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 4d96893e1f935b978b4637b484f1e95a27e665d9 Author: Daniel P. Berrange <berra...@redhat.com> Date: Mon Jul 3 09:31:32 2006 -0400 Added support for async reply callbacks --- CHANGES | 4 ++++ DBus.xs | 41 ++++++++++++++++++++++++++++++++++ examples/example-client-async.pl | 41 ++++++++++++++++++++++++++++++++++ examples/example-service-async.pl | 44 +++++++++++++++++++++++++++++++++++++ lib/Net/DBus/ASyncReply.pm | 19 ++++++++++++++++ lib/Net/DBus/Binding/PendingCall.pm | 15 +++++++++++++ 6 files changed, 164 insertions(+) diff --git a/CHANGES b/CHANGES index ba745ed..6288b75 100644 --- a/CHANGES +++ b/CHANGES @@ -22,6 +22,10 @@ Changes since 0.33.2 - Change re-distribution license from GPL, to GPL / Perl Artistic, matching the terms of Perl itself. + - Add support for registering a callback on Net::DBus::ASyncReply + objects to allow notification of completion for asynchronous + method calls + Changes since 0.33.1 - Fixed handling of variants in introspection data diff --git a/DBus.xs b/DBus.xs index 912112a..9da25af 100644 --- a/DBus.xs +++ b/DBus.xs @@ -35,6 +35,7 @@ initialization */ dbus_int32_t connection_data_slot = -1; dbus_int32_t server_data_slot = -1; +dbus_int32_t pending_call_data_slot = -1; void _object_release(void *obj) { @@ -268,11 +269,41 @@ if (0) { } void +_pending_call_callback(DBusPendingCall *call, + void *data) { + SV *selfref; + HV *self; + dSP; + + selfref = (SV*)dbus_pending_call_get_data(call, pending_call_data_slot); + self = (HV*)SvRV(selfref); + + dbus_pending_call_ref(call); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs((SV*)selfref); + PUTBACK; + + call_sv(data, G_DISCARD); + + FREETMPS; + LEAVE; +} + +void _filter_release(void *data) { SvREFCNT_dec(data); } void +_pending_call_notify_release(void *data) { + SvREFCNT_dec(data); +} + +void _path_unregister_callback(DBusConnection *con, void *data) { SvREFCNT_dec(data); @@ -411,6 +442,7 @@ BOOT: dbus_connection_allocate_data_slot(&connection_data_slot); dbus_server_allocate_data_slot(&server_data_slot); + dbus_pending_call_allocate_data_slot(&pending_call_data_slot); } @@ -1016,6 +1048,15 @@ dbus_pending_call_cancel(call) DBusPendingCall *call; void +_set_notify(call, code) + DBusPendingCall *call; + SV *code; + CODE: + SvREFCNT_inc(code); + PD_DEBUG("Adding pending call notify %p\n", code); + dbus_pending_call_set_notify(call, _pending_call_callback, code, _pending_call_notify_release); + +void DESTROY (call) DBusPendingCall *call; CODE: diff --git a/examples/example-client-async.pl b/examples/example-client-async.pl new file mode 100644 index 0000000..cbca6e2 --- /dev/null +++ b/examples/example-client-async.pl @@ -0,0 +1,41 @@ +#/usr/bin/perl + +use warnings; +use strict; + +use Net::DBus; +use Net::DBus::Reactor; +use Net::DBus::Callback; +use Net::DBus::Annotation qw(:call); + +my $bus = Net::DBus->session(); + +my $service = $bus->get_service("org.designfu.SampleService"); +my $object = $service->get_object("/SomeObject"); + +print "Doing async call\n"; +my $reply = $object->HelloWorld(dbus_call_async, "Hello from example-client.pl!"); + +my $r = Net::DBus::Reactor->main; + +sub all_done { + my $reply = shift; + my $list = $reply->get_result; + print "[", join(", ", map { "'$_'" } @{$list}), "]\n"; + + $r->shutdown; +} + +print "Setting notify\n"; +$reply->set_notify(\&all_done); + +sub tick { + print "Tick-tock\n"; +} + + +print "Adding timer\n"; +$r->add_timeout(500, Net::DBus::Callback->new(method => \&tick)); + +print "Entering main loop\n"; +$r->run; diff --git a/examples/example-service-async.pl b/examples/example-service-async.pl new file mode 100644 index 0000000..bb29f9d --- /dev/null +++ b/examples/example-service-async.pl @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Carp qw(confess cluck); +use Net::DBus; +use Net::DBus::Service; +use Net::DBus::Reactor; + +#... continued at botom + + +package SomeObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.designfu.SampleInterface); + +sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/SomeObject"); + bless $self, $class; + + return $self; +} + +dbus_method("HelloWorld", ["string"], [["array", "string"]]); +sub HelloWorld { + my $self = shift; + my $message = shift; + print "Do hello world\n"; + print $message, "\n"; + sleep 10; + return ["Hello", " from example-service-async.pl"]; +} + +package main; + +my $bus = Net::DBus->session(); +my $service = $bus->export_service("org.designfu.SampleService"); +my $object = SomeObject->new($service); + +Net::DBus::Reactor->main->run(); diff --git a/lib/Net/DBus/ASyncReply.pm b/lib/Net/DBus/ASyncReply.pm index 1e72131..94f6f60 100644 --- a/lib/Net/DBus/ASyncReply.pm +++ b/lib/Net/DBus/ASyncReply.pm @@ -119,6 +119,25 @@ sub is_ready { } +=item $asyncreply->set_notify($coderef); + +Sets a notify function which will be invoked when the +asynchronous reply finally completes. The callback will +be invoked with a single parameter which is this object. + +=cut + +sub set_notify { + my $self = shift; + my $cb = shift; + + $self->{pending_call}->set_notify(sub { + my $pending_call = shift; + + &$cb($self); + }); +} + =item my @data = $asyncreply->get_result; Retrieves the data associated with the asynchronous reply. diff --git a/lib/Net/DBus/Binding/PendingCall.pm b/lib/Net/DBus/Binding/PendingCall.pm index 36aff92..dfb1f0f 100644 --- a/lib/Net/DBus/Binding/PendingCall.pm +++ b/lib/Net/DBus/Binding/PendingCall.pm @@ -142,6 +142,21 @@ sub get_reply { } } +=item $call->set_notify($coderef); + +Sets a notification function to be invoked when the pending +call completes. The callback will be passed a single argument +which is this pending call object. + +=cut + +sub set_notify { + my $self = shift; + my $cb = shift; + + $self->{pending_call}->_set_notify($cb); +} + 1; =pod -- 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