[libnet-dbus-perl] 298/335: Add support for customizable timeouts on method calls
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:08:12 UTC 2015
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 <dan at 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.doe at example.com');
+ $object->salary(100000);
+ # Email is readonly, so we expect this to fail
+ eval {
+ $object->email('john.doe at 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('joe at 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
More information about the Pkg-perl-cvs-commits
mailing list