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 <[email protected]> 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 <[email protected]> + +=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 _______________________________________________ Pkg-perl-cvs-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
