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 63661a3c1dd8b3baf6ab1499fff631bcb6c41816
Author: Daniel P. Berrange <d...@berrange.com>
Date:   Mon Jul 18 21:26:04 2011 +0100

    Add support for customizable timeouts on method calls
    
    Allowing overriding the default timeout on a bus object,
    a service and a remote object. Add an annotation to allow
    overriding the timeout on an individual method call.
    
    Based on a patch from Pavel Strashkin.
---
 examples/example-client-async.pl |   6 +++
 examples/example-client.pl       |  11 +++--
 examples/example-service.pl      |  10 ++--
 lib/Net/DBus.pm                  |  16 +++++++
 lib/Net/DBus/Annotation.pm       |  24 +++++++++-
 lib/Net/DBus/RemoteObject.pm     | 101 +++++++++++++++++++++++++++++++--------
 lib/Net/DBus/RemoteService.pm    |  43 +++++++++++++++--
 7 files changed, 177 insertions(+), 34 deletions(-)

diff --git a/examples/example-client-async.pl b/examples/example-client-async.pl
index deba421..cc44c81 100644
--- a/examples/example-client-async.pl
+++ b/examples/example-client-async.pl
@@ -38,3 +38,9 @@ $r->add_timeout(500, \&tick);
 
 print "Entering main loop\n";
 $r->run;
+
+# Call with a 15 second timeout, should still work
+print "Reply ", join(',', @{$object->HelloWorld(dbus_call_timeout, 15000, 
"Eeek")}), "\n";
+
+# Call with a 5 second timeout should fail
+print "Reply ", join(',', @{$object->HelloWorld(dbus_call_timeout, 5000, 
"Eeek")}), "\n";
diff --git a/examples/example-client.pl b/examples/example-client.pl
index 74ba76e..c0af94b 100644
--- a/examples/example-client.pl
+++ b/examples/example-client.pl
@@ -25,11 +25,14 @@ my $dict = $object->GetDict();
 
 print "{", join(", ", map { "'$_': '" . $dict->{$_} . "'"} keys %{$dict}), 
"}\n";
 
-if (0) {
+if (1) {
     $object->name("John Doe");
-    $object->age(21);
-#$object->email('john....@example.com');
+    $object->salary(100000);
+    # Email is readonly, so we expect this to fail
+    eval {
+       $object->email('john....@example.com');
+    };
     
-    print $object->name, " ", " ", $object->email, "\n";
+    print $object->name, " ", $object->email, "\n";
 
 }
diff --git a/examples/example-service.pl b/examples/example-service.pl
index 0343521..b651c32 100644
--- a/examples/example-service.pl
+++ b/examples/example-service.pl
@@ -16,11 +16,11 @@ package SomeObject;
 use base qw(Net::DBus::Object);
 use Net::DBus::Exporter qw(org.designfu.SampleInterface);
 
-#use Class::MethodMaker [ scalar => [ qw(name email age) ]];
+use Class::MethodMaker [ scalar => [ qw(name email salary) ]];
 
-#dbus_property("name", "string");
-#dbus_property("email", "string", "read");
-#dbus_property("age", "int32", "write");
+dbus_property("name", "string");
+dbus_property("email", "string", "read");
+dbus_property("salary", "int32", "write");
 
 sub new {
     my $class = shift;
@@ -60,4 +60,6 @@ my $bus = Net::DBus->session();
 my $service = $bus->export_service("org.designfu.SampleService");
 my $object = SomeObject->new($service);
 
+$object->email('j...@example.com');
+
 Net::DBus::Reactor->main->run();
diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm
index 2876d37..84ccc20 100644
--- a/lib/Net/DBus.pm
+++ b/lib/Net/DBus.pm
@@ -248,6 +248,7 @@ sub _new {
     $self->{signals} = [];
     # Map well known names to RemoteService objects
     $self->{services} = {};
+    $self->{timeout} = 60 * 1000;
 
     my %params = @_;
 
@@ -391,6 +392,21 @@ sub get_service_owner {
     return $owner;
 }
 
+=item my $timeout = $bus->timeout(60 * 1000);
+
+Sets or retrieves the timeout value which will be used for DBus
+requests belongs to this bus connection. The timeout should be
+specified in milliseconds, with the default value being 60 seconds.
+
+=cut
+
+sub timeout {
+    my $self = shift;
+    if (@_) {
+        $self->{timeout} = shift;
+    }
+    return $self->{timeout};
+}
 
 sub _add_signal_receiver {
     my $self = shift;
diff --git a/lib/Net/DBus/Annotation.pm b/lib/Net/DBus/Annotation.pm
index 0161580..000178b 100644
--- a/lib/Net/DBus/Annotation.pm
+++ b/lib/Net/DBus/Annotation.pm
@@ -43,6 +43,11 @@ Net::DBus::Annotation - annotations for changing behaviour 
of APIs
   ... some time later...
   my $processes = $asyncreply->get_data;
 
+
+  # List processes, with a shorter 10 second timeout, instead of
+  # the default 60 seconds
+  my $object->list_processes(dbus_call_timeout, 10 * 1000, "someuser");
+
 =head1 DESCRIPTION
 
 This module provides a number of annotations which will be useful
@@ -64,16 +69,18 @@ use warnings;
 our $CALL_SYNC = "sync";
 our $CALL_ASYNC = "async";
 our $CALL_NOREPLY = "noreply";
+our $CALL_TIMEOUT = "timeout";
 
 bless \$CALL_SYNC, __PACKAGE__;
 bless \$CALL_ASYNC, __PACKAGE__;
 bless \$CALL_NOREPLY, __PACKAGE__;
+bless \$CALL_TIMEOUT, __PACKAGE__;
 
 require Exporter;
 
 our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(dbus_call_sync dbus_call_async dbus_call_noreply);
-our %EXPORT_TAGS = (call => [qw(dbus_call_sync dbus_call_async 
dbus_call_noreply)]);
+our @EXPORT_OK = qw(dbus_call_sync dbus_call_async dbus_call_noreply 
dbus_call_timeout);
+our %EXPORT_TAGS = (call => [qw(dbus_call_sync dbus_call_async 
dbus_call_noreply dbus_call_timeout)]);
 
 =item dbus_call_sync
 
@@ -110,6 +117,19 @@ sub dbus_call_noreply() {
     return \$CALL_NOREPLY;
 }
 
+
+=item dbus_call_timeout
+
+Indicates that the next parameter for the method call will specify
+the time to wait for a reply in milliseconds. If omitted, then the
+default timeout for the object will be used
+
+=cut
+
+sub dbus_call_timeout() {
+    return \$CALL_TIMEOUT;
+}
+
 1;
 
 =pod
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index bd7f153..37fc700 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -59,8 +59,21 @@ use Net::DBus::Binding::Introspector;
 use Net::DBus::ASyncReply;
 use Net::DBus::Annotation qw(:call);
 
+#
+# BEGIN WARNING
+#
+# Each method added to this module prevents an application from
+# being able to invoke a similarly named method on a remote object.
+#
+# As such the aim is that no further public methods should be
+# added. All private methods should have a _net_dbus_ prefix on
+# them too.
+#
+# END WARNING
+#
 
-=item my $object = Net::DBus::RemoteObject->new($service, $object_path[, 
$interface]);
+
+=item my $object = Net::DBus::RemoteObject->new($service, $object_path[, 
$interface], \%params);
 
 Creates a new handle to a remote object. The C<$service> parameter is an 
instance
 of the L<Net::DBus::RemoteService> method, and C<$object_path> is the 
identifier of
@@ -73,6 +86,10 @@ method names are unique. Rather than using this constructor 
directly, it is pref
 to use the C<get_object> method on L<Net::DBus::RemoteService>, since this 
caches handles
 to remote objects, eliminating unneccessary introspection data lookups.
 
+The C<%params> parameter contains extra configuration parameters for the 
object. Currently
+a single parameter is supported, C<timeout> which takes a value in 
milliseconds to use as
+the timeout for method calls on the object.
+
 =cut
 
 
@@ -88,6 +105,9 @@ sub new {
     $self->{signal_handlers} = {};
     $self->{signal_id} = 0;
 
+    my %params = @_;
+    $self->{timeout} = $params{timeout};
+
     bless $self, $class;
 
     return $self;
@@ -160,7 +180,7 @@ sub get_child_object {
                      $interface);
 }
 
-sub _introspector {
+sub _net_dbus_introspector {
     my $self = shift;
 
 
@@ -218,7 +238,7 @@ sub connect_to_signal {
     my $name = shift;
     my $code = shift;
 
-    my $ins = $self->_introspector;
+    my $ins = $self->_net_dbus_introspector;
     my $interface = $self->{interface};
     if (!$interface) {
        if (!$ins) {
@@ -246,7 +266,7 @@ sub connect_to_signal {
 
     my $cb = sub {
        my $signal = shift;
-       my $ins = $self->_introspector;
+       my $ins = $self->_net_dbus_introspector;
        my @params;
        if ($ins) {
            @params = $ins->decode($signal, "signals", $signal->get_member, 
"params");
@@ -289,7 +309,7 @@ sub disconnect_from_signal {
     my $name = shift;
     my $sigid = shift;
 
-    my $ins = $self->_introspector;
+    my $ins = $self->_net_dbus_introspector;
     my $interface = $self->{interface};
     if (!$interface) {
        if (!$ins) {
@@ -336,14 +356,39 @@ sub DESTROY {
     # call DESTROY on remote object
 }
 
+sub _net_dbus_timeout {
+    my $self = shift;
+
+    if (defined $self->{timeout}) {
+       return $self->{timeout};
+    }
+    if (defined $self->get_service()->timeout()) {
+       return $self->get_service()->timeout();
+    }
+    return $self->get_service()->get_bus()->timeout();
+}
+
+
 sub AUTOLOAD {
     my $self = shift;
     my $sub = $AUTOLOAD;
 
     my $mode = dbus_call_sync;
-    if (@_ && UNIVERSAL::isa($_[0], "Net::DBus::Annotation")) {
-       $mode = shift;
+    my $timeout;
+
+    while (@_ && UNIVERSAL::isa($_[0], "Net::DBus::Annotation")) {
+       if ($_[0] eq dbus_call_sync ||
+           $_[0] eq dbus_call_async ||
+           $_[0] eq dbus_call_noreply) {
+           $mode = shift;
+       } elsif ($_[0] eq dbus_call_timeout) {
+           shift;
+           $timeout = shift;
+       } else {
+           die "Unknown annotation $_[0]";
+       }
     }
+    $timeout = $self->_net_dbus_timeout() unless defined $timeout;
 
     (my $name = $AUTOLOAD) =~ s/.*:://;
 
@@ -352,11 +397,13 @@ sub AUTOLOAD {
     # 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();
+    my $ins = $self->_net_dbus_introspector();
     if ($ins) {
        if ($interface) {
            if ($ins->has_method($name, $interface)) {
-               return $self->_call_method($mode, $name, $interface, 1, @_);
+               return $self->_net_dbus_call_method($mode, $timeout,
+                                                   $name, $interface, 1,
+                                                   @_);
            }
            if ($ins->has_property($name, $interface)) {
                if ($ins->is_property_deprecated($name, $interface)) {
@@ -364,10 +411,14 @@ sub AUTOLOAD {
                }
 
                if (@_) {
-                   $self->_call_method($mode, "Set", 
"org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
+                   $self->_net_dbus_call_method($mode, $timeout,
+                                                "Set", 
"org.freedesktop.DBus.Properties",
+                                                $interface, 1, $name, $_[0]);
                    return ();
                } else {
-                   return $self->_call_method($mode, "Get", 
"org.freedesktop.DBus.Properties", $interface, 1, $name);
+                   return $self->_net_dbus_call_method($mode, $timeout,
+                                                       "Get", 
"org.freedesktop.DBus.Properties",
+                                                       $interface, 1, $name);
                }
            }
        } else {
@@ -378,7 +429,8 @@ sub AUTOLOAD {
                    die "method with name '$name' is exported " .
                        "in multiple interfaces of '" . $self->get_object_path 
. "'";
                }
-               return $self->_call_method($mode, $name, $interfaces[0], 1, @_);
+               return $self->_net_dbus_call_method($mode, $timeout,
+                                                   $name, $interfaces[0], 1, 
@_);
            }
            @interfaces = $ins->has_property($name);
 
@@ -392,10 +444,14 @@ sub AUTOLOAD {
                    warn "property $name in interface $interface on " . 
$self->get_object_path . " is deprecated";
                }
                if (@_) {
-                   $self->_call_method($mode, "Set", 
"org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
+                   $self->_net_dbus_call_method($mode, $timeout,
+                                                "Set", 
"org.freedesktop.DBus.Properties",
+                                                $interface, 1, $name, $_[0]);
                    return ();
                } else {
-                   return $self->_call_method($mode, "Get", 
"org.freedesktop.DBus.Properties", $interface, 1, $name);
+                   return $self->_net_dbus_call_method($mode, $timeout,
+                                                       "Get", 
"org.freedesktop.DBus.Properties",
+                                                       $interface, 1, $name);
                }
            }
        }
@@ -406,20 +462,23 @@ sub AUTOLOAD {
            $self->get_object_path . "', and object is not cast to any 
interface";
     }
 
-    return $self->_call_method($mode, $name, $interface, 0, @_);
+    return $self->_net_dbus_call_method($mode, $timeout,
+                                       $name, $interface,
+                                       0, @_);
 }
 
 
-sub _call_method {
+sub _net_dbus_call_method {
     my $self = shift;
     my $mode = shift;
+    my $timeout = shift;
     my $name = shift;
     my $interface = shift;
     my $introspect = shift;
 
     my $con = $self->{service}->get_bus()->get_connection();
 
-    my $ins = $introspect ? $self->_introspector : undef;
+    my $ins = $introspect ? $self->_net_dbus_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";
@@ -440,7 +499,7 @@ sub _call_method {
 
     if ($mode == dbus_call_sync) {
        my $reply = $con->
-           send_with_reply_and_block($call, 60 * 1000);
+           send_with_reply_and_block($call, $timeout);
 
        my @reply;
        if ($ins) {
@@ -454,7 +513,7 @@ sub _call_method {
        my $pending_call = $self->{service}->
            get_bus()->
            get_connection()->
-           send_with_reply($call, 60 * 1000);
+           send_with_reply($call, $timeout);
        my $reply = Net::DBus::ASyncReply->_new(pending_call => $pending_call,
                                                ($ins ? (introspector => $ins,
                                                         method_name => $name)
@@ -465,7 +524,7 @@ sub _call_method {
        $self->{service}->
            get_bus()->
            get_connection()->
-           send($call, 60 * 1000);
+           send($call, $timeout);
     } else {
        die "unsupported annotation '$mode'";
     }
@@ -488,6 +547,6 @@ Copright (C) 2004-2011, Daniel Berrange.
 
 =head1 SEE ALSO
 
-L<Net::DBus::RemoteService>, L<Net::DBus::Object>
+L<Net::DBus::RemoteService>, L<Net::DBus::Object>, L<Net::DBus::Annotation>
 
 =cut
diff --git a/lib/Net/DBus/RemoteService.pm b/lib/Net/DBus/RemoteService.pm
index 6ab8068..2c05a5d 100644
--- a/lib/Net/DBus/RemoteService.pm
+++ b/lib/Net/DBus/RemoteService.pm
@@ -121,6 +121,7 @@ sub get_owner_name {
 }
 
 =item my $object = $service->get_object($object_path[, $interface]);
+=item my $object = $service->get_object($object_path, \%params);
 
 Retrieves a handle to the remote object provided by the service  with
 the name of C<$object_path>. If the optional C<$interface> parameter is
@@ -130,25 +131,61 @@ interface if there are multiple interfaces on the object 
providing
 methods with the same name, or the remote object does support
 introspection. The returned object will be an instance of 
L<Net::DBus::RemoteObject>.
 
+An alternate form of the method is available, passing a hash reference
+of extra parameters. Valid keys in the hash are C<interface> specifying
+the interface name to cast to, and C<timeout> specifying a timeout in
+milliseconds
+
 =cut
 
 sub get_object {
     my $self = shift;
     my $object_path = shift;
 
+    my $timeout;
+    my $interface;
+
+    if (@_) {
+       if (int(@_) == 1) {
+           $interface = shift;
+       } else {
+           my %params = @_;
+           $interface = $params{interface};
+           $timeout = $params{timeout};
+       }
+    }
+
     unless (defined $self->{objects}->{$object_path}) {
        $self->{objects}->{$object_path} = Net::DBus::RemoteObject->new($self,
-                                                                       
$object_path);
+                                                                       
$object_path,
+                                                                       undef,
+                                                                       timeout 
=> $timeout);
     }
 
-    if (@_) {
-       my $interface = shift;
+    if (defined $interface) {
        return $self->{objects}->{$object_path}->as_interface($interface);
     } else {
        return $self->{objects}->{$object_path};
     }
 }
 
+=item my $timeout = $service->timeout(60 * 1000);
+
+Sets or retrieves the timeout value which will be used for DBus
+requests belongs to this service. The value is in miliseconds.
+If the timeout for a service is undefined, then the default
+timeout from the bus will apply.
+
+=cut
+
+sub timeout {
+    my $self = shift;
+    if (@_) {
+        $self->{timeout} = shift;
+    }
+    return $self->{timeout};
+}
+
 1;
 
 

-- 
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

Reply via email to