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 <d...@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 <d...@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

_______________________________________________
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