[libnet-dbus-perl] 107/335: Add caching of service ownership info & online status, adapting method call timeouts using this info to allow extra time for activation
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:34 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 a1304b6ff416bf90c0bb7516d94aa23d63a53d32
Author: Daniel P. Berrange <dan at berrange.com>
Date: Mon Sep 12 22:33:48 2005 +0000
Add caching of service ownership info & online status, adapting method call timeouts using this info to allow extra time for activation
---
CHANGES | 19 +++++
lib/Net/DBus.pm | 174 +++++++++++++++++++++++++++++++++++--------
lib/Net/DBus/RemoteObject.pm | 153 +++++++++++++++++++++++++++++++++----
3 files changed, 301 insertions(+), 45 deletions(-)
diff --git a/CHANGES b/CHANGES
index 1f8ae95..69de0a4 100644
--- a/CHANGES
+++ b/CHANGES
@@ -9,6 +9,25 @@ Changes since 0.32.1
- Added full support for org.freedesktop.DBus.Properties
in exported & remote objects.
+ - Added support for getting the unique name of the client's
+ connection to the bus
+
+ - Added support for getting the unique name of the client
+ owning a service on the bus
+
+ - Cache details of online services & their owners to avoid
+ repeated calls to GetNameOwner & related methods.
+
+ - Cache RemoteService objects to avoid creating multiple
+ instances for the same service name.
+
+ - Fix caching of objects by the service to avoid caching
+ objects cast to a specific interface
+
+ - Make add_signal_receiver method on Net::DBus private
+
+ - Lots more POD documentation
+
Changes since 0.32.0
- The order of 'service_name' and 'bus' parameter to the
diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm
index 15675f6..efcf2e3 100644
--- a/lib/Net/DBus.pm
+++ b/lib/Net/DBus.pm
@@ -188,6 +188,7 @@ sub _new {
$self->{connection} = shift;
$self->{signals} = {};
+ $self->{services} = {};
my %params = @_;
@@ -203,6 +204,50 @@ sub _new {
$self->get_connection->add_filter(sub { $self->_signal_func(@_) });
+ $self->_manage_names();
+ return $self;
+}
+
+
+sub _manage_names {
+ my $self = shift;
+
+ $self->{services}->{"org.freedesktop.DBus"} = { online => 1 };
+
+ my $bus = $self->get_bus_object;
+
+ $bus->connect_to_signal("NameOwnerChanged", sub {
+ my $name = shift;
+ my $orig = shift;
+ my $new = shift;
+
+ if (exists $self->{services}->{$name}) {
+ if ($self->{services}->{$name}->{instance}) {
+ $self->{services}->{$name}->{online} = $new ? 1 : 0;
+ $self->{services}->{$name}->{owner} = $new;
+ } else {
+ if ($new) {
+ $self->{services}->{$name}->{online} = 1;
+ $self->{services}->{$name}->{owner} = $new;
+ } else {
+ delete $self->{services}->{$name};
+ }
+ }
+ } else {
+ if ($new) {
+ $self->{services}->{$name} = {
+ online => 1,
+ owner => $new
+ };
+ }
+ }
+ });
+
+ foreach (@{$bus->ListNames}) {
+ $self->{services}->{$_} = { online => 1, owner => undef };
+ }
+
+
return $self;
}
@@ -237,7 +282,15 @@ sub get_service {
my $self = shift;
my $name = shift;
- return Net::DBus::RemoteService->new($self, $name);
+ if (!exists $self->{services}->{$name}) {
+ $self->{services}->{$name} = { online => 0, owner => undef };
+ }
+
+ if (!defined $self->{services}->{$name}->{instance}) {
+ $self->{services}->{$name}->{instance} = Net::DBus::RemoteService->new($self, $name);
+ }
+
+ return $self->{services}->{$name}->{instance};
}
=pod
@@ -256,14 +309,8 @@ sub has_service {
my $self = shift;
my $name = shift;
- my $dbus = $self->get_service("org.freedesktop.DBus");
- my $bus = $dbus->get_object("/org/freedesktop/DBus");
- my $services = $bus->ListNames;
-
- foreach (@{$services}) {
- return 1 if $_ eq $name;
- }
- return 0;
+ return exists $self->{services}->{$name} &&
+ $self->{services}->{$name}->{online};
}
@@ -283,7 +330,68 @@ sub export_service {
return Net::DBus::Service->new($self, $name);
}
-sub add_signal_receiver {
+=pod
+
+=item my $object = $bus->get_bus_object;
+
+Retrieves a handle to the bus object, C</org/freedesktop/DBus>,
+provided by the service C<org.freedesktop.DBus>. The returned
+object is an instance of L<Net::DBus::RemoteObject>
+
+=cut
+
+sub get_bus_object {
+ my $self = shift;
+
+ my $service = $self->get_service("org.freedesktop.DBus");
+ return $service->get_object('/org/freedesktop/DBus',
+ 'org.freedesktop.DBus');
+}
+
+
+=pod
+
+=item my $name = $bus->get_unique_name;
+
+Retrieves the unique name of this client's connection to
+the bus.
+
+=cut
+
+sub get_unique_name {
+ my $self = shift;
+
+ return $self->get_connection->get_unique_name
+}
+
+=pod
+
+=item my $name = $bus->get_service_owner($service);
+
+Retrieves the unique name of the client on the bus owning
+the service named by the C<$service> parameter.
+
+=cut
+
+sub get_service_owner {
+ my $self = shift;
+ my $service = shift;
+
+ if (!exists $self->{services}->{$service}) {
+ $self->{services}->{$service} = { online => 0, owner => undef };
+ }
+
+ if (!defined $self->{services}->{$service}->{owner}) {
+ my $bus = $self->get_bus_object;
+ my $owner = $bus->GetNameOwner($service);
+ $self->{services}->{$service}->{online} = 1;
+ $self->{services}->{$service}->{owner} = $owner;
+ }
+ return $self->{services}->{$service}->{owner};
+}
+
+
+sub _add_signal_receiver {
my $self = shift;
my $receiver = shift;
my $signal_name = shift;
@@ -299,7 +407,7 @@ sub add_signal_receiver {
$self->{connection}->add_match($rule);
}
-sub remove_signal_receiver {
+sub _remove_signal_receiver {
my $self = shift;
my $receiver = shift;
my $signal_name = shift;
@@ -333,14 +441,13 @@ sub _match_rule {
$rule .= ",interface='$interface'";
}
if ($service) {
- if ($service !~ /^:/ &&
- $service ne "org.freedesktop.DBus") {
- my $bus_service = $self->get_service("org.freedesktop.DBus");
- my $bus_object = $bus_service->get_object('/org/freedesktop/DBus',
- 'org.freedesktop.DBus');
- $service = $bus_object->GetNameOwner($service);
+ if ($service !~ /^:/) {
+ # Resolve service name to a client id
+ $service = $self->get_service_owner($service);
+ }
+ if ($service) {
+ $rule .= ",sender='$service'";
}
- $rule .= ",sender='$service'";
}
if ($path) {
$rule .= ",path='$path'";
@@ -410,20 +517,6 @@ sub _signal_func {
return $handled;
}
-package Net::DBus::Error;
-
-use overload ('""' => 'stringify');
-
-sub stringify {
- my $self = shift;
-
- return $self->{name} . ": " . $self->{message};
-}
-
-
-1;
-__END__
-
=pod
=back
@@ -447,3 +540,20 @@ This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
+
+1;
+
+package Net::DBus::Error;
+
+use overload ('""' => 'stringify');
+
+sub stringify {
+ my $self = shift;
+
+ return $self->{name} . ": " . $self->{message};
+}
+
+
+1;
+
+
diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm
index f3af993..898d862 100644
--- a/lib/Net/DBus/RemoteObject.pm
+++ b/lib/Net/DBus/RemoteObject.pm
@@ -1,3 +1,34 @@
+=pod
+
+=head1 NAME
+
+Net::DBus::RemoteObject - access objects on the bus
+
+=head1 SYNOPSIS
+
+ my $service = $bus->get_service("org.freedesktop.DBus");
+ my $object = $service->get_object("/org/freedesktop/DBus");
+
+ print "Names on the bus {\n";
+ foreach my $name (sort $object->ListNames) {
+ print " ", $name, "\n";
+ }
+ print "}\n";
+
+=head1 DESCRIPTION
+
+This module provides the API for accessing remote objects available
+on the bus. It uses the autoloader to fake the presence of methods
+based on the API of the remote object. There is also support for
+setting callbacks against signals, and accessing properties of the
+object.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
package Net::DBus::RemoteObject;
use 5.006;
@@ -5,14 +36,32 @@ use strict;
use warnings;
use Carp;
-our $VERSION = '0.0.1';
our $AUTOLOAD;
use Net::DBus::Binding::Message::MethodCall;
use Net::DBus::Binding::Introspector;
+=pod
+
+=item my $object = Net::DBus::RemoteObject->new($service, $object_path[, $interface]);
+
+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
+an object exported by this service, for example C</org/freedesktop/DBus>. For remote
+objects which implement more than one interface it is possible to specify an optional
+name of an interface as the third parameter. This is only really required, however, if
+two interfaces in the object provide methods with the same name, since introspection
+data can be used to automatically resolve the correct interface to call cases where
+method names are unique. Rather than using this constructor directly, it is preferrable
+to use the C<get_object> method on L<Net::DBus::RemoteService>, since this caches handles
+to remote objects, eliminating unneccessary introspection data lookups.
+
+=cut
+
+
sub new {
- my $class = shift;
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
my $self = {};
$self->{service} = shift;
@@ -25,6 +74,18 @@ sub new {
return $self;
}
+=pod
+
+=item my $object = $object->as_interface($interface);
+
+Casts the object to a specific interface, returning a new instance of the
+L<Net::DBus::RemoteObject> specialized to the desired interface. It is only
+neccessary to cast objects to a specific interface, if two interfaces
+export methods or signals with the same name, or the remote object does not
+support introspection.
+
+=cut
+
sub as_interface {
my $self = shift;
my $interface = shift;
@@ -37,11 +98,29 @@ sub as_interface {
$interface);
}
+=pod
+
+=item my $service = $object->get_service
+
+Retrieves a handle for the remote service on which this object is
+attached. The returned object is an instance of L<Net::DBus::RemoteService>
+
+=cut
+
sub get_service {
my $self = shift;
return $self->{service};
}
+=pod
+
+=item my $path = $object->get_object_path
+
+Retrieves the unique path identifier for this object within the
+service.
+
+=cut
+
sub get_object_path {
my $self = shift;
return $self->{object_path};
@@ -49,6 +128,8 @@ sub get_object_path {
sub _introspector {
my $self = shift;
+ my $timeout = shift;
+ $timeout = 5 unless defined $timeout;
unless ($self->{introspected}) {
my $call = Net::DBus::Binding::Message::MethodCall->
@@ -61,7 +142,7 @@ sub _introspector {
my $reply = $self->{service}->
get_bus()->
get_connection()->
- send_with_reply_and_block($call, 5000);
+ send_with_reply_and_block($call, $timeout * 1000);
my $iter = $reply->iterator;
return $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
@@ -88,10 +169,24 @@ sub _introspector {
return $self->{introspector};
}
+
+=pod
+
+=item $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.
+
+=cut
+
sub connect_to_signal {
my $self = shift;
my $name = shift;
my $code = shift;
+ # This will likely go away
my $lazy_binding = shift;
my $interface = $self->{interface};
@@ -116,7 +211,7 @@ sub connect_to_signal {
$self->get_service->
get_bus()->
- add_signal_receiver(sub {
+ _add_signal_receiver(sub {
my $signal = shift;
my $ins = $self->_introspector;
my @params;
@@ -133,6 +228,7 @@ sub connect_to_signal {
$self->{object_path});
}
+
sub DESTROY {
# No op merely to stop AutoLoader trying to
# call DESTROY on remote object
@@ -141,11 +237,24 @@ sub DESTROY {
sub AUTOLOAD {
my $self = shift;
my $sub = $AUTOLOAD;
-
+
(my $name = $AUTOLOAD) =~ s/.*:://;
+
+ # Use a long timeout if the service is not online,
+ # because some services take a long time to startup.
+ # With a 5 second timeout, we'd time out before the
+ # service was fully activated.
+ # Also use a long timeout on the GetNameOwner and
+ # StartServiceByName methods since they trigger
+ # the activation process
+ my $timeout = !$self->get_service->is_online ||
+ ($self->get_service->get_service_name eq "org.freedesktop.DBus" &&
+ $self->get_object_path eq "/org/freedesktop/DBus" &&
+ ($name eq "GetNameOwner" ||
+ $name eq "StartServiceByName")) ? 60 : 5;
my $interface = $self->{interface};
- my $ins = $self->_introspector;
+ my $ins = $self->_introspector($timeout);
if ($ins) {
my @interfaces = $ins->has_method($name);
@@ -155,7 +264,7 @@ sub AUTOLOAD {
"in multiple interfaces of '" . $self->get_object_path . "'" .
"calling first interface only\n";
}
- return $self->_call_method($name, $interfaces[0], @_);
+ return $self->_call_method($name, $interfaces[0], $timeout, @_);
}
@interfaces = $ins->has_property($name);
@@ -166,10 +275,10 @@ sub AUTOLOAD {
"calling first interface only\n";
}
if (@_) {
- $self->_call_method("Set", "org.freedesktop.DBus.Properties", $interfaces[0], $name, $_[0]);
+ $self->_call_method("Set", "org.freedesktop.DBus.Properties", $timeout, $interfaces[0], $name, $_[0]);
return ();
} else {
- return $self->_call_method("Get", "org.freedesktop.DBus.Properties", $interfaces[0], $name);
+ return $self->_call_method("Get", "org.freedesktop.DBus.Properties", $timeout, $interfaces[0], $name);
}
}
die "no method or property with name '$name' is exported in object '" .
@@ -180,7 +289,7 @@ sub AUTOLOAD {
"', and object is not cast to any interface";
}
- return $self->_call_method($name, $interface, @_);
+ return $self->_call_method($name, $interface, $timeout, @_);
}
}
@@ -189,6 +298,9 @@ sub _call_method {
my $self = shift;
my $name = shift;
my $interface = shift;
+ my $timeout = shift;
+
+ warn "Do $name $interface $timeout\n";
my $call = Net::DBus::Binding::Message::MethodCall->
new(service_name => $self->{service}->get_service_name(),
@@ -206,7 +318,7 @@ sub _call_method {
my $reply = $self->{service}->
get_bus()->
get_connection()->
- send_with_reply_and_block($call, 5000);
+ send_with_reply_and_block($call, $timeout * 1000);
my @reply;
if ($ins) {
@@ -217,8 +329,23 @@ sub _call_method {
return wantarray ? @reply : $reply[0];
}
-sub _read_prop {
-}
1;
+=pod
+
+=back
+
+=head1 AUTHOR
+
+Daniel Berrange <dan at berrange.com>
+
+=head1 COPYRIGHT
+
+Copright (C) 2004-2005, Daniel Berrange.
+
+=head1 SEE ALSO
+
+L<Net::DBus::RemoteService>, L<Net::DBus::Object>
+
+=cut
--
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