[libnet-dbus-perl] 260/335: Add support for annotating methods with their arg/return value names (based on work from Dave Belser)
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:08:07 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 04046774701d1c78eb1c96481226a167e7d576e4
Author: Daniel P. Berrange <berrange at redhat.com>
Date: Wed Feb 6 20:32:52 2008 -0500
Add support for annotating methods with their arg/return value names (based on work from Dave Belser)
---
lib/Net/DBus/Binding/Introspector.pm | 18 ++++--
lib/Net/DBus/Exporter.pm | 32 +++++++++--
t/40-introspector.t | 29 ++++++----
t/45-exporter.t | 103 ++++++++++++++++++++++++++++++++++-
t/55-method-calls.t | 8 +--
t/56-scalar-param-typing.t | 16 +++---
6 files changed, 170 insertions(+), 36 deletions(-)
diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index 6473863..6a74771 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -265,13 +265,14 @@ sub has_property {
}
}
-=item $ins->add_method($name, $params, $returns, $interface, $attributes);
+=item $ins->add_method($name, $params, $returns, $interface, $attributes, $names);
Register the object as providing a method called C<$name> accepting parameters
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.
+for annotating the method. The C<$names> parameter is a list of argument
+and return value names.
=cut
@@ -282,11 +283,13 @@ sub add_method {
my $returns = shift;
my $interface = shift;
my $attributes = shift;
+ my $names = shift;
$self->add_interface($interface);
$self->{interfaces}->{$interface}->{methods}->{$name} = {
params => $params,
returns => $returns,
+ names => $names,
deprecated => $attributes->{deprecated} ? 1 : 0,
no_reply => $attributes->{no_return} ? 1 : 0,
};
@@ -634,18 +637,22 @@ sub _parse_method {
my $name = $node->att("name");
my @params;
my @returns;
+ my @names;
my $deprecated = 0;
my $no_reply = 0;
foreach my $child ($node->children("arg")) {
my $type = $child->att("type");
my $direction = $child->att("direction");
+ my $name = $child->att("name");
my @sig = split //, $type;
my @type = $self->_parse_type(\@sig);
if (!defined $direction || $direction eq "in") {
push @params, @type;
+ push @names, $name;
} elsif ($direction eq "out") {
push @returns, @type;
+ push @names, $name;
}
}
foreach my $child ($node->children("annotation")) {
@@ -664,6 +671,7 @@ sub _parse_method {
returns => \@returns,
no_reply => $no_reply,
deprecated => $deprecated,
+ names => \@names,
}
}
@@ -816,14 +824,16 @@ sub to_xml {
my $method = $interface->{methods}->{$mname};
$xml .= $indent . ' <method name="' . $mname . '">' . "\n";
+ my @names = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{names}} );
+
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";
+ $xml .= $indent . ' <arg ' . (@names ? shift(@names) : "") . '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";
+ $xml .= $indent . ' <arg ' . (@names ? shift(@names) : "") . 'type="' . $self->to_xml_type($type) . '" direction="out"/>' . "\n";
}
if ($method->{deprecated}) {
$xml .= $indent . ' <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index 91e4623..86a5bf8 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -215,11 +215,16 @@ not to expect / wait for a reply message
=item deprecated
-Indicate that use of this method/signal/property is discouraged, and
+Indicate that use of this method/signal/property is discouraged, and
it may disappear altogether in a future release. Clients will typically
print out a warning message when a deprecated method/signal/property
is used.
+=item arg_names
+
+An array of strings specifying names for the input parameters and
+return values of the method. If omitted, no names will be assigned.
+
=back
=head1 METHODS
@@ -317,8 +322,8 @@ sub _dbus_introspector_add {
my $exports = $dbus_exports{$class};
if ($exports) {
foreach my $method (keys %{$exports->{methods}}) {
- my ($params, $returns, $interface, $attributes) = @{$exports->{methods}->{$method}};
- $introspector->add_method($method, $params, $returns, $interface, $attributes);
+ my ($params, $returns, $interface, $attributes, $names) = @{$exports->{methods}->{$method}};
+ $introspector->add_method($method, $params, $returns, $interface, $attributes, $names);
}
foreach my $prop (keys %{$exports->{props}}) {
my ($type, $access, $interface, $attributes) = @{$exports->{props}->{$prop}};
@@ -360,6 +365,7 @@ values.
sub dbus_method {
my $name = shift;
+ my $arg_names = [];
my $params = [];
my $returns = [];
my $caller = caller;
@@ -382,8 +388,13 @@ sub dbus_method {
if (!$interface) {
die "interface not specified & no default interface defined";
}
-
- $dbus_exports{$caller}->{methods}->{$name} = [$params, $returns, $interface, \%attributes];
+
+ if ( $attributes{arg_names} ) {
+ $arg_names = $attributes{arg_names} if ref($attributes{arg_names}) eq "ARRAY";
+ delete($attributes{arg_names});
+ }
+
+ $dbus_exports{$caller}->{methods}->{$name} = [$params, $returns, $interface, \%attributes, $arg_names];
}
@@ -533,6 +544,17 @@ return any value
dbus_method("PlayMP3", ["string"], [], { deprecated => 1, no_return => 1 });
+Or giving names to input parameters:
+
+ sub PlayMP3 {
+ my $self = shift;
+ my $track = shift;
+
+ system "mpg123 $track &";
+ }
+
+ dbus_method("PlayMP3", ["string"], [], { arg_names => ["track"] });
+
=back
=head1 SEE ALSO
diff --git a/t/40-introspector.t b/t/40-introspector.t
index 76c31ce..a98b7d9 100644
--- a/t/40-introspector.t
+++ b/t/40-introspector.t
@@ -18,10 +18,12 @@ TEST_ONE: {
"hello" => {
params => ["int32", "int32", ["struct", "int32","byte"]],
returns => ["int32"],
+ names => ["wibble", "eek", "frob"],
},
"goodbye" => {
params => [["array", ["struct", "int32", "string"]]],
returns => ["string", "string"],
+ names => ["ooh", "ahh", "eek"],
},
},
signals => {
@@ -48,14 +50,14 @@ TEST_ONE: {
<node name="org.example.Object.OtherObject">
<interface name="org.example.SomeInterface">
<method name="goodbye">
- <arg type="a(is)" direction="in"/>
- <arg type="s" direction="out"/>
- <arg type="s" direction="out"/>
+ <arg name="ooh" type="a(is)" direction="in"/>
+ <arg name="ahh" type="s" direction="out"/>
+ <arg name="eek" type="s" direction="out"/>
</method>
<method name="hello">
- <arg type="i" direction="in"/>
- <arg type="i" direction="in"/>
- <arg type="(iy)" direction="in"/>
+ <arg name="wibble" type="i" direction="in"/>
+ <arg name="eek" type="i" direction="in"/>
+ <arg name="frob" type="(iy)" direction="in"/>
<arg type="i" direction="out"/>
</method>
<signal name="meltdown">
@@ -79,10 +81,12 @@ EOF
"hello" => {
params => ["int32", "int32", ["struct", "int32","byte"]],
returns => ["uint32"],
+ names => [],
},
"goodbye" => {
params => [["array", ["dict", "int32", "string"]]],
returns => ["string", ["array", "string"]],
+ names => [],
},
},
signals => {
@@ -96,6 +100,7 @@ EOF
"hitme" => {
params => ["int32", "uint32"],
return => [],
+ names => [],
}
},
props => {
@@ -146,14 +151,14 @@ EOF
<node name="org.example.Object.OtherObject">
<interface name="org.example.SomeInterface">
<method name="goodbye">
- <arg type="a(is)" direction="in"/>
- <arg type="s" direction="out"/>
- <arg type="s" direction="out"/>
+ <arg name="ooh" type="a(is)" direction="in"/>
+ <arg name="ahh" type="s" direction="out"/>
+ <arg name="eek" type="s" direction="out"/>
</method>
<method name="hello">
- <arg type="i" direction="in"/>
- <arg type="i" direction="in"/>
- <arg type="(iy)" direction="in"/>
+ <arg name="wibble" type="i" direction="in"/>
+ <arg name="eek" type="i" direction="in"/>
+ <arg name="frob" type="(iy)" direction="in"/>
<arg type="i" direction="out"/>
</method>
<signal name="meltdown">
diff --git a/t/45-exporter.t b/t/45-exporter.t
index 2bd2255..b1cc469 100644
--- a/t/45-exporter.t
+++ b/t/45-exporter.t
@@ -1,6 +1,6 @@
# -*- perl -*-
-use Test::More tests => 93;
+use Test::More tests => 94;
use strict;
use warnings;
@@ -36,7 +36,7 @@ dbus_method("EverythingInterfaceNegativeAnnotate", ["string"], ["int32"], "org.e
# Now test 'defaults'
dbus_method("NoArgsReturns");
-dbus_method("NoReturns", ["string"]);
+dbus_method("NoReturns", ["string"], [], { arg_names => ["wizz"] });
dbus_method("NoArgs",[],["int32"]);
dbus_method("NoArgsReturnsInterface", "org.example.OtherObject");
dbus_method("NoReturnsInterface", ["string"], "org.example.OtherObject");
@@ -46,7 +46,7 @@ dbus_method("NoArgsReturnsAnnotate", { deprecated => 1 });
dbus_method("NoReturnsAnnotate", ["string"], { deprecated => 1 });
dbus_method("NoArgsAnnotate",[],["int32"], { deprecated => 1 });
dbus_method("NoArgsReturnsInterfaceAnnotate", "org.example.OtherObject", { deprecated => 1 });
-dbus_method("NoReturnsInterfaceAnnotate", ["string"], "org.example.OtherObject", { deprecated => 1 });
+dbus_method("NoReturnsInterfaceAnnotate", ["string"], "org.example.OtherObject", { deprecated => 1, arg_names => ["one"] });
dbus_method("NoArgsInterfaceAnnotate", [],["int32"], "org.example.OtherObject", { deprecated => 1 });
@@ -57,6 +57,103 @@ 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");
+my $wantxml = <<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/MyObject">
+ <interface name="org.example.MyObject">
+ <method name="Everything">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="EverythingAnnotate">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ <annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>
+ </method>
+ <method name="EverythingNegativeAnnotate">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="NoArgs">
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="NoArgsAnnotate">
+ <arg type="i" direction="out"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ <method name="NoArgsReturns">
+ </method>
+ <method name="NoArgsReturnsAnnotate">
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ <method name="NoReturns">
+ <arg name="wizz" type="s" direction="in"/>
+ </method>
+ <method name="NoReturnsAnnotate">
+ <arg type="s" direction="in"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ </interface>
+ <interface name="org.example.OtherObject">
+ <method name="EverythingInterface">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="EverythingInterfaceAnnotate">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ <annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>
+ </method>
+ <method name="EverythingInterfaceNegativeAnnotate">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="NoArgsInterface">
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="NoArgsInterfaceAnnotate">
+ <arg type="i" direction="out"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ <method name="NoArgsReturnsInterface">
+ </method>
+ <method name="NoArgsReturnsInterfaceAnnotate">
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ <method name="NoReturnsInterface">
+ <arg type="s" direction="in"/>
+ </method>
+ <method name="NoReturnsInterfaceAnnotate">
+ <arg name="one" type="s" direction="in"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </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>
+EOF
+
+is ($ins->format, $wantxml, "xml matches");
+
+
&check_method($ins, "Everything", ["string"], ["int32"], "org.example.MyObject", 0, 0);
&check_method($ins, "EverythingInterface", ["string"], ["int32"], "org.example.OtherObject", 0, 0);
&check_method($ins, "EverythingAnnotate", ["string"], ["int32"], "org.example.MyObject", 1, 1);
diff --git a/t/55-method-calls.t b/t/55-method-calls.t
index 97ad6a9..6c89e04 100644
--- a/t/55-method-calls.t
+++ b/t/55-method-calls.t
@@ -65,10 +65,10 @@ TEST_FULL_INTROSPECT: {
my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
- $ins->add_method("Test", [], ["string"], "org.example.MyObject");
- $ins->add_method("PolyTest", [], ["string"], "org.example.MyObject");
- $ins->add_method("PolyTest", [], ["string"], "org.example.OtherObject");
- $ins->add_method("Deprecated", [], ["string"], "org.example.MyObject", { deprecated => 1 });
+ $ins->add_method("Test", [], ["string"], "org.example.MyObject", {}, []);
+ $ins->add_method("PolyTest", [], ["string"], "org.example.MyObject", {}, []);
+ $ins->add_method("PolyTest", [], ["string"], "org.example.OtherObject", {}, []);
+ $ins->add_method("Deprecated", [], ["string"], "org.example.MyObject", { deprecated => 1 }, []);
$object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect",
reply => { return => [ $ins->format ] });
diff --git a/t/56-scalar-param-typing.t b/t/56-scalar-param-typing.t
index 1b7b6ce..c2f044a 100644
--- a/t/56-scalar-param-typing.t
+++ b/t/56-scalar-param-typing.t
@@ -705,14 +705,14 @@ TEST_INTROSPECT_TYPING: {
my ($bus, $object, $robject, $myobject, $otherobject) = &setup;
my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
- $ins->add_method("ScalarString", ["string"], [], "org.example.MyObject");
- $ins->add_method("ScalarInt16", ["int16"], [], "org.example.MyObject");
- $ins->add_method("ScalarUInt16", ["uint16"], [], "org.example.MyObject");
- $ins->add_method("ScalarInt32", ["int32"], [], "org.example.MyObject");
- $ins->add_method("ScalarUInt32", ["uint32"], [], "org.example.MyObject");
- $ins->add_method("ScalarDouble", ["double"], [], "org.example.MyObject");
- $ins->add_method("ScalarByte", ["byte"], [], "org.example.MyObject");
- $ins->add_method("ScalarBoolean", ["bool"], [], "org.example.MyObject");
+ $ins->add_method("ScalarString", ["string"], [], "org.example.MyObject", {}, []);
+ $ins->add_method("ScalarInt16", ["int16"], [], "org.example.MyObject", {}, []);
+ $ins->add_method("ScalarUInt16", ["uint16"], [], "org.example.MyObject", {}, []);
+ $ins->add_method("ScalarInt32", ["int32"], [], "org.example.MyObject", {}, []);
+ $ins->add_method("ScalarUInt32", ["uint32"], [], "org.example.MyObject", {}, []);
+ $ins->add_method("ScalarDouble", ["double"], [], "org.example.MyObject", {}, []);
+ $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 ] });
--
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