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 <berra...@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

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits

Reply via email to