[libnet-dbus-perl] 60/335: Caching of introspection data to avoid repeated lookups. Pass actual signal parameters into signal handler callbacks, rather than the useless lowlevel api info.

[Intrigeri]

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 d62b02e09d457b8fc92bd6cebd93fc44f1c1ff7e
Author: Daniel P. Berrange <dan at berrange.com>
Date:   Sun Aug 14 18:00:46 2005 +0000

    Caching of introspection data to avoid repeated lookups. Pass actual signal parameters into signal handler callbacks, rather than the useless lowlevel api info.
---
 lib/Net/DBus/RemoteObject.pm | 98 +++++++++++++++++++++++++++++++-------------
 1 file changed, 69 insertions(+), 29 deletions(-)

diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index 811d3d1..dedee8c 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -17,46 +17,74 @@ sub new {
 
     $self->{service} = shift;
     $self->{object_path}  = shift;
-    $self->{interface}    = shift;
     
     bless $self, $class;
 
-    $self->{introspector} = @_ ? shift : $self->_introspect();
-
     return $self;
 }
 
-sub _introspect {
+sub get_service {
     my $self = shift;
-    
-    my $call = Net::DBus::Binding::Message::MethodCall->
-	new(service_name => $self->{service}->get_service_name(),
-	    object_path => $self->{object_path},
-	    method_name => "Introspect",
-	    interface => "org.freedesktop.DBus.Introspectable");
+    return $self->{service};
+}
 
-    my $reply = $self->{service}->
-	get_bus()->
-	get_connection()->
-	send_with_reply_and_block($call, 5000);
-    
-    my $iter = $reply->iterator;
-    my $xml = $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
-    
-    return Net::DBus::Introspector->new(xml => $xml);
+sub get_object_path {
+    my $self = shift;
+    return $self->{object_path};
+}
+
+sub _introspector {
+    my $self = shift;
+
+    unless (defined $self->{introspector}) {
+	my $call = Net::DBus::Binding::Message::MethodCall->
+	    new(service_name => $self->{service}->get_service_name(),
+		object_path => $self->{object_path},
+		method_name => "Introspect",
+		interface => "org.freedesktop.DBus.Introspectable");
+	
+	my $reply = $self->{service}->
+	    get_bus()->
+	    get_connection()->
+	    send_with_reply_and_block($call, 5000);
+	
+	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});
+    }
+    return $self->{introspector};
 }
 
 sub connect_to_signal {
     my $self = shift;
-    my $signal_name = shift;
+    my $name = shift;
     my $code = shift;
     my $lazy_binding = shift;
-    
-    $self->{service}->
+
+    my $ins = $self->_introspector;
+    my @interfaces = $ins->has_signal($name);
+
+    if ($#interfaces == -1) {
+	die "no signal with name '$name' is exported in object '" .
+	    $self->get_object_path . "'\n";
+    } elsif ($#interfaces > 0) {
+	warn "signal with name '$name' is exported " .
+	    "in multiple interfaces of '" . $self->get_object_path . "'" .
+	    "connecting to first interface only\n";
+    }
+
+    $self->get_service->
 	get_bus()->
-	add_signal_receiver($code,
-			    $signal_name,
-			    $self->{interface},
+	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->{service}->get_service_name(),
 			    $self->{object_path});
 }
@@ -71,21 +99,33 @@ sub AUTOLOAD {
     my $sub = $AUTOLOAD;
     
     (my $method = $AUTOLOAD) =~ s/.*:://;
+
+    my $ins = $self->_introspector;
+    my @interfaces = $ins->has_method($method);
+
+    if ($#interfaces == -1) {
+	die "no method with name '$method' is exported in object '" .
+	    $self->get_object_path . "'\n";
+    } elsif ($#interfaces > 0) {
+	warn "method with name '$method' is exported " .
+	    "in multiple interfaces of '" . $self->get_object_path . "'" .
+	    "calling first interface only\n";
+    }
+
     my $call = Net::DBus::Binding::Message::MethodCall->
 	new(service_name => $self->{service}->get_service_name(),
 	    object_path => $self->{object_path},
 	    method_name => $method,
-	    interface => $self->{interface});
+	    interface => $interfaces[0]);
 
-    $self->{introspector}->encode($call, "methods", $method, "params", @_);
+    $ins->encode($call, "methods", $method, "params", @_);
 
     my $reply = $self->{service}->
 	get_bus()->
 	get_connection()->
 	send_with_reply_and_block($call, 5000);
     
-    my @reply = $reply->get_args_list();
-    #my @reply = $self->{introspector}->decode($reply, $method, "return");
+    my @reply = $ins->decode($reply, "methods", $method, "returns");
     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