[libnet-dbus-perl] 79/335: Moved introspector class to private Binding namespace. Decode input args for method calls. Short circuit local callbacks
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:29 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 17bf8733a5e767cb8d5e8eeacf227071b0767f34
Author: Daniel P. Berrange <dan at berrange.com>
Date: Mon Aug 22 12:32:10 2005 +0000
Moved introspector class to private Binding namespace. Decode input args for method calls. Short circuit local callbacks
---
lib/Net/DBus/{ => Binding}/Introspector.pm | 23 ++++++++--
lib/Net/DBus/Binding/Iterator.pm | 73 ++++++++++++++++++++----------
lib/Net/DBus/Binding/Message.pm | 16 -------
lib/Net/DBus/Exporter.pm | 2 +-
lib/Net/DBus/Object.pm | 36 +++++++--------
lib/Net/DBus/RemoteObject.pm | 6 +--
6 files changed, 87 insertions(+), 69 deletions(-)
diff --git a/lib/Net/DBus/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm
similarity index 97%
rename from lib/Net/DBus/Introspector.pm
rename to lib/Net/DBus/Binding/Introspector.pm
index 88445f6..4651788 100644
--- a/lib/Net/DBus/Introspector.pm
+++ b/lib/Net/DBus/Binding/Introspector.pm
@@ -17,7 +17,7 @@
=cut
-package Net::DBus::Introspector;
+package Net::DBus::Binding::Introspector;
use 5.006;
use strict;
@@ -532,11 +532,26 @@ sub decode {
die "no introspection data for such $name ($type)" unless exists $self->{$type}->{$name};
- my @type = $type eq "signals" ?
+ my @types = $type eq "signals" ?
@{$self->{$type}->{$name}} :
@{$self->{$type}->{$name}->{$direction}};
- # XXX validate received message against instrospection data!
+
+
+ my $iter = $message->iterator;
- return $message->get_args_list();
+ 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);
+ } while ($iter->next);
+
+ return @ret;
}
diff --git a/lib/Net/DBus/Binding/Iterator.pm b/lib/Net/DBus/Binding/Iterator.pm
index 7d5c6da..ae56b93 100644
--- a/lib/Net/DBus/Binding/Iterator.pm
+++ b/lib/Net/DBus/Binding/Iterator.pm
@@ -167,7 +167,30 @@ sub append_uint64 {
sub get {
my $self = shift;
- my $type = @_ ? shift : $self->get_arg_type;
+ my $type = shift;
+
+ if (defined $type) {
+ if (ref($type)) {
+ if (ref($type) eq "ARRAY") {
+ # XXX we should recursively validate types
+ $type = $type->[0];
+ if ($type eq &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ $type = &Net::DBus::Binding::Message::TYPE_ARRAY;
+ }
+ } else {
+ die "unsupport type reference $type";
+ }
+ }
+
+ my $actual = $self->get_arg_type;
+ if ($actual != $type) {
+ die "requested type '$type' did not match wire type '$actual'";
+ }
+ } else {
+ $type = $self->get_arg_type;
+ }
+
+
if ($type == &Net::DBus::Binding::Message::TYPE_STRING) {
return $self->get_string;
@@ -194,18 +217,16 @@ sub get {
}
} elsif ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) {
return $self->get_struct();
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) {
+ return $self->get_variant();
} elsif ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
confess "dictionary can only occur as part of an array type";
} elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) {
confess "cannot handle Net::DBus::Binding::Message::TYPE_INVALID";
} elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
- my $path = $self->get_string();
- bless $path, "Net::DBus::Binding::ObjectPath";
- return $path;
+ return $self->get_string();
} elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) {
- my $sig = $self->get_string();
- bless $sig, "Net::DBus::Binding::Signature";
- return $sig;
+ return $self->get_string();
} else {
confess "unknown argument type '" . chr($type) . "' ($type)";
}
@@ -308,6 +329,8 @@ sub append {
$self->append_uint64($value);
} elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) {
$self->append_double($value);
+ } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) {
+ $self->append_string($value);
} else {
$self->append_string($value);
}
@@ -323,26 +346,26 @@ sub get_signature {
$i = 0;
if (ref ($type) eq "ARRAY") {
- while ($i <= $#{$type}) {
- $t = $$type[$i];
-
- if (ref ($t) eq "ARRAY") {
- $sig .= &get_signature ($t);
- } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
- $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY);
- $sig .= "{" . &get_signature ($$type[++$i]) . "}";
- } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) {
- $sig .= "(" . &get_signature ($$type[++$i]) . ")";
- } else {
- $sig .= chr ($t);
- }
-
- $i++;
- }
+ while ($i <= $#{$type}) {
+ $t = $$type[$i];
+
+ if (ref ($t) eq "ARRAY") {
+ $sig .= &get_signature ($t);
+ } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) {
+ $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY);
+ $sig .= "{" . &get_signature ($$type[++$i]) . "}";
+ } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) {
+ $sig .= "(" . &get_signature ($$type[++$i]) . ")";
+ } else {
+ $sig .= chr ($t);
+ }
+
+ $i++;
+ }
} else {
- $sig .= chr ($type);
+ $sig .= chr ($type);
}
-
+
return $sig;
}
diff --git a/lib/Net/DBus/Binding/Message.pm b/lib/Net/DBus/Binding/Message.pm
index 7c4fbe5..164b680 100644
--- a/lib/Net/DBus/Binding/Message.pm
+++ b/lib/Net/DBus/Binding/Message.pm
@@ -141,22 +141,6 @@ sub iterator {
}
-sub get_args_list {
- my $self = shift;
-
- my @ret;
- my $iter = $self->iterator;
-
- if ($iter->get_arg_type() == &Net::DBus::Binding::Message::TYPE_INVALID) {
- return ();
- }
-
- do {
- push @ret, $iter->get;
- } while ($iter->next);
-
- return @ret;
-}
# To keep autoloader quiet
sub DESTROY {
diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm
index ee6f6b2..d611784 100644
--- a/lib/Net/DBus/Exporter.pm
+++ b/lib/Net/DBus/Exporter.pm
@@ -290,7 +290,7 @@ sub dbus_introspector {
die "$object must be a blessed reference" unless $class;
unless (exists $dbus_introspectors{$class}) {
- my $is = Net::DBus::Introspector->new(object_path => $object->get_object_path);
+ my $is = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
&_dbus_introspector_add(ref($object), $is);
$dbus_introspectors{$class} = $is;
diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm
index 54e1d61..73239d9 100644
--- a/lib/Net/DBus/Object.pm
+++ b/lib/Net/DBus/Object.pm
@@ -136,7 +136,6 @@ our $VERSION = '0.0.1';
use Net::DBus::RemoteObject;
use Net::DBus::Exporter "org.freedesktop.DBus.Introspectable";
-use Net::DBus::Introspector;
use Net::DBus::Binding::Message::Error;
use Net::DBus::Binding::Message::MethodReturn;
@@ -148,6 +147,7 @@ sub new {
$self->{service} = shift;
$self->{object_path} = shift;
+ $self->{callbacks} = {};
bless $self, $class;
@@ -184,6 +184,13 @@ sub emit_signal_in {
$self->_introspector->encode($signal, "signals", $name, "params", @args);
$self->get_service->get_bus->get_connection->send($signal);
+
+ # Short circuit locally registered callbacks
+ if (exists $self->{callbacks}->{$interface} &&
+ exists $self->{callbacks}->{$interface}->{$name}) {
+ my $cb = $self->{callbacks}->{$interface}->{$name};
+ &$cb(@args);
+ }
}
sub emit_signal {
@@ -203,12 +210,11 @@ sub emit_signal {
$self->emit_signal_in($name, $interfaces[0], @_);
}
-# XXX dont duplicate me from RemoteObject
+
sub connect_to_signal {
my $self = shift;
my $name = shift;
my $code = shift;
- my $lazy_binding = shift;
my $ins = $self->_introspector;
my @interfaces = $ins->has_signal($name);
@@ -221,19 +227,10 @@ sub connect_to_signal {
"in multiple interfaces of '" . $self->get_object_path . "'" .
"connecting to first interface only\n";
}
-
- $self->get_service->
- get_bus()->
- add_signal_receiver(sub {
- my $signal = shift;
- my $ins = $self->_introspector;
- my @params = $ins->decode($signal, "signals", $signal->get_member, "params");
- &$code(@params);
- },
- $name,
- $interfaces[0],
- $lazy_binding ? undef : $self->get_service->get_service_name(),
- $self->get_object_path);
+
+ $self->{callbacks}->{$interfaces[0]} = {} unless
+ exists $self->{callbacks}->{$interfaces[0]};
+ $self->{callbacks}->{$interfaces[0]}->{$name} = $code;
}
@@ -242,11 +239,11 @@ sub _dispatch {
my $connection = shift;
my $message = shift;
- my $method_name = $message->get_member;
- my @args = $message->get_args_list;
-
my $reply;
+ my $method_name = $message->get_member;
if ($self->can($method_name)) {
+ my @args = $self->_introspector->decode($message, "methods", $method_name, "params");
+
my @ret = eval {
$self->$method_name(@args);
};
@@ -256,7 +253,6 @@ sub _dispatch {
description => $@);
} else {
$reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
-
$self->_introspector->encode($reply, "methods", $method_name, "returns", @ret);
}
} elsif ($method_name eq "Introspect") {
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index dedee8c..0d55be8 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -9,7 +9,7 @@ our $VERSION = '0.0.1';
our $AUTOLOAD;
use Net::DBus::Binding::Message::MethodCall;
-use Net::DBus::Introspector;
+use Net::DBus::Binding::Introspector;
sub new {
my $class = shift;
@@ -51,8 +51,8 @@ sub _introspector {
my $iter = $reply->iterator;
my $xml = $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
- $self->{introspector} = Net::DBus::Introspector->new(xml => $xml,
- object_path => $self->{object_path});
+ $self->{introspector} = Net::DBus::Binding::Introspector->new(xml => $xml,
+ object_path => $self->{object_path});
}
return $self->{introspector};
}
--
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