[libnet-dbus-perl] 203/335: Switch from XML::Grove to use XML::Twig for parsing
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:57 UTC 2015
This is an automated email from the git hooks/post-receive script.
intrigeri pushed a commit to branch experimental
in repository libnet-dbus-perl.
commit 11cf0b0ffbab11245e3f106bc48158d72402fbee
Author: Daniel P. Berrange <berrange at redhat.com>
Date: Mon Jun 12 20:23:54 2006 -0400
Switch from XML::Grove to use XML::Twig for parsing
---
CHANGES | 5 ++
Makefile.PL | 3 +-
Net-DBus.spec.PL | 10 +--
README | 2 +-
lib/Net/DBus/Binding/Introspector.pm | 150 +++++++++++++++--------------------
5 files changed, 75 insertions(+), 95 deletions(-)
diff --git a/CHANGES b/CHANGES
index bb00360..d34963c 100644
--- a/CHANGES
+++ b/CHANGES
@@ -3,6 +3,11 @@ Changes since 0.33.2
- Fixed parsing of introspection data if there are processing
instructions, or other non-data nodes before the root element.
+ - Replace use of XML::Grove with XML::Twig when parsing the
+ introspection XML documents, since the former has not had any
+ updates / bug fixes since 1999(!), and several people have
+ reported problems using it on Perl 5.8.x
+
Changes since 0.33.1
- Fixed handling of variants in introspection data
diff --git a/Makefile.PL b/Makefile.PL
index 4118a40..ad980a1 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -19,8 +19,7 @@ WriteMakefile(
'PREREQ_PM' => {
'Test::More' => 0,
'Time::HiRes' => 0,
- 'XML::Grove' => 0,
- 'XML::Parser' => 0
+ 'XML::Twig' => 0,
},
# 'ABSTRACT_FROM' => 'lib/Net/DBus.pm',
'AUTHOR' => 'Daniel Berrange <dan at berrange.com>',
diff --git a/Net-DBus.spec.PL b/Net-DBus.spec.PL
index ac587b0..0b05de2 100644
--- a/Net-DBus.spec.PL
+++ b/Net-DBus.spec.PL
@@ -49,19 +49,17 @@ Source: %{appname}-%{version}.tar.gz
BuildRoot: /var/tmp/%{appname}-%{version}-root
#BuildArchitectures: noarch
Requires: perl = %{perlversion}
-# For XML::Parser::PerlSAX & friends
-Requires: perl-libxml-perl
-Requires: perl-XML-Grove
+# For XML::Twig
+Requires: perl-XML-Twig
# For Time::HiRes
Requires: perl-Time-HiRes
Requires: dbus >= 0.33
BuildRequires: dbus-devel >= 0.33
-BuildRequires: perl-XML-Grove
-BuildRequires: perl-libxml-perl
+BuildRequires: perl-XML-Twig
%description
Provides a Perl API to the DBus message system
-
+
%prep
%setup -q -n %{appname}-%{version}
diff --git a/README b/README
index 22da478..d21f6b5 100644
--- a/README
+++ b/README
@@ -49,7 +49,7 @@ In keeping with the C API, the Perl DBus implementation
has minimal external dependancies:
Time::HiRes
- XML::Grove
+ XML::Twig
XML::Parser
And to run the test suite:
diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index 19e6690..fb66e1a 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -56,8 +56,7 @@ use 5.006;
use strict;
use warnings;
use Carp;
-use XML::Grove::Builder;
-use XML::Parser::PerlSAX;
+use XML::Twig;
use Net::DBus::Binding::Message;
@@ -573,36 +572,27 @@ sub _parse {
my $self = shift;
my $xml = shift;
- my $grove_builder = XML::Grove::Builder->new;
- my $parser = XML::Parser::PerlSAX->new(Handler => $grove_builder);
- my $document = $parser->parse ( Source => { String => $xml } );
+ my $twig = XML::Twig->new();
+ $twig->parse($xml);
- foreach my $child (@{$document->{Contents}}) {
- if (ref($child) eq "XML::Grove::Element") {
- $self->_parse_node($child);
- }
- }
+ $self->_parse_node($twig->root);
}
sub _parse_node {
my $self = shift;
my $node = shift;
- $self->{object_path} = $node->{Attributes}->{name} if defined $node->{Attributes}->{name};
+ $self->{object_path} = $node->att("name") if defined $node->att("name");
die "no object path provided" unless defined $self->{object_path};
$self->{children} = [];
- foreach my $child (@{$node->{Contents}}) {
- if (ref($child) eq "XML::Grove::Element") {
- if ($child->{Name} eq "interface") {
- $self->_parse_interface($child);
- } elsif ($child->{Name} eq "node") {
- my $subcont = $child->{Contents};
- if ($#{$subcont} == -1) {
- push @{$self->{children}}, $child->{Attributes}->{name};
- } else {
- push @{$self->{children}}, $self->new(node => $child);
- }
- }
+ foreach my $child ($node->children("interface")) {
+ $self->_parse_interface($child);
+ }
+ foreach my $child ($node->children("node")) {
+ if (!$child->has_children()) {
+ push @{$self->{children}}, $child->att("name");
+ } else {
+ push @{$self->{children}}, $self->new(node => $child);
}
}
}
@@ -611,23 +601,21 @@ sub _parse_interface {
my $self = shift;
my $node = shift;
- my $name = $node->{Attributes}->{name};
+ my $name = $node->att("name");
$self->{interfaces}->{$name} = {
methods => {},
signals => {},
props => {},
};
- foreach my $child (@{$node->{Contents}}) {
- if (ref($child) eq "XML::Grove::Element") {
- if ($child->{Name} eq "method") {
- $self->_parse_method($child, $name);
- } elsif ($child->{Name} eq "signal") {
- $self->_parse_signal($child, $name);
- } elsif ($child->{Name} eq "property") {
- $self->_parse_property($child, $name);
- }
- }
+ foreach my $child ($node->children("method")) {
+ $self->_parse_method($child, $name);
+ }
+ foreach my $child ($node->children("signal")) {
+ $self->_parse_signal($child, $name);
+ }
+ foreach my $child ($node->children("property")) {
+ $self->_parse_property($child, $name);
}
}
@@ -636,34 +624,31 @@ sub _parse_method {
my $node = shift;
my $interface = shift;
- my $name = $node->{Attributes}->{name};
+ my $name = $node->att("name");
my @params;
my @returns;
my $deprecated = 0;
my $no_reply = 0;
- foreach my $child (@{$node->{Contents}}) {
- if (ref($child) eq "XML::Grove::Element") {
- if ($child->{Name} eq "arg") {
- my $type = $child->{Attributes}->{type};
- my $direction = $child->{Attributes}->{direction};
-
- my @sig = split //, $type;
- my @type = $self->_parse_type(\@sig);
- if (!defined $direction || $direction eq "in") {
- push @params, @type;
- } elsif ($direction eq "out") {
- push @returns, @type;
- }
- } elsif ($child->{Name} eq "annotation") {
- my $name = $child->{Attributes}->{name};
- my $value = $child->{Attributes}->{value};
-
- if ($name eq "org.freedesktop.DBus.Deprecated") {
- $deprecated = 1 if lc($value) eq "true";
- } elsif ($name eq "org.freedesktop.DBus.Method.NoReply") {
- $no_reply = 1 if lc($value) eq "true";
- }
- }
+ foreach my $child ($node->children("arg")) {
+ my $type = $child->att("type");
+ my $direction = $child->att("direction");
+
+ my @sig = split //, $type;
+ my @type = $self->_parse_type(\@sig);
+ if (!defined $direction || $direction eq "in") {
+ push @params, @type;
+ } elsif ($direction eq "out") {
+ push @returns, @type;
+ }
+ }
+ foreach my $child ($node->children("annotation")) {
+ my $name = $child->att("name");
+ my $value = $child->att("value");
+
+ if ($name eq "org.freedesktop.DBus.Deprecated") {
+ $deprecated = 1 if lc($value) eq "true";
+ } elsif ($name eq "org.freedesktop.DBus.Method.NoReply") {
+ $no_reply = 1 if lc($value) eq "true";
}
}
@@ -736,24 +721,21 @@ sub _parse_signal {
my $node = shift;
my $interface = shift;
- my $name = $node->{Attributes}->{name};
+ my $name = $node->att("name");
my @params;
my $deprecated = 0;
- foreach my $child (@{$node->{Contents}}) {
- if (ref($child) eq "XML::Grove::Element") {
- if ($child->{Name} eq "arg") {
- my $type = $child->{Attributes}->{type};
- my @sig = split //, $type;
- my @type = $self->_parse_type(\@sig);
- push @params, @type;
- } elsif ($child->{Name} eq "annotation") {
- my $name = $child->{Attributes}->{name};
- my $value = $child->{Attributes}->{value};
-
- if ($name eq "org.freedesktop.DBus.Deprecated") {
- $deprecated = 1 if lc($value) eq "true";
- }
- }
+ foreach my $child ($node->children("arg")) {
+ my $type = $child->att("type");
+ my @sig = split //, $type;
+ my @type = $self->_parse_type(\@sig);
+ push @params, @type;
+ }
+ foreach my $child ($node->children("annotation")) {
+ my $name = $child->att("name");
+ my $value = $child->att("value");
+
+ if ($name eq "org.freedesktop.DBus.Deprecated") {
+ $deprecated = 1 if lc($value) eq "true";
}
}
@@ -768,24 +750,20 @@ sub _parse_property {
my $node = shift;
my $interface = shift;
- my $name = $node->{Attributes}->{name};
- my $access = $node->{Attributes}->{access};
+ my $name = $node->att("name");
+ my $access = $node->att("access");
my $deprecated = 0;
- foreach my $child (@{$node->{Contents}}) {
- if (ref($child) eq "XML::Grove::Element") {
- if ($child->{Name} eq "annotation") {
- my $name = $child->{Attributes}->{name};
- my $value = $child->{Attributes}->{value};
+ foreach my $child ($node->children("annotation")) {
+ my $name = $child->att("name");
+ my $value = $child->att("value");
- if ($name eq "org.freedesktop.DBus.Deprecated") {
- $deprecated = 1 if lc($value) eq "true";
- }
- }
+ if ($name eq "org.freedesktop.DBus.Deprecated") {
+ $deprecated = 1 if lc($value) eq "true";
}
}
$self->{interfaces}->{$interface}->{props}->{$name} = {
- type => $self->_parse_type([$node->{Attributes}->{type}]),
+ type => $self->_parse_type([$node->att("type")]),
access => $access,
deprecated => $deprecated,
};
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git
More information about the Pkg-perl-cvs-commits
mailing list