[libnet-dbus-perl] 114/335: Remove pointless denormalization of method, props, signals from services. Added support for magic "caller" and "serial" data types
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:35 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 31ab30c625d1f4ce362200311f25f6c4017253bd
Author: Daniel P. Berrange <dan at berrange.com>
Date: Mon Sep 26 19:26:10 2005 +0000
Remove pointless denormalization of method, props, signals from services. Added support for magic "caller" and "serial" data types
---
lib/Net/DBus/Binding/Introspector.pm | 99 +++++++++++++++++++-----------------
lib/Net/DBus/Exporter.pm | 24 +++++++++
2 files changed, 77 insertions(+), 46 deletions(-)
diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
index 434f77e..b9c7e57 100644
--- a/lib/Net/DBus/Binding/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -55,6 +55,19 @@ our %simple_type_rev_map = (
&Net::DBus::Binding::Message::TYPE_VARIANT => "variant",
);
+our %magic_type_map = (
+ "caller" => sub {
+ my $msg = shift;
+
+ return $msg->get_sender;
+ },
+ "serial" => sub {
+ my $msg = shift;
+
+ return $msg->get_serial;
+ },
+);
+
our %compound_type_map = (
"array" => &Net::DBus::Binding::Message::TYPE_ARRAY,
"struct" => &Net::DBus::Binding::Message::TYPE_STRUCT,
@@ -68,9 +81,6 @@ sub new {
my $self = {};
my %params = @_;
- $self->{methods} = {};
- $self->{signals} = {};
- $self->{props} = {};
$self->{interfaces} = {};
bless $self, $class;
@@ -83,24 +93,11 @@ sub new {
$self->_parse_node($params{node});
} else {
$self->{object_path} = exists $params{object_path} ? $params{object_path} : die "object_path parameter is required";
- $self->{interfaces} = exists $params{interfaces} ? $params{interfaces} : {};
+ $self->{interfaces} = $params{interfaces} if exists $params{interfaces};
$self->{children} = exists $params{children} ? $params{children} : [];
}
- foreach my $name (keys %{$self->{interfaces}}) {
- my $interface = $self->{interfaces}->{$name};
- foreach my $method (keys %{$interface->{methods}}) {
- $self->{methods}->{$method} = $interface->{methods}->{$method};
- }
- foreach my $signal (keys %{$interface->{signals}}) {
- $self->{signals}->{$signal} = $interface->{signals}->{$signal};
- }
- foreach my $prop (keys %{$interface->{props}}) {
- $self->{props}->{$prop} = $interface->{props}->{$prop};
- }
- }
-
- # XXX its a bug that these aren't included in the introspection
+ # XXX it is really a bug that these aren't included in the introspection
# data the bus generates
if ($self->{object_path} eq "/org/freedesktop/DBus") {
if (!$self->has_signal("NameOwnerChanged")) {
@@ -168,7 +165,6 @@ sub has_property {
} else {
my @interfaces;
foreach my $interface (keys %{$self->{interfaces}}) {
-
if (exists $self->{interfaces}->{$interface}->{props}->{$name}) {
push @interfaces, $interface;
}
@@ -186,10 +182,10 @@ sub add_method {
my $interface = shift;
$self->add_interface($interface);
-
- $self->{methods}->{$name} = { params => $params,
- returns => $returns };
- $self->{interfaces}->{$interface}->{methods}->{$name} = $self->{methods}->{$name};
+ $self->{interfaces}->{$interface}->{methods}->{$name} = {
+ params => $params,
+ returns => $returns,
+ };
}
sub add_signal {
@@ -199,9 +195,7 @@ sub add_signal {
my $interface = shift;
$self->add_interface($interface);
-
- $self->{signals}->{$name} = $params;
- $self->{interfaces}->{$interface}->{signals}->{$name} = $self->{signals}->{$name};
+ $self->{interfaces}->{$interface}->{signals}->{$name} = $params;
}
@@ -213,9 +207,7 @@ sub add_property {
my $interface = shift;
$self->add_interface($interface);
-
- $self->{props}->{$name} = [$type, $access];
- $self->{interfaces}->{$interface}->{props}->{$name} = $self->{props}->{$name};
+ $self->{interfaces}->{$interface}->{props}->{$name} = [$type, $access];
}
@@ -314,7 +306,6 @@ sub _parse_node {
$self->{object_path} = $node->{Attributes}->{name} if defined $node->{Attributes}->{name};
die "no object path provided" unless defined $self->{object_path};
- $self->{interfaces} = {};
$self->{children} = [];
foreach my $child (@{$node->{Contents}}) {
if (ref($child) eq "XML::Grove::Element" &&
@@ -497,10 +488,12 @@ sub to_xml {
$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";
}
@@ -511,6 +504,7 @@ sub to_xml {
$xml .= $indent . ' <signal name="' . $sname . '">' . "\n";
foreach my $type (@{$signal}) {
+ next if ! ref($type) && exists $magic_type_map{$type};
$xml .= $indent . ' <arg type="' . $self->to_xml_type($type) . '"/>' . "\n";
}
$xml .= $indent . ' </signal>' . "\n";
@@ -575,7 +569,7 @@ sub to_xml_type {
return $sig;
}
-# XXX we should be passing interface name along with method
+
sub encode {
my $self = shift;
my $message = shift;
@@ -584,12 +578,18 @@ sub encode {
my $direction = shift;
my @args = @_;
- die "no introspection data for $name (type: $type) in object " . $self->get_object_path . "\n"
- unless exists $self->{$type}->{$name};
+ my $interface = $message->get_interface;
+
+ die "no introspection data for interface '$interface' in object '" . $self->get_object_path . "'\n"
+ unless exists $self->{interfaces}->{$interface};
+
+ die "no introspection data for $type '$name' in object " . $self->get_object_path . "\n"
+ unless exists $self->{interfaces}->{$interface}->{$type}->{$name};
+
my @types = $type eq "signals" ?
- @{$self->{$type}->{$name}} :
- @{$self->{$type}->{$name}->{$direction}};
+ @{$self->{interfaces}->{$interface}->{$type}->{$name}} :
+ @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
# If you don't explicitly 'return ()' from methods, Perl
# will always return a single element representing the
@@ -625,6 +625,8 @@ sub convert {
die "unknown compound type " . $in->[0] unless
exists $compound_type_map{lc $in->[0]};
push @out, [$compound_type_map{lc $in->[0]}, \@subout];
+ } elsif (exists $magic_type_map{lc $in}) {
+ push @out, $magic_type_map{lc $in};
} else {
die "unknown simple type " . $in unless
exists $simple_type_map{lc $in};
@@ -635,7 +637,6 @@ sub convert {
}
-# XXX we should be passing interface name along with methods
sub decode {
my $self = shift;
my $message = shift;
@@ -644,27 +645,33 @@ sub decode {
my $direction = shift;
my @args = @_;
- die "no introspection data for such $name ($type)" unless exists $self->{$type}->{$name};
-
- my @types = $type eq "signals" ?
- @{$self->{$type}->{$name}} :
- @{$self->{$type}->{$name}->{$direction}};
+ my $interface = $message->get_interface;
+
+ die "no introspection data for interface '$interface' in object '" . $self->get_object_path . "'\n"
+ unless exists $self->{interfaces}->{$interface};
+ die "no introspection data for $type '$name' in object " . $self->get_object_path . "\n"
+ unless exists $self->{interfaces}->{$interface}->{$type}->{$name};
+ my @types = $type eq "signals" ?
+ @{$self->{interfaces}->{$interface}->{$type}->{$name}} :
+ @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
+
my $iter = $message->iterator;
- if ($iter->get_arg_type() == &Net::DBus::Binding::Message::TYPE_INVALID) {
- return ();
- }
-
# XXX validate received message against instrospection data!
my @rawtypes = $self->convert(@types);
my @ret;
do {
my $rawtype = shift @rawtypes;
my $type = shift @types;
- push @ret, $iter->get($rawtype);
+
+ if (exists $magic_type_map{$type}) {
+ push @ret, &$rawtype($message);
+ } else {
+ push @ret, $iter->get($rawtype);
+ }
} while ($iter->next);
return @ret;
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index 5dbb44d..826ac50 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -147,6 +147,30 @@ with the values orded to match the structure
=back
+=head1 MAGIC TYPES
+
+When specifying introspection data for an exported service, there
+are a couple of so called C<magic> types. Parameters declared as
+magic types are not visible to clients, but instead their values
+are provided automatically by the server side bindings. One use of
+magic types is to get an extra parameter passed with the unique
+name of the caller invoking the method.
+
+=over 4
+
+=item "caller"
+
+The value passed in is the unique name of the caller of the method.
+Unique names are strings automatically assigned to client connections
+by the bus daemon, for example ':1.15'
+
+=item "serial"
+
+The value passed in is an integer within the scope of a caller, which
+increments on every method call.
+
+=back
+
=head1 METHODS
=over 4
--
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