[libnet-dbus-perl] 201/335: Fixed parsing of introspection data when there are processing instructions before root node
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:56 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 c17d0094986e9dd0dcb72070e640f13f9a4a62e1
Author: Daniel P. Berrange <berrange at redhat.com>
Date: Wed Jun 7 23:10:57 2006 -0400
Fixed parsing of introspection data when there are processing instructions before root node
---
AUTHORS | 1 +
CHANGES | 4 +
lib/Net/DBus/Binding/Introspector.pm | 148 ++++++++++++++++-------------------
3 files changed, 73 insertions(+), 80 deletions(-)
diff --git a/AUTHORS b/AUTHORS
index 69d90fa..22e55ed 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -11,6 +11,7 @@ from
Carlos Garnacho <carlosg-at-gnome-dot-org>
Emmanuele Bassi <ebassi-at-gmail-dot-com>
Olivier Blin <oblin-at-mandriva-dot-com>
+ Jack <ms419-at-freezone-dot-co-dot-uk>
[...send patches to get your name here!]
diff --git a/CHANGES b/CHANGES
index 693e0c0..bb00360 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,3 +1,7 @@
+Changes since 0.33.2
+
+ - Fixed parsing of introspection data if there are processing
+ instructions, or other non-data nodes before the root element.
Changes since 0.33.1
diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index b37c170..19e6690 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -40,7 +40,7 @@ Net::DBus::Binding::Introspector - Handler for object introspection data
=head1 DESCRIPTION
This class is responsible for managing introspection data, and
-answering questions about it. This is not intended for use by
+answering questions about it. This is not intended for use by
application developers, whom should instead consult the higher
level API in L<Net::DBus::Exporter>.
@@ -72,7 +72,7 @@ our %simple_type_map = (
"uint32" => &Net::DBus::Binding::Message::TYPE_UINT32,
"int64" => &Net::DBus::Binding::Message::TYPE_INT64,
"uint64" => &Net::DBus::Binding::Message::TYPE_UINT64,
- "objectpath" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
+ "objectpath" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
"signature" => &Net::DBus::Binding::Message::TYPE_SIGNATURE,
);
@@ -87,7 +87,7 @@ our %simple_type_rev_map = (
&Net::DBus::Binding::Message::TYPE_UINT32 => "uint32",
&Net::DBus::Binding::Message::TYPE_INT64 => "int64",
&Net::DBus::Binding::Message::TYPE_UINT64 => "uint64",
- &Net::DBus::Binding::Message::TYPE_OBJECT_PATH => "objectpath",
+ &Net::DBus::Binding::Message::TYPE_OBJECT_PATH => "objectpath",
&Net::DBus::Binding::Message::TYPE_SIGNATURE => "signature",
);
@@ -112,7 +112,7 @@ our %compound_type_map = (
);
=item my $ins = Net::DBus::Binding::Introspector->new(object_path => $object_path,
- xml => $xml);
+ xml => $xml);
Creates a new introspection data manager for the object registered
at the path specified for the C<object_path> parameter. The optional
@@ -121,7 +121,6 @@ metadata from an XML document.
=cut
-
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
@@ -157,8 +156,7 @@ sub new {
$self->add_signal("NameAcquired", ["string"], "org.freedesktop.DBus");
}
}
-
-
+
return $self;
}
@@ -189,7 +187,7 @@ an interface with the name C<$name>; returns false otherwise.
sub has_interface {
my $self = shift;
my $name = shift;
-
+
return exists $self->{interfaces}->{$name} ? 1 : 0;
}
@@ -203,7 +201,7 @@ contain a method called C<$name>. This may be an empty list.
sub has_method {
my $self = shift;
my $name = shift;
-
+
my @interfaces;
foreach my $interface (keys %{$self->{interfaces}}) {
if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) {
@@ -214,7 +212,6 @@ sub has_method {
return @interfaces;
}
-
=item my @interfaces = $ins->has_signal($name)
Return a list of all interfaces provided by the object, which
@@ -225,7 +222,7 @@ contain a signal called C<$name>. This may be an empty list.
sub has_signal {
my $self = shift;
my $name = shift;
-
+
my @interfaces;
foreach my $interface (keys %{$self->{interfaces}}) {
if (exists $self->{interfaces}->{$interface}->{signals}->{$name}) {
@@ -235,7 +232,6 @@ sub has_signal {
return @interfaces;
}
-
=item my @interfaces = $ins->has_property($name)
Return a list of all interfaces provided by the object, which
@@ -243,11 +239,10 @@ contain a property called C<$name>. This may be an empty list.
=cut
-
sub has_property {
my $self = shift;
my $name = shift;
-
+
if (@_) {
my $interface = shift;
return () unless exists $self->{interfaces}->{$interface};
@@ -264,18 +259,16 @@ sub has_property {
}
}
-
=item $ins->add_method($name, $params, $returns, $interface, $attributes);
Register the object as providing a method called C<$name> accepting parameters
-whose types are declared by C<$params> and returning values whose type
+whose types are declared by C<$params> and returning values whose type
are declared by C<$returns>. The method will be scoped to the inteface
named by C<$interface>. The C<$attributes> parameter is a hash reference
for annotating the method.
=cut
-
sub add_method {
my $self = shift;
my $name = shift;
@@ -285,7 +278,7 @@ sub add_method {
my $attributes = shift;
$self->add_interface($interface);
- $self->{interfaces}->{$interface}->{methods}->{$name} = {
+ $self->{interfaces}->{$interface}->{methods}->{$name} = {
params => $params,
returns => $returns,
deprecated => $attributes->{deprecated} ? 1 : 0,
@@ -293,7 +286,6 @@ sub add_method {
};
}
-
=item $ins->add_signal($name, $params, $interface, $attributes);
Register the object as providing a signal called C<$name> with parameters
@@ -303,7 +295,6 @@ for annotating the signal.
=cut
-
sub add_signal {
my $self = shift;
my $name = shift;
@@ -328,7 +319,6 @@ for annotating the signal.
=cut
-
sub add_property {
my $self = shift;
my $name = shift;
@@ -339,7 +329,7 @@ sub add_property {
$self->add_interface($interface);
$self->{interfaces}->{$interface}->{props}->{$name} = {
- type => $type,
+ type => $type,
access => $access,
deprecated => $attributes->{deprecated} ? 1 : 0,
};
@@ -356,7 +346,7 @@ sub is_method_deprecated {
my $self = shift;
my $name = shift;
my $interface = shift;
-
+
die "no interface $interface" unless exists $self->{interfaces}->{$interface};
die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name};
return 1 if $self->{interfaces}->{$interface}->{methods}->{$name}->{deprecated};
@@ -374,7 +364,7 @@ sub is_signal_deprecated {
my $self = shift;
my $name = shift;
my $interface = shift;
-
+
die "no interface $interface" unless exists $self->{interfaces}->{$interface};
die "no signal $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{signals}->{$name};
return 1 if $self->{interfaces}->{$interface}->{signals}->{$name}->{deprecated};
@@ -392,7 +382,7 @@ sub is_property_deprecated {
my $self = shift;
my $name = shift;
my $interface = shift;
-
+
die "no interface $interface" unless exists $self->{interfaces}->{$interface};
die "no property $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{props}->{$name};
return 1 if $self->{interfaces}->{$interface}->{props}->{$name}->{deprecated};
@@ -426,7 +416,7 @@ by the object.
sub list_interfaces {
my $self = shift;
-
+
return keys %{$self->{interfaces}};
}
@@ -469,7 +459,6 @@ sub list_properties {
return keys %{$self->{interfaces}->{$interface}->{props}};
}
-
=item my @paths = $self->list_children;
Returns a list of object paths representing all the children
@@ -538,7 +527,7 @@ sub get_signal_params {
=item my $type = $ins->get_property_type($interface, $name)
-Returns the declared data type for property called C<$name> within
+Returns the declared data type for property called C<$name> within
the interface C<$interface>.
=cut
@@ -552,7 +541,7 @@ sub get_property_type {
=item my $bool = $ins->is_property_readable($interface, $name);
-Returns a true value if the property called C<$name> within the
+Returns a true value if the property called C<$name> within the
interface C<$interface> can have its value read.
=cut
@@ -567,7 +556,7 @@ sub is_property_readable {
=item my $bool = $ins->is_property_writable($interface, $name);
-Returns a true value if the property called C<$name> within the
+Returns a true value if the property called C<$name> within the
interface C<$interface> can have its value written to.
=cut
@@ -580,7 +569,6 @@ sub is_property_writable {
return $access eq "readwrite" || $access eq "write" ? 1 : 0;
}
-
sub _parse {
my $self = shift;
my $xml = shift;
@@ -588,9 +576,12 @@ sub _parse {
my $grove_builder = XML::Grove::Builder->new;
my $parser = XML::Parser::PerlSAX->new(Handler => $grove_builder);
my $document = $parser->parse ( Source => { String => $xml } );
-
- my $root = $document->{Contents}->[0];
- $self->_parse_node($root);
+
+ foreach my $child (@{$document->{Contents}}) {
+ if (ref($child) eq "XML::Grove::Element") {
+ $self->_parse_node($child);
+ }
+ }
}
sub _parse_node {
@@ -619,14 +610,14 @@ sub _parse_node {
sub _parse_interface {
my $self = shift;
my $node = shift;
-
+
my $name = $node->{Attributes}->{name};
$self->{interfaces}->{$name} = {
methods => {},
signals => {},
props => {},
};
-
+
foreach my $child (@{$node->{Contents}}) {
if (ref($child) eq "XML::Grove::Element") {
if ($child->{Name} eq "method") {
@@ -640,12 +631,11 @@ sub _parse_interface {
}
}
-
sub _parse_method {
my $self = shift;
my $node = shift;
my $interface = shift;
-
+
my $name = $node->{Attributes}->{name};
my @params;
my @returns;
@@ -656,7 +646,7 @@ sub _parse_method {
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") {
@@ -667,7 +657,7 @@ sub _parse_method {
} 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") {
@@ -688,7 +678,7 @@ sub _parse_method {
sub _parse_type {
my $self = shift;
my $sig = shift;
-
+
my $root = [];
my $current = $root;
my @cont;
@@ -728,11 +718,11 @@ sub _parse_type {
if ($current->[0] eq "array") {
$current = pop @cont;
}
- } elsif ($type eq "v") {
- push @{$current}, "variant";
- if ($current->[0] eq "array") {
- $current = pop @cont;
- }
+ } elsif ($type eq "v") {
+ push @{$current}, "variant";
+ if ($current->[0] eq "array") {
+ $current = pop @cont;
+ }
} else {
die "unknown type sig '$type'";
}
@@ -745,7 +735,7 @@ sub _parse_signal {
my $self = shift;
my $node = shift;
my $interface = shift;
-
+
my $name = $node->{Attributes}->{name};
my @params;
my $deprecated = 0;
@@ -759,14 +749,14 @@ sub _parse_signal {
} 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";
}
}
}
}
-
+
$self->{interfaces}->{$interface}->{signals}->{$name} = {
params => \@params,
deprecated => $deprecated,
@@ -777,24 +767,24 @@ sub _parse_property {
my $self = shift;
my $node = shift;
my $interface = shift;
-
+
my $name = $node->{Attributes}->{name};
my $access = $node->{Attributes}->{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};
-
+
if ($name eq "org.freedesktop.DBus.Deprecated") {
$deprecated = 1 if lc($value) eq "true";
}
}
}
}
- $self->{interfaces}->{$interface}->{props}->{$name} = {
+ $self->{interfaces}->{$interface}->{props}->{$name} = {
type => $self->_parse_type([$node->{Attributes}->{type}]),
access => $access,
deprecated => $deprecated,
@@ -810,10 +800,10 @@ state of the introspection data.
sub format {
my $self = shift;
-
+
my $xml = '<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"' . "\n";
$xml .= '"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">' . "\n";
-
+
return $xml . $self->to_xml("");
}
@@ -821,7 +811,7 @@ sub format {
Returns a string containing an XML fragment representing the
state of the introspection data. This is basically the same
-as the C<format> method, but without the leading doctype
+as the C<format> method, but without the leading doctype
declaration.
=cut
@@ -829,22 +819,22 @@ declaration.
sub to_xml {
my $self = shift;
my $indent = shift;
-
+
my $xml = '';
$xml .= $indent . '<node name="' . $self->{object_path} . '">' . "\n";
-
+
foreach my $name (sort { $a cmp $b } keys %{$self->{interfaces}}) {
my $interface = $self->{interfaces}->{$name};
$xml .= $indent . ' <interface name="' . $name . '">' . "\n";
foreach my $mname (sort { $a cmp $b } keys %{$interface->{methods}}) {
my $method = $interface->{methods}->{$mname};
$xml .= $indent . ' <method name="' . $mname . '">' . "\n";
-
+
foreach my $type (@{$method->{params}}) {
next if ! ref($type) && exists $magic_type_map{$type};
$xml .= $indent . ' <arg type="' . $self->to_xml_type($type) . '" direction="in"/>' . "\n";
}
-
+
foreach my $type (@{$method->{returns}}) {
next if ! ref($type) && exists $magic_type_map{$type};
$xml .= $indent . ' <arg type="' . $self->to_xml_type($type) . '" direction="out"/>' . "\n";
@@ -860,7 +850,7 @@ sub to_xml {
foreach my $sname (sort { $a cmp $b } keys %{$interface->{signals}}) {
my $signal = $interface->{signals}->{$sname};
$xml .= $indent . ' <signal name="' . $sname . '">' . "\n";
-
+
foreach my $type (@{$signal->{params}}) {
next if ! ref($type) && exists $magic_type_map{$type};
$xml .= $indent . ' <arg type="' . $self->to_xml_type($type) . '"/>' . "\n";
@@ -870,22 +860,22 @@ sub to_xml {
}
$xml .= $indent . ' </signal>' . "\n";
}
-
+
foreach my $pname (sort { $a cmp $b } keys %{$interface->{props}}) {
my $prop = $interface->{props}->{$pname};
my $type = $interface->{props}->{$pname}->{type};
my $access = $interface->{props}->{$pname}->{access};
if ($prop->{deprecated}) {
- $xml .= $indent . ' <property name="' . $pname . '" type="' .
+ $xml .= $indent . ' <property name="' . $pname . '" type="' .
$self->to_xml_type($type) . '" access="' . $access . '">' . "\n";
$xml .= $indent . ' <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
$xml .= $indent . ' </property>' . "\n";
} else {
- $xml .= $indent . ' <property name="' . $pname . '" type="' .
+ $xml .= $indent . ' <property name="' . $pname . '" type="' .
$self->to_xml_type($type) . '" access="' . $access . '"/>' . "\n";
}
}
-
+
$xml .= $indent . ' </interface>' . "\n";
}
@@ -919,7 +909,7 @@ sub to_xml_type {
$sig .= chr($compound_type_map{$type->[0]});
$sig .= $self->to_xml_type($type->[1]);
} elsif ($type->[0] eq "struct") {
- $sig .= "(";
+ $sig .= "(";
for (my $i = 1 ; $i <= $#{$type} ; $i++) {
$sig .= $self->to_xml_type($type->[$i]);
}
@@ -954,7 +944,7 @@ sub to_xml_type {
Append a set of values <@args> to a message object C<$message>.
The C<$type> parameter is either C<signal> or C<method> and
C<$direction> is either C<params> or C<returns>. The introspection
-data will be queried to obtain the declared data types & the
+data will be queried to obtain the declared data types & the
argument marshalling accordingly.
=cut
@@ -972,7 +962,7 @@ sub encode {
if ($interface) {
die "no interface '$interface' in introspection data for object '" . $self->get_object_path . "' encoding $type '$name'\n"
unless exists $self->{interfaces}->{$interface};
- die "no introspection data when encoding $type '$name' in object " . $self->get_object_path . "\n"
+ die "no introspection data when encoding $type '$name' in object " . $self->get_object_path . "\n"
unless exists $self->{interfaces}->{$interface}->{$type}->{$name};
} else {
foreach my $in (keys %{$self->{interfaces}}) {
@@ -981,13 +971,13 @@ sub encode {
}
}
if (!$interface) {
- die "no interface in introspection data for object " . $self->get_object_path . " encoding $type '$name'\n"
+ die "no interface in introspection data for object " . $self->get_object_path . " encoding $type '$name'\n"
}
}
my @types =
@{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
-
+
# If you don't explicitly 'return ()' from methods, Perl
# will always return a single element representing the
# return value of the last command executed in the method.
@@ -999,7 +989,7 @@ sub encode {
@args = ();
}
- die "expected " . int(@types) . " $direction, but got " . int(@args)
+ die "expected " . int(@types) . " $direction, but got " . int(@args)
unless $#types == $#args;
my $iter = $message->iterator(1);
@@ -1008,7 +998,6 @@ sub encode {
}
}
-
sub _convert {
my $self = shift;
my @in = @_;
@@ -1034,13 +1023,12 @@ sub _convert {
return @out;
}
-
=item my @args = $ins->decode($message, $type, $name, $direction)
Unmarshalls the contents of a message object C<$message>.
The C<$type> parameter is either C<signal> or C<method> and
C<$direction> is either C<params> or C<returns>. The introspection
-data will be queried to obtain the declared data types & the
+data will be queried to obtain the declared data types & the
arguments unmarshalled accordingly.
=cut
@@ -1057,7 +1045,7 @@ sub decode {
if ($interface) {
die "no interface '$interface' in introspection data for object '" . $self->get_object_path . "' decoding $type '$name'\n"
unless exists $self->{interfaces}->{$interface};
- die "no introspection data when encoding $type '$name' in object " . $self->get_object_path . "\n"
+ die "no introspection data when encoding $type '$name' in object " . $self->get_object_path . "\n"
unless exists $self->{interfaces}->{$interface}->{$type}->{$name};
} else {
foreach my $in (keys %{$self->{interfaces}}) {
@@ -1066,27 +1054,27 @@ sub decode {
}
}
if (!$interface) {
- die "no interface in introspection data for object " . $self->get_object_path . " decoding $type '$name'\n"
+ die "no interface in introspection data for object " . $self->get_object_path . " decoding $type '$name'\n"
}
}
- my @types =
+ my @types =
@{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
# If there are no types defined, just return the
# actual data from the message, assuming the introspection
# data was partial.
- return $message->get_args_list
+ return $message->get_args_list
unless @types;
my $iter = $message->iterator;
-
+
my @rawtypes = $self->_convert(@types);
my @ret;
do {
my $type = shift @types;
my $rawtype = shift @rawtypes;
-
+
if (exists $magic_type_map{$type}) {
push @ret, &$rawtype($message);
} else {
--
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