[libnet-dbus-perl] 284/335: Add API for disconnecting from a signal (rt #52764)

[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 b5d0a14cbbdd43c5e719ed8c3dd8d1ae2427076c
Author: Daniel P. Berrange <dan at berrange.com>
Date:   Tue Jun 28 23:08:10 2011 +0100

    Add API for disconnecting from a signal (rt #52764)
---
 examples/example-signal-receiver.pl |  24 +++++++-
 lib/Net/DBus/RemoteObject.pm        | 109 +++++++++++++++++++++++++++++-------
 2 files changed, 111 insertions(+), 22 deletions(-)

diff --git a/examples/example-signal-receiver.pl b/examples/example-signal-receiver.pl
index 85b2bdc..59041ff 100644
--- a/examples/example-signal-receiver.pl
+++ b/examples/example-signal-receiver.pl
@@ -17,12 +17,30 @@ my $service = $bus->get_service("org.designfu.TestService");
 my $object  = $service->get_object("/org/designfu/TestService/object",
 				   "org.designfu.TestService");
 
-sub hello_signal_handler {
+my $sig1;
+my $sig2;
+
+my $sig1ref = \$sig1;
+my $sig2ref = \$sig2;
+
+sub hello_signal_handler1 {
     my $greeting = shift;
-    print "Received hello signal with greeting '$greeting'\n";
+    print ${$sig1ref} . " Received hello signal with greeting '$greeting'\n";
+
+    unless (${$sig2ref}) {
+	$object->disconnect_from_signal("HelloSignal", ${$sig1ref});
+    }
+}
+sub hello_signal_handler2 {
+    my $greeting = shift;
+    print ${$sig2ref} . " Received hello signal with greeting '$greeting'\n";
+
+    $object->disconnect_from_signal("HelloSignal", ${$sig2ref});
+    ${$sig2ref} = undef;
 }
 
-$object->connect_to_signal("HelloSignal", \&hello_signal_handler);
+$sig1 = $object->connect_to_signal("HelloSignal", \&hello_signal_handler1);
+$sig2 = $object->connect_to_signal("HelloSignal", \&hello_signal_handler2);
 
 my $reactor = Net::DBus::Reactor->main();
 
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index ed9e5a5..9ff1302 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -85,6 +85,8 @@ sub new {
     $self->{object_path}  = shift;
     $self->{interface} = @_ ? shift : undef;
     $self->{introspected} = 0;
+    $self->{signal_handlers} = {};
+    $self->{signal_id} = 0;
 
     bless $self, $class;
 
@@ -199,13 +201,15 @@ sub _introspector {
 }
 
 
-=item $object->connect_to_signal($name, $coderef);
+=item my $sigid = $object->connect_to_signal($name, $coderef);
 
 Connects a callback to a signal emitted by the object. The C<$name>
 parameter is the name of the signal within the object, and C<$coderef>
 is a reference to an anonymous subroutine. When the signal C<$name>
 is emitted by the remote object, the subroutine C<$coderef> will be
-invoked, and passed the parameters from the signal.
+invoked, and passed the parameters from the signal. A unique C<$sigid>
+will be returned, which can be later passed to C<disconnect_from_signal>
+to remove the handler
 
 =cut
 
@@ -240,23 +244,90 @@ sub connect_to_signal {
 	warn "signal $name in interface $interface on " . $self->get_object_path . " is deprecated";
     }
 
-    $self->get_service->
-	get_bus()->
-	_add_signal_receiver(sub {
-	    my $signal = shift;
-	    my $ins = $self->_introspector;
-	    my @params;
-	    if ($ins) {
-		@params = $ins->decode($signal, "signals", $signal->get_member, "params");
-	    } else {
-		@params = $signal->get_args_list;
-	    }
-	    &$code(@params);
-	},
-			     $name,
-			     $interface,
-			     $self->{service}->get_owner_name(),
-			     $self->{object_path});
+    my $cb = sub {
+	my $signal = shift;
+	my $ins = $self->_introspector;
+	my @params;
+	if ($ins) {
+	    @params = $ins->decode($signal, "signals", $signal->get_member, "params");
+	} else {
+	    @params = $signal->get_args_list;
+	}
+
+	foreach my $handler (@{$self->{signal_handlers}->{$signal->get_member}->{handlers}}) {
+	    my ($id, $cb) = @{$handler};
+	    &$cb(@params);
+	}
+    };
+    if (!exists $self->{signal_handlers}->{$name}) {
+	$self->{signal_handlers}->{$name} = { cb => $cb, handlers => [] };
+	$self->get_service->
+	    get_bus()->
+	    _add_signal_receiver($cb,
+				 $name,
+				 $interface,
+				 $self->{service}->get_owner_name(),
+				 $self->{object_path});
+    }
+    my $sigid = ++$self->{signal_id};
+    push @{$self->{signal_handlers}->{$name}->{handlers}}, [$sigid, $code];
+    return $sigid;
+}
+
+
+=item $object->disconnect_from_signal($name, $sigid);
+
+Disconnects from a signal emitted by the object. The C<$name>
+parameter is the name of the signal within the object. The
+C<$sigid> must be the unique signal handler ID returned by
+a previous C<connect_to_signal> method call.
+
+=cut
+
+sub disconnect_from_signal {
+    my $self = shift;
+    my $name = shift;
+    my $sigid = shift;
+
+    my $ins = $self->_introspector;
+    my $interface = $self->{interface};
+    if (!$interface) {
+	if (!$ins) {
+	    die "no introspection data available for '" . $self->get_object_path .
+		"', and object is not cast to any interface";
+	}
+	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";
+	}
+	$interface = $interfaces[0];
+    }
+
+    my @handlers;
+    foreach my $handler (@{$self->{signal_handlers}->{$name}->{handlers}}) {
+	my ($thissigid, $cb) = @{$handler};
+	if ($thissigid != $sigid) {
+	    push @handlers, $handler;
+	}
+    }
+    if (@handlers) {
+	$self->{signal_handlers}->{$name}->{handlers} = \@handlers;
+    } else {
+	$self->get_service->
+	    get_bus()->
+	    _remove_signal_receiver($self->{signal_handlers}->{$name}->{cb},
+				    $name,
+				    $interface,
+				    $self->{service}->get_owner_name(),
+				    $self->{object_path});
+	delete $self->{signal_handlers}->{$name};
+    }
 }
 
 

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git