[libnet-dbus-perl] 267/335: Fix introspection XML format for exported objects with children. Based on work from Dave Belser
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:08:08 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 f90f2828236d83592e7c26fb5a7d35794ce0381e
Author: Daniel P. Berrange <berrange at redhat.com>
Date: Sat Feb 16 14:58:21 2008 -0500
Fix introspection XML format for exported objects with children. Based on work from Dave Belser
---
lib/Net/DBus/Binding/Introspector.pm | 41 ++++++--
lib/Net/DBus/Exporter.pm | 13 +--
lib/Net/DBus/Object.pm | 18 +++-
lib/Net/DBus/Test/MockObject.pm | 5 +
t/45-exporter.t | 7 +-
t/50-object-introspect.t | 2 +-
t/56-scalar-param-typing.t | 4 +-
t/60-object-props.t | 2 +-
t/65-object-magic.t | 2 +-
t/66-child-objects.t | 188 +++++++++++++++++++++++++++++++++++
10 files changed, 250 insertions(+), 32 deletions(-)
diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index 46debae..83bc883 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -144,14 +144,15 @@ sub new {
$self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
$self->_parse_node($params{node});
} else {
- $self->{object_path} = exists $params{object_path} ? $params{object_path} : die "object_path parameter is required";
+ $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
$self->{interfaces} = $params{interfaces} if exists $params{interfaces};
$self->{children} = exists $params{children} ? $params{children} : [];
}
# Some versions of dbus failed to include signals in introspection data
# so this code adds them, letting us keep compatability with old versions
- if ($self->{object_path} eq "/org/freedesktop/DBus") {
+ if (defined $self->{object_path} &&
+ $self->{object_path} eq "/org/freedesktop/DBus") {
if (!$self->has_signal("NameOwnerChanged")) {
$self->add_signal("NameOwnerChanged", ["string","string","string"], "org.freedesktop.DBus");
}
@@ -837,20 +838,23 @@ sub _parse_property {
};
}
-=item my $xml = $ins->format
+=item my $xml = $ins->format([$obj])
Return a string containing an XML document representing the
-state of the introspection data.
+state of the introspection data. The optional C<$obj> parameter
+can be an instance of L<Net::DBus::Object> to include object
+specific information in the XML (eg child nodes).
=cut
sub format {
my $self = shift;
+ my $obj = 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("");
+ return $xml . $self->to_xml("", $obj);
}
=item my $xml_fragment = $ins->to_xml
@@ -865,9 +869,14 @@ declaration.
sub to_xml {
my $self = shift;
my $indent = shift;
+ my $obj = shift;
my $xml = '';
- $xml .= $indent . '<node name="' . $self->{object_path} . '">' . "\n";
+ my $path = $obj ? $obj->get_object_path : $self->{object_path};
+ unless (defined $path) {
+ die "no object_path for introspector, and no object supplied";
+ }
+ $xml .= $indent . '<node name="' . $path . '">' . "\n";
foreach my $name (sort { $a cmp $b } keys %{$self->{interfaces}}) {
my $interface = $self->{interfaces}->{$name};
@@ -933,13 +942,23 @@ sub to_xml {
$xml .= $indent . ' </interface>' . "\n";
}
- foreach my $child (@{$self->{children}}) {
- if (ref($child) eq __PACKAGE__) {
- $xml .= $child->to_xml($indent . " ");
- } else {
- $xml .= $indent . ' <node name="' . $child . '"/>' . "\n";
+ #
+ # Interfaces don't have children, objects do
+ #
+ if ($obj) {
+ foreach ( $obj->_get_sub_nodes ) {
+ $xml .= $indent . ' <node name="/' . $_ . '"/>' . "\n";
+ }
+ } else {
+ foreach my $child (@{$self->{children}}) {
+ if (ref($child) eq __PACKAGE__) {
+ $xml .= $child->to_xml($indent . " ");
+ } else {
+ $xml .= $indent . ' <node name="' . $child . '"/>' . "\n";
+ }
}
}
+
$xml .= $indent . "</node>\n";
}
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index c64ddb4..9cfafff 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -280,14 +280,8 @@ sub import {
}
sub _dbus_introspector {
- my $object = shift;
my $class = shift;
- $class = ref($object) unless $class;
- die "no introspection data available for '" .
- $object->get_object_path .
- "' and object is not cast to any interface" unless $class;
-
if (!exists $dbus_exports{$class}) {
# If this class has not been exported, lets look
# at the parent class & return its introspection
@@ -301,7 +295,7 @@ sub _dbus_introspector {
# choice of not supporting introspection
next if $parent eq "Net::DBus::Object";
- my $ins = &_dbus_introspector($object, $parent);
+ my $ins = &_dbus_introspector($parent);
if ($ins) {
return $ins;
}
@@ -311,9 +305,8 @@ sub _dbus_introspector {
}
unless (exists $dbus_introspectors{$class}) {
- my $is = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
-
- &_dbus_introspector_add(ref($object), $is);
+ my $is = Net::DBus::Binding::Introspector->new();
+ &_dbus_introspector_add($class, $is);
$dbus_introspectors{$class} = $is;
}
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 4e98c7c..728ff09 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -261,6 +261,20 @@ sub _unregister_child {
delete $self->{children}->{$object->get_object_path};
}
+# return a list of sub nodes for this object
+sub _get_sub_nodes {
+ my $self = shift;
+ my %uniq;
+
+ my $base = "$self->{object_path}/";
+ foreach ( keys( %{$self->{children}} ) ) {
+ m/^$base([^\/]+)/;
+ $uniq{$1} = 1;
+ }
+
+ return sort( keys( %uniq ) );
+}
+
=item my $service = $object->get_service
Retrieves the L<Net::DBus::Service> object within which this
@@ -463,7 +477,7 @@ sub _dispatch {
if ($method_name eq "Introspect" &&
$self->_introspector &&
$ENABLE_INTROSPECT) {
- my $xml = $self->_introspector->format;
+ my $xml = $self->_introspector->format($self);
$reply = $connection->make_method_return_message($message);
$self->_introspector->encode($reply, "methods", $method_name, "returns", $xml);
@@ -614,7 +628,7 @@ sub _introspector {
my $self = shift;
if (!$self->{introspected}) {
- $self->{introspector} = Net::DBus::Exporter::_dbus_introspector($self);
+ $self->{introspector} = Net::DBus::Exporter::_dbus_introspector(ref($self));
$self->{introspected} = 1;
}
return $self->{introspector};
diff --git a/lib/Net/DBus/Test/MockObject.pm b/lib/Net/DBus/Test/MockObject.pm
index a93a983..3ae45cc 100644
--- a/lib/Net/DBus/Test/MockObject.pm
+++ b/lib/Net/DBus/Test/MockObject.pm
@@ -107,6 +107,11 @@ sub new {
}
+sub _get_sub_nodes {
+ my $self = shift;
+ return [];
+}
+
=item my $service = $object->get_service
Retrieves the L<Net::DBus::Service> object within which this
diff --git a/t/45-exporter.t b/t/45-exporter.t
index 4c853fc..ce70ac1 100644
--- a/t/45-exporter.t
+++ b/t/45-exporter.t
@@ -1,6 +1,6 @@
# -*- perl -*-
-use Test::More tests => 94;
+use Test::More tests => 93;
use strict;
use warnings;
@@ -51,9 +51,8 @@ dbus_method("NoArgsInterfaceAnnotate", [],["int32"], "org.example.OtherObject",
-my $ins = Net::DBus::Exporter::_dbus_introspector($obj);
+my $ins = Net::DBus::Exporter::_dbus_introspector(ref($obj));
-is($ins->get_object_path, "/org/example/MyObject", "object path");
ok($ins->has_interface("org.example.MyObject"), "interface registration");
ok(!$ins->has_interface("org.example.BogusObject"), "-ve interface registration");
@@ -151,7 +150,7 @@ my $wantxml = <<EOF;
</node>
EOF
-is ($ins->format, $wantxml, "xml matches");
+is ($ins->format($obj), $wantxml, "xml matches");
&check_method($ins, "Everything", ["string"], ["int32"], "org.example.MyObject", 0, 0);
diff --git a/t/50-object-introspect.t b/t/50-object-introspect.t
index 906ed65..7090308 100644
--- a/t/50-object-introspect.t
+++ b/t/50-object-introspect.t
@@ -16,7 +16,7 @@ my $object = Net::DBus::Object->new($service, "/org/example/Object/OtherObject")
my $introspector = $object->_introspector;
-my $xml_got = $introspector->format();
+my $xml_got = $introspector->format($object);
my $xml_expect = <<EOF;
<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
diff --git a/t/56-scalar-param-typing.t b/t/56-scalar-param-typing.t
index c2f044a..98d12ff 100644
--- a/t/56-scalar-param-typing.t
+++ b/t/56-scalar-param-typing.t
@@ -704,7 +704,7 @@ TEST_MANUAL_TYPING: {
TEST_INTROSPECT_TYPING: {
my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
- my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
+ my $ins = Net::DBus::Binding::Introspector->new();
$ins->add_method("ScalarString", ["string"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarInt16", ["int16"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarUInt16", ["uint16"], [], "org.example.MyObject", {}, []);
@@ -714,7 +714,7 @@ TEST_INTROSPECT_TYPING: {
$ins->add_method("ScalarByte", ["byte"], [], "org.example.MyObject", {}, []);
$ins->add_method("ScalarBoolean", ["bool"], [], "org.example.MyObject", {}, []);
$object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
- reply => { return => [ $ins->format ] });
+ reply => { return => [ $ins->format($object) ] });
##### String tests
diff --git a/t/60-object-props.t b/t/60-object-props.t
index 5ef080b..003e2ed 100644
--- a/t/60-object-props.t
+++ b/t/60-object-props.t
@@ -63,7 +63,7 @@ my $object = MyObject->new($service, "/org/example/MyObject");
my $introspector = $object->_introspector;
-my $xml_got = $introspector->format();
+my $xml_got = $introspector->format($object);
my $xml_expect = <<EOF;
<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
diff --git a/t/65-object-magic.t b/t/65-object-magic.t
index f3b9028..3da9ace 100644
--- a/t/65-object-magic.t
+++ b/t/65-object-magic.t
@@ -57,7 +57,7 @@ my $object = MyObject->new($service, "/org/example/MyObject");
my $introspector = $object->_introspector;
-my $xml_got = $introspector->format();
+my $xml_got = $introspector->format($object);
my $xml_expect = <<EOF;
<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
diff --git a/t/66-child-objects.t b/t/66-child-objects.t
new file mode 100644
index 0000000..1f942b8
--- /dev/null
+++ b/t/66-child-objects.t
@@ -0,0 +1,188 @@
+# -*- perl -*-
+use Test::More tests => 5;
+
+use strict;
+use warnings;
+
+BEGIN {
+ use_ok('Net::DBus::Binding::Introspector');
+ use_ok('Net::DBus::Object');
+};
+
+package ObjectType1;
+
+use base qw(Net::DBus::Object);
+use Net::DBus::Exporter qw(com.dbelser.test.type1);
+
+sub new {
+ my $class = shift;
+ my $service = shift;
+ my $path = shift;
+ my $name = shift;
+
+ my $self = $class->SUPER::new($service, "$path");
+ bless $self, $class;
+
+ $self->{name} = $name;
+ return $self;
+}
+
+dbus_method("version", [], ["string"], { arg_names=>["version"],} );
+sub version {
+ my $self = shift;
+ return ("$self->{name}: ObjectType1, Version 0.1");
+}
+
+
+package ObjectType2;
+
+use base qw(Net::DBus::Object);
+use Net::DBus::Exporter qw(com.dbelser.test.type2);
+
+sub new {
+ my $class = shift;
+ my $service = shift;
+ my $path = shift;
+ my $name = shift;
+
+ my $self = $class->SUPER::new($service, "$path");
+ bless $self, $class;
+ $self->{name} = $name;
+
+ return $self;
+}
+
+dbus_method("version", [], ["string"], { arg_names=>["version"],} );
+sub version {
+ my $self = shift;
+ return ("$self->{name}: ObjectType2, Version 0.1");
+}
+
+
+package ObjectType3;
+
+use base qw(Net::DBus::Object);
+use Net::DBus::Exporter qw(com.dbelser.test.type3);
+
+sub new {
+ my $class = shift;
+ my $service = shift;
+ my $path = shift;
+ my $name = shift;
+
+ my $self = $class->SUPER::new($service, "$path");
+ bless $self, $class;
+ $self->{name} = $name;
+
+ return $self;
+}
+
+dbus_method("version", [], ["string"], { arg_names=>["version"],} );
+sub version {
+ my $self = shift;
+ return ("$self->{name}: ObjectType3, Version 0.1");
+}
+
+
+package main;
+
+use Net::DBus qw(:typing);
+my $bus = Net::DBus->test;
+my $service = $bus->export_service("org.cpan.Net.Bus.test");
+
+# base path for this app
+my $base = "/base";
+
+my $root = ObjectType1->new($service,$base,"Root");
+
+# second tier one each
+my $c1 = ObjectType1->new($root,"/branch_1", "C1");
+my $c2 = ObjectType2->new($root,"/branch_2", "C2");
+my $c3 = ObjectType3->new($root,"/branch_3", "C3");
+
+# go deep
+my $c4 = ObjectType1->new($c1,"/one", "C4");
+my $c5 = ObjectType2->new($c4,"/two", "C5");
+my $c6 = ObjectType3->new($c5,"/three", "C6");
+
+# skip some nodes
+my $c7 = ObjectType1->new($c2,"/skip/one", "C7");
+my $c8 = ObjectType2->new($c7,"/skip/skip/two", "C8");
+my $c9 = ObjectType3->new($c8,"/skip/skip/skip/three", "C9");
+
+my $introspector = $root->_introspector;
+my $xml_got = $introspector->format($root);
+
+my $xml_expect = <<EOF;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/base">
+ <interface name="com.dbelser.test.type1">
+ <method name="version">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+ <node name="/branch_1"/>
+ <node name="/branch_2"/>
+ <node name="/branch_3"/>
+</node>
+EOF
+
+is($xml_got, $xml_expect, "xml data matches");
+
+my $ins2 = Net::DBus::Binding::Introspector->new(xml => $xml_got);
+
+my @children = $ins2->list_children();
+is_deeply(\@children, ["/branch_1", "/branch_2", "/branch_3"], "children match");
+
+
+$introspector = $c2->_introspector;
+$xml_got = $introspector->format($c2);
+
+$xml_expect = <<EOF;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/base/branch_2">
+ <interface name="com.dbelser.test.type2">
+ <method name="version">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+ <node name="/skip"/>
+</node>
+EOF
+is($xml_got, $xml_expect, "xml data matches");
--
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