[libnet-dbus-perl] 46/335: A trial at updating introspection XML to use signatures instead of type names
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:20 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 62bbfb086e1896d51b1c9f147bc6be19a47a14ae
Author: Daniel P. Berrange <dan at berrange.com>
Date: Sun Apr 17 21:14:40 2005 +0000
A trial at updating introspection XML to use signatures instead of type names
---
examples/example-service.pl | 6 +-
examples/example-signal-receiver.pl | 4 +
lib/Net/DBus/Introspector.pm | 205 ++++++++++++++++++++++--------------
t/40-introspector.t | 127 ++++++++++++++++++++--
4 files changed, 251 insertions(+), 91 deletions(-)
diff --git a/examples/example-service.pl b/examples/example-service.pl
index 530dc74..f10d262 100644
--- a/examples/example-service.pl
+++ b/examples/example-service.pl
@@ -27,15 +27,15 @@ sub new {
methods => {
"HelloWorld" => {
params => ["string"],
- returns => [["array",["string"]]],
+ returns => [["array","string"]],
},
"GetDict" => {
params => [],
- returns => [["dict", ["string", "string"]]],
+ returns => [["dict", "string", "string"]],
},
"GetTuple" => {
params => [],
- returns => [["struct", ["string", "string"]]],
+ returns => [["struct", "string", "string"]],
}
},
},
diff --git a/examples/example-signal-receiver.pl b/examples/example-signal-receiver.pl
index 0a7e295..b13da64 100644
--- a/examples/example-signal-receiver.pl
+++ b/examples/example-signal-receiver.pl
@@ -25,8 +25,12 @@ $object->connect_to_signal("hello", \&hello_signal_handler);
my $reactor = Net::DBus::Reactor->new();
$reactor->manage($bus->{connection});
+my $ticks = 0;
$reactor->add_timeout(1000, Net::DBus::Callback->new(method => sub {
$object->emitHelloSignal();
+ if ($ticks++ == 10) {
+ $reactor->shutdown();
+ }
}));
$reactor->run();
diff --git a/lib/Net/DBus/Introspector.pm b/lib/Net/DBus/Introspector.pm
index 0edb420..2540d5d 100644
--- a/lib/Net/DBus/Introspector.pm
+++ b/lib/Net/DBus/Introspector.pm
@@ -5,8 +5,8 @@
"org.foo.bar.Wibble" => {
methods => {
foo => {
- params => ["int32", "double", ["array", ["int32"]]],
- return => ["string", "byte", ["dict", ["string", "variant"]]]
+ params => ["int32", "double", ["array", "int32"]],
+ return => ["string", "byte", ["dict", "string", "variant"]]
}
}
}
@@ -40,6 +40,17 @@ our %simple_type_map = (
"uint64" => &Net::DBus::Binding::Message::TYPE_UINT64,
);
+our %simple_type_rev_map = (
+ &Net::DBus::Binding::Message::TYPE_BYTE => "byte",
+ &Net::DBus::Binding::Message::TYPE_BOOLEAN => "bool",
+ &Net::DBus::Binding::Message::TYPE_DOUBLE => "double",
+ &Net::DBus::Binding::Message::TYPE_STRING => "string",
+ &Net::DBus::Binding::Message::TYPE_INT32 => "int32",
+ &Net::DBus::Binding::Message::TYPE_UINT32 => "uint32",
+ &Net::DBus::Binding::Message::TYPE_INT64 => "int64",
+ &Net::DBus::Binding::Message::TYPE_UINT64 => "uint64",
+);
+
our %compound_type_map = (
"array" => &Net::DBus::Binding::Message::TYPE_ARRAY,
"struct" => &Net::DBus::Binding::Message::TYPE_STRUCT,
@@ -50,7 +61,8 @@ our %compound_type_map = (
our $VERSION = '0.0.1';
sub new {
- my $class = shift;
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
my $self = {};
my %params = @_;
@@ -58,6 +70,8 @@ sub new {
if (defined $params{xml}) {
$self->_parse($params{xml});
+ } elsif (defined $params{node}) {
+ $self->_parse_node($params{node});
} else {
$self->{name} = exists $params{name} ? $params{name} : die "name parameter is required";
$self->{interfaces} = exists $params{interfaces} ? $params{interfaces} : die "interfaces parameter is required";
@@ -97,13 +111,28 @@ sub _parse {
my $document = $parser->parse ( Source => { String => $xml } );
my $root = $document->{Contents}->[0];
-
- $self->{name} = $root->{Attributes}->{name};
+ $self->_parse_node($root);
+}
+
+sub _parse_node {
+ my $self = shift;
+ my $node = shift;
+
+ $self->{name} = $node->{Attributes}->{name};
$self->{interfaces} = {};
- foreach my $child (@{$root->{Contents}}) {
+ $self->{children} = [];
+ foreach my $child (@{$node->{Contents}}) {
if (ref($child) eq "XML::Grove::Element" &&
$child->{Name} eq "interface") {
$self->_parse_interface($child);
+ } elsif (ref($child) eq "XML::Grove::Element" &&
+ $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);
+ }
}
}
}
@@ -129,6 +158,7 @@ sub _parse_interface {
}
}
+
sub _parse_method {
my $self = shift;
my $node = shift;
@@ -143,23 +173,16 @@ sub _parse_method {
my $type = $child->{Attributes}->{type};
my $direction = $child->{Attributes}->{direction};
- if (exists $compound_type_map{lc $type}) {
- my @subtype = $self->_parse_type($child);
- if ($direction eq "in") {
- push @params, [lc $type, \@subtype];
- } elsif ($direction eq "out") {
- push @returns, [lc $type, \@subtype];
- }
- } elsif (exists $simple_type_map{lc $type}) {
- if ($direction eq "in") {
- push @params, lc $type;
- } elsif ($direction eq "out") {
- push @returns, lc $type;
- }
+ my @sig = split //, $type;
+ my @type = $self->_parse_type(\@sig);
+ if ($direction eq "in") {
+ push @params, @type;
+ } elsif ($direction eq "out") {
+ push @returns, @type;
}
}
}
-
+
$self->{interfaces}->{$interface}->{methods}->{$name} = {
params => \@params,
returns => \@returns,
@@ -168,25 +191,53 @@ sub _parse_method {
sub _parse_type {
my $self = shift;
- my $node = shift;
-
-
- my @types;
- foreach my $child (@{$node->{Contents}}) {
- if (ref($child) eq "XML::Grove::Element" &&
- $child->{Name} eq "type") {
- my $name = $child->{Attributes}->{name};
-
- if (exists $compound_type_map{lc $name}) {
- my @subtype = $self->_parse_type($child);
- push @types, [lc $name, \@subtype];
- } elsif (exists $simple_type_map{lc $name}) {
- push @types, lc $name;
+ my $sig = shift;
+
+ my $root = [];
+ my $current = $root;
+ my @cont;
+ while (my $type = shift @{$sig}) {
+ if (exists $simple_type_rev_map{ord($type)}) {
+ push @{$current}, $simple_type_rev_map{ord($type)};
+ if ($current->[0] eq "array") {
+ $current = pop @cont;
+ }
+ } else {
+ if ($type eq "(") {
+ my $new = ["struct"];
+ push @{$current}, $new;
+ push @cont, $current;
+ $current = $new;
+ } elsif ($type eq "a") {
+ my $new = ["array"];
+ push @cont, $current;
+ push @{$current}, $new;
+ $current = $new;
+ } elsif ($type eq "{") {
+ if ($current->[0] ne "array") {
+ die "dict must only occur within an array";
+ }
+ $current->[0] = "dict";
+ } elsif ($type eq ")") {
+ die "unexpected end of struct" unless
+ $current->[0] eq "struct";
+ $current = pop @cont;
+ if ($current->[0] eq "array") {
+ $current = pop @cont;
+ }
+ } elsif ($type eq "}") {
+ die "unexpected end of dict" unless
+ $current->[0] eq "dict";
+ $current = pop @cont;
+ if ($current->[0] eq "array") {
+ $current = pop @cont;
+ }
+ } else {
+ die "unknown type sig '$type'";
}
}
}
-
- return @types;
+ return @{$root};
}
sub _parse_signal {
@@ -200,13 +251,9 @@ sub _parse_signal {
if (ref($child) eq "XML::Grove::Element" &&
$child->{Name} eq "arg") {
my $type = $child->{Attributes}->{type};
-
- if (exists $compound_type_map{lc $type}) {
- my @subtype = $self->_parse_type($child);
- push @params, [lc $type, \@subtype];
- } elsif (exists $simple_type_map{lc $type}) {
- push @params, lc $type;
- }
+ my @sig = split //, $type;
+ my @type = $self->_parse_type(\@sig);
+ push @params, @type;
}
}
@@ -238,26 +285,13 @@ sub to_xml {
$xml .= $indent . ' <method name="' . $mname . '">' . "\n";
foreach my $type (@{$method->{params}}) {
- if (ref($type) eq "ARRAY") {
- $xml .= $indent . ' <arg type="' . $type->[0] . '" direction="in">' . "\n";
- $xml .= $self->to_xml_type($type->[1], $indent . ' ');
- $xml .= $indent . ' </arg>' . "\n";
- } else {
- $xml .= $indent . ' <arg type="' . $type . '" direction="in"/>' . "\n";
- }
+ $xml .= $indent . ' <arg type="' . $self->to_xml_type($type) . '" direction="in"/>' . "\n";
}
foreach my $type (@{$method->{returns}}) {
- if (ref($type) eq "ARRAY") {
- $xml .= $indent . ' <arg type="' . $type->[0] . '" direction="out">' . "\n";
- $xml .= $self->to_xml_type($type->[1], $indent . ' ');
- $xml .= $indent . ' </arg>' . "\n";
- } else {
- $xml .= $indent . ' <arg type="' . $type . '" direction="out"/>' . "\n";
- }
+ $xml .= $indent . ' <arg type="' . $self->to_xml_type($type) . '" direction="out"/>' . "\n";
}
-
-
+
$xml .= $indent . ' </method>' . "\n";
}
foreach my $sname (keys %{$interface->{signals}}) {
@@ -265,13 +299,7 @@ sub to_xml {
$xml .= $indent . ' <signal name="' . $sname . '">' . "\n";
foreach my $type (@{$signal}) {
- if (ref($type) eq "ARRAY") {
- $xml .= $indent . ' <arg type="' . $type->[0] . '">' . "\n";
- $xml .= $self->to_xml_type($type->[1], $indent . ' ');
- $xml .= $indent . ' </arg>' . "\n";
- } else {
- $xml .= $indent . ' <arg type="' . $type . '"/>' . "\n";
- }
+ $xml .= $indent . ' <arg type="' . $self->to_xml_type($type) . '"/>' . "\n";
}
$xml .= $indent . ' </signal>' . "\n";
}
@@ -281,30 +309,49 @@ sub to_xml {
foreach my $child (@{$self->{children}}) {
if (ref($child) eq "Net::DBus::Introspector") {
- $xml .= $child->to_xml($indent . " ") . "\n";
+ $xml .= $child->to_xml($indent . " ");
} else {
$xml .= $indent . ' <node name="' . $child . '"/>' . "\n";
}
}
- $xml .= $indent . "</node>";
+ $xml .= $indent . "</node>\n";
}
sub to_xml_type {
my $self = shift;
my $type = shift;
- my $indent = shift;
- my $xml = '';
- foreach my $subtype (@{$type}) {
- if (ref($subtype) eq "ARRAY") {
- $xml .= $indent . ' <type name="' . $subtype->[0] . '">' . "\n";
- $xml .= $self->to_xml_type($subtype->[1], $indent . ' ');
- $xml .= $indent . ' </type>' . "\n";
+
+ my $sig = '';
+ if (ref($type) eq "ARRAY") {
+ if ($type->[0] eq "array") {
+ if ($#{$type} != 1) {
+ die "array spec must contain only 1 type";
+ }
+ $sig .= chr($compound_type_map{$type->[0]});
+ $sig .= $self->to_xml_type($type->[1]);
+ } elsif ($type->[0] eq "struct") {
+ $sig .= "(";
+ for (my $i = 1 ; $i <= $#{$type} ; $i++) {
+ $sig .= $self->to_xml_type($type->[$i]);
+ }
+ $sig .= ")";
+ } elsif ($type->[0] eq "dict") {
+ if ($#{$type} != 2) {
+ die "dict spec must contain only 2 types";
+ }
+ $sig .= chr($compound_type_map{"array"});
+ $sig .= "{";
+ $sig .= $self->to_xml_type($type->[1]);
+ $sig .= $self->to_xml_type($type->[2]);
+ $sig .= "}";
} else {
- $xml .= $indent . ' <type name="' . $subtype . '"/>' . "\n";
+ die "unknown type " . $type->[0] . " expecting 'array', 'struct', or 'dict'";
}
+ } else {
+ $sig .= chr($simple_type_map{$type});
}
- return $xml;
+ return $sig;
}
sub encode {
@@ -338,7 +385,9 @@ sub convert {
my @out;
foreach my $in (@in) {
if (ref($in) eq "ARRAY") {
- my @subout = $self->convert(@{$in->[1]});
+ my @subtype = @{$in};
+ shift @subtype;
+ my @subout = $self->convert(@subtype);
die "unknown compound type " . $in->[0] unless
exists $compound_type_map{lc $in->[0]};
push @out, [$compound_type_map{lc $in->[0]}, \@subout];
diff --git a/t/40-introspector.t b/t/40-introspector.t
index 77512de..14bfe1e 100644
--- a/t/40-introspector.t
+++ b/t/40-introspector.t
@@ -1,5 +1,9 @@
# -*- perl -*-
-use Test::More tests => 2;
+use Test::More tests => 6;
+
+use strict;
+use warnings;
+
BEGIN {
use_ok('Net::DBus::Introspector');
};
@@ -7,16 +11,16 @@ BEGIN {
TEST_ONE: {
my $other_object = Net::DBus::Introspector->new(
- name => "org.example.OtherObject",
+ name => "org.example.Object.OtherObject",
interfaces => {
"org.example.SomeInterface" => {
methods => {
"hello" => {
- params => ["int32", "int32", ["struct", ["int32","byte"]]],
+ params => ["int32", "int32", ["struct", "int32","byte"]],
returns => ["int32"],
},
"goodbye" => {
- params => [["array", [["struct", ["int32", "string"]]]]],
+ params => [["array", ["struct", "int32", "string"]]],
returns => ["string", "string"],
},
},
@@ -25,18 +29,53 @@ TEST_ONE: {
}
}
});
+
+ isa_ok($other_object, "Net::DBus::Introspector");
+
+ my $other_xml_got = $other_object->format();
+
+ my $other_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="org.example.Object.OtherObject">
+ <interface name="org.example.SomeInterface">
+ <method name="hello">
+ <arg type="i" direction="in"/>
+ <arg type="i" direction="in"/>
+ <arg type="(iy)" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="goodbye">
+ <arg type="a(is)" direction="in"/>
+ <arg type="s" direction="out"/>
+ <arg type="s" direction="out"/>
+ </method>
+ <signal name="meltdown">
+ <arg type="i"/>
+ <arg type="y"/>
+ </signal>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+</node>
+EOF
+ is($other_xml_got, $other_xml_expect, "xml data matches");
+
my $object = Net::DBus::Introspector->new(
name => "org.example.Object",
interfaces => {
"org.example.SomeInterface" => {
methods => {
"hello" => {
- params => ["int32", "int32", ["struct", ["int32","byte"]]],
- returns => ["int32"],
+ params => ["int32", "int32", ["struct", "int32","byte"]],
+ returns => ["uint32"],
},
"goodbye" => {
- params => [["array", [["struct", ["int32", "string"]]]]],
- returns => ["string", "string"],
+ params => [["array", ["dict", "int32", "string"]]],
+ returns => ["string", ["array", "string"]],
},
},
signals => {
@@ -53,11 +92,79 @@ TEST_ONE: {
},
},
children => [
- "org.example.AnotherObject",
+ "org.example.Object.SubObject",
$other_object,
]);
isa_ok($object, "Net::DBus::Introspector");
- warn $object->format;
+ my $object_xml_got = $object->format();
+
+ my $object_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="org.example.Object">
+ <interface name="org.example.SomeInterface">
+ <method name="hello">
+ <arg type="i" direction="in"/>
+ <arg type="i" direction="in"/>
+ <arg type="(iy)" direction="in"/>
+ <arg type="u" direction="out"/>
+ </method>
+ <method name="goodbye">
+ <arg type="aa{is}" direction="in"/>
+ <arg type="s" direction="out"/>
+ <arg type="as" direction="out"/>
+ </method>
+ <signal name="meltdown">
+ <arg type="i"/>
+ <arg type="y"/>
+ </signal>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.example.OtherInterface">
+ <method name="hitme">
+ <arg type="i" direction="in"/>
+ <arg type="u" direction="in"/>
+ </method>
+ </interface>
+ <node name="org.example.Object.SubObject"/>
+ <node name="org.example.Object.OtherObject">
+ <interface name="org.example.SomeInterface">
+ <method name="hello">
+ <arg type="i" direction="in"/>
+ <arg type="i" direction="in"/>
+ <arg type="(iy)" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="goodbye">
+ <arg type="a(is)" direction="in"/>
+ <arg type="s" direction="out"/>
+ <arg type="s" direction="out"/>
+ </method>
+ <signal name="meltdown">
+ <arg type="i"/>
+ <arg type="y"/>
+ </signal>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ </node>
+</node>
+EOF
+ is($object_xml_got, $object_xml_expect, "xml data matches");
+
+
+ my $recon_other = Net::DBus::Introspector->new(xml => $object_xml_got);
+
+ my $object_xml_got_again = $recon_other->format();
+
+ is($object_xml_got_again, $object_xml_expect, "reconstructed xml 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