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 ad0dadc8897f5670a347c0dede78e09f00092da5
Author: Daniel P. Berrange <d...@berrange.com>
Date: Mon Nov 21 11:39:10 2005 +0000
Re-work dispatching to be more robuse to partial/incomplete introspection
data. Print warnings for any methods/signals annotated as deprecated
---
lib/Net/DBus/RemoteObject.pm | 128 ++++++++++++++++++++++++++++---------------
1 file changed, 84 insertions(+), 44 deletions(-)
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index 0a7ad68..955c5b3 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -16,7 +16,7 @@
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
-# $Id: RemoteObject.pm,v 1.17 2005/10/23 16:28:44 dan Exp $
+# $Id: RemoteObject.pm,v 1.18 2005/11/21 11:39:10 dan Exp $
=pod
@@ -148,7 +148,7 @@ sub get_object_path {
sub _introspector {
my $self = shift;
-
+
unless ($self->{introspected}) {
my $call = Net::DBus::Binding::Message::MethodCall->
new(service_name => $self->{service}->get_service_name(),
@@ -205,9 +205,9 @@ sub connect_to_signal {
my $name = shift;
my $code = shift;
+ my $ins = $self->_introspector;
my $interface = $self->{interface};
if (!$interface) {
- my $ins = $self->_introspector;
if (!$ins) {
die "no introspection data available for '" .
$self->get_object_path .
"', and object is not cast to any interface";
@@ -225,6 +225,12 @@ sub connect_to_signal {
$interface = $interfaces[0];
}
+ if ($ins &&
+ $ins->has_signal($name, $interface) &&
+ $ins->is_signal_deprecated($name, $interface)) {
+ warn "signal $name in interface $interface on " .
$self->get_object_path . " is deprecated";
+ }
+
$self->get_service->
get_bus()->
_add_signal_receiver(sub {
@@ -257,43 +263,65 @@ sub AUTOLOAD {
(my $name = $AUTOLOAD) =~ s/.*:://;
my $interface = $self->{interface};
+
+ # If introspection data is available, use that
+ # to resolve correct interface (if object is not
+ # cast to an explicit interface already)
my $ins = $self->_introspector();
if ($ins) {
- my @interfaces = $ins->has_method($name);
-
- if (@interfaces) {
- if ($#interfaces > 0) {
- warn "method with name '$name' is exported " .
- "in multiple interfaces of '" . $self->get_object_path .
"'" .
- "calling first interface only\n";
+ if ($interface) {
+ if ($ins->has_method($name, $interface)) {
+ return $self->_call_method($name, $interface, 1, @_);
}
- return $self->_call_method($name, $interfaces[0], @_);
- }
- @interfaces = $ins->has_property($name);
-
- if (@interfaces) {
- if ($#interfaces > 0) {
- warn "property with name '$name' is exported " .
- "in multiple interfaces of '" . $self->get_object_path .
"'" .
- "calling first interface only\n";
+ if ($ins->has_property($name, $interface)) {
+ if ($ins->is_property_deprecated($name, $interface)) {
+ warn "property $name in interface $interface on " .
$self->get_object_path . " is deprecated";
+ }
+
+ if (@_) {
+ $self->_call_method("Set",
"org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
+ return ();
+ } else {
+ return $self->_call_method("Get",
"org.freedesktop.DBus.Properties", $interface, 1, $name);
+ }
}
- if (@_) {
- $self->_call_method("Set", "org.freedesktop.DBus.Properties",
$interfaces[0], $name, $_[0]);
- return ();
- } else {
- return $self->_call_method("Get",
"org.freedesktop.DBus.Properties", $interfaces[0], $name);
+ } else {
+ my @interfaces = $ins->has_method($name);
+
+ if (@interfaces) {
+ if ($#interfaces > 0) {
+ die "method with name '$name' is exported " .
+ "in multiple interfaces of '" . $self->get_object_path
. "'";
+ }
+ return $self->_call_method($name, $interfaces[0], 1, @_);
+ }
+ @interfaces = $ins->has_property($name);
+
+ if (@interfaces) {
+ if ($#interfaces > 0) {
+ die "property with name '$name' is exported " .
+ "in multiple interfaces of '" . $self->get_object_path
. "'";
+ }
+ $interface = $interfaces[0];
+ if ($ins->is_property_deprecated($name, $interface)) {
+ warn "property $name in interface $interface on " .
$self->get_object_path . " is deprecated";
+ }
+ if (@_) {
+ $self->_call_method("Set",
"org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
+ return ();
+ } else {
+ return $self->_call_method("Get",
"org.freedesktop.DBus.Properties", $interface, 1, $name);
+ }
}
}
- die "no method or property with name '$name' is exported in object '" .
- $self->get_object_path . "'\n";
- } else {
- if (!$interface) {
- die "no introspection data available for '" .
$self->get_object_path .
- "', and object is not cast to any interface";
- }
-
- return $self->_call_method($name, $interface, @_);
}
+
+ if (!$interface) {
+ die "no introspection data available for method '" . $name . "' in
object '" .
+ $self->get_object_path . "', and object is not cast to any
interface";
+ }
+
+ return $self->_call_method($name, $interface, 0, @_);
}
@@ -301,6 +329,13 @@ sub _call_method {
my $self = shift;
my $name = shift;
my $interface = shift;
+ my $introspect = shift;
+
+ my $ins = $introspect ? $self->_introspector : undef;
+ if ($ins &&
+ $ins->is_method_deprecated($name, $interface)) {
+ warn "method '$name' in interface $interface on object " .
$self->get_object_path . " is deprecated\n";
+ }
my $call = Net::DBus::Binding::Message::MethodCall->
new(service_name => $self->{service}->get_service_name(),
@@ -308,25 +343,30 @@ sub _call_method {
method_name => $name,
interface => $interface);
- my $ins = $self->_introspector;
if ($ins) {
$ins->encode($call, "methods", $name, "params", @_);
} else {
$call->append_args_list(@_);
}
-
- my $reply = $self->{service}->
- get_bus()->
- get_connection()->
- send_with_reply_and_block($call, 60 * 1000);
- my @reply;
- if ($ins) {
- @reply = $ins->decode($reply, "methods", $name, "returns");
+ if (!$ins ||
+ $ins->does_method_reply($name, $interface)) {
+ my $reply = $self->{service}->
+ get_bus()->
+ get_connection()->
+ send_with_reply_and_block($call, 60 * 1000);
+
+ my @reply;
+ if ($ins) {
+ @reply = $ins->decode($reply, "methods", $name, "returns");
+ } else {
+ @reply = $reply->get_args_list;
+ }
+
+ return wantarray ? @reply : $reply[0];
} else {
- @reply = $reply->get_args_list;
+ return wantarray ? () : undef;
}
- return wantarray ? @reply : $reply[0];
}
--
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
