home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / lib / perl5 / Net / DBus / RemoteObject.pm < prev    next >
Encoding:
Perl POD Document  |  2006-06-03  |  11.6 KB  |  429 lines
  1. # -*- perl -*-
  2. #
  3. # Copyright (C) 2004-2005 Daniel P. Berrange
  4. #
  5. # This program is free software; you can redistribute it and/or modify
  6. # it under the terms of the GNU General Public License as published by
  7. # the Free Software Foundation; either version 2 of the License, or
  8. # (at your option) any later version.
  9. #
  10. # This program is distributed in the hope that it will be useful,
  11. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. # GNU General Public License for more details.
  14. #
  15. # You should have received a copy of the GNU General Public License
  16. # along with this program; if not, write to the Free Software
  17. # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18. #
  19. # $Id: RemoteObject.pm,v 1.20 2006/01/27 15:34:24 dan Exp $
  20.  
  21. =pod
  22.  
  23. =head1 NAME
  24.  
  25. Net::DBus::RemoteObject - Access objects provided on the bus
  26.  
  27. =head1 SYNOPSIS
  28.  
  29.   my $service = $bus->get_service("org.freedesktop.DBus");
  30.   my $object = $service->get_object("/org/freedesktop/DBus");
  31.  
  32.   print "Names on the bus {\n";
  33.   foreach my $name (sort $object->ListNames) {
  34.       print "  ", $name, "\n";
  35.   }
  36.   print "}\n";
  37.  
  38. =head1 DESCRIPTION
  39.  
  40. This module provides the API for accessing remote objects available
  41. on the bus. It uses the autoloader to fake the presence of methods
  42. based on the API of the remote object. There is also support for
  43. setting callbacks against signals, and accessing properties of the
  44. object.
  45.  
  46. =head1 METHODS
  47.  
  48. =over 4
  49.  
  50. =cut
  51.  
  52. package Net::DBus::RemoteObject;
  53.  
  54. use 5.006;
  55. use strict;
  56. use warnings;
  57. use Carp;
  58.  
  59. our $AUTOLOAD;
  60.  
  61. use Net::DBus::Binding::Message::MethodCall;
  62. use Net::DBus::Binding::Introspector;
  63. use Net::DBus::ASyncReply;
  64. use Net::DBus::Annotation qw(:call);
  65.  
  66.  
  67. =item my $object = Net::DBus::RemoteObject->new($service, $object_path[, $interface]);
  68.  
  69. Creates a new handle to a remote object. The C<$service> parameter is an instance
  70. of the L<Net::DBus::RemoteService> method, and C<$object_path> is the identifier of
  71. an object exported by this service, for example C</org/freedesktop/DBus>. For remote
  72. objects which implement more than one interface it is possible to specify an optional
  73. name of an interface as the third parameter. This is only really required, however, if
  74. two interfaces in the object provide methods with the same name, since introspection
  75. data can be used to automatically resolve the correct interface to call cases where
  76. method names are unique. Rather than using this constructor directly, it is preferrable
  77. to use the C<get_object> method on L<Net::DBus::RemoteService>, since this caches handles
  78. to remote objects, eliminating unneccessary introspection data lookups.
  79.  
  80. =cut
  81.  
  82.  
  83. sub new {
  84.     my $proto = shift;
  85.     my $class = ref($proto) || $proto;
  86.     my $self = {};
  87.  
  88.     $self->{service} = shift;
  89.     $self->{object_path}  = shift;
  90.     $self->{interface} = @_ ? shift : undef;
  91.     $self->{introspected} = 0;
  92.  
  93.     bless $self, $class;
  94.  
  95.     return $self;
  96. }
  97.  
  98. =item my $object = $object->as_interface($interface);
  99.  
  100. Casts the object to a specific interface, returning a new instance of the
  101. L<Net::DBus::RemoteObject> specialized to the desired interface. It is only
  102. neccessary to cast objects to a specific interface, if two interfaces
  103. export methods or signals with the same name, or the remote object does not
  104. support introspection.
  105.  
  106. =cut
  107.  
  108. sub as_interface {
  109.     my $self = shift;
  110.     my $interface = shift;
  111.  
  112.     die "already cast to " . $self->{interface} . "'"
  113.     if $self->{interface};
  114.  
  115.     return $self->new($self->{service},
  116.               $self->{object_path},
  117.               $interface);
  118. }
  119.  
  120. =item my $service = $object->get_service
  121.  
  122. Retrieves a handle for the remote service on which this object is
  123. attached. The returned object is an instance of L<Net::DBus::RemoteService>
  124.  
  125. =cut
  126.  
  127. sub get_service {
  128.     my $self = shift;
  129.     return $self->{service};
  130. }
  131.  
  132. =item my $path = $object->get_object_path
  133.  
  134. Retrieves the unique path identifier for this object within the
  135. service.
  136.  
  137. =cut
  138.  
  139. sub get_object_path {
  140.     my $self = shift;
  141.     return $self->{object_path};
  142. }
  143.  
  144. =item my $object = $object->get_child_object($subpath, [$interface])
  145.  
  146. Retrieves a handle to a child of this object, identified
  147. by the relative path C<$subpath>. The returned object
  148. is an instance of C<Net::DBus::RemoteObject>. The optional
  149. C<$interface> parameter can be used to immediately cast
  150. the object to a specific type.
  151.  
  152. =cut
  153.  
  154. sub get_child_object {
  155.     my $self = shift;
  156.     my $path = shift;
  157.     my $interface = @_ ? shift : undef;
  158.     my $fullpath = $self->{object_path} . $path;
  159.  
  160.     return $self->new($self->get_service,
  161.               $fullpath,
  162.               $interface);
  163. }
  164.  
  165. sub _introspector {
  166.     my $self = shift;
  167.  
  168.     unless ($self->{introspected}) {
  169.     my $call = Net::DBus::Binding::Message::MethodCall->
  170.         new(service_name => $self->{service}->get_service_name(),
  171.         object_path => $self->{object_path},
  172.         method_name => "Introspect",
  173.         interface => "org.freedesktop.DBus.Introspectable");
  174.  
  175.     my $xml = eval {
  176.         my $reply = $self->{service}->
  177.         get_bus()->
  178.         get_connection()->
  179.         send_with_reply_and_block($call, 60 * 1000);
  180.  
  181.         my $iter = $reply->iterator;
  182.         return $iter->get(&Net::DBus::Binding::Message::TYPE_STRING);
  183.     };
  184.     if ($@) {
  185.         if (UNIVERSAL::isa($@, "Net::DBus::Error") &&
  186.         $@->{name} eq "org.freedesktop.DBus.Error.ServiceUnknown") {
  187.         die $@;
  188.         } else {
  189.         # Ignore other failures, since its probably
  190.         # just that the object doesn't implement
  191.         # the introspect method. Of course without
  192.         # the introspect method we can't tell for sure
  193.         # if this is the case..
  194.         #warn "could not introspect object: $@";
  195.         }
  196.     }
  197.     if ($xml) {
  198.         $self->{introspector} = Net::DBus::Binding::Introspector->new(xml => $xml,
  199.                                       object_path => $self->{object_path});
  200.     }
  201.     $self->{introspected} = 1;
  202.     }
  203.     return $self->{introspector};
  204. }
  205.  
  206.  
  207. =item $object->connect_to_signal($name, $coderef);
  208.  
  209. Connects a callback to a signal emitted by the object. The C<$name>
  210. parameter is the name of the signal within the object, and C<$coderef>
  211. is a reference to an anonymous subroutine. When the signal C<$name>
  212. is emitted by the remote object, the subroutine C<$coderef> will be
  213. invoked, and passed the parameters from the signal.
  214.  
  215. =cut
  216.  
  217. sub connect_to_signal {
  218.     my $self = shift;
  219.     my $name = shift;
  220.     my $code = shift;
  221.  
  222.     my $ins = $self->_introspector;
  223.     my $interface = $self->{interface};
  224.     if (!$interface) {
  225.     if (!$ins) {
  226.         die "no introspection data available for '" . $self->get_object_path .
  227.         "', and object is not cast to any interface";
  228.     }
  229.     my @interfaces = $ins->has_signal($name);
  230.  
  231.     if ($#interfaces == -1) {
  232.         die "no signal with name '$name' is exported in object '" .
  233.         $self->get_object_path . "'\n";
  234.     } elsif ($#interfaces > 0) {
  235.         warn "signal with name '$name' is exported " .
  236.         "in multiple interfaces of '" . $self->get_object_path . "'" .
  237.         "connecting to first interface only\n";
  238.     }
  239.     $interface = $interfaces[0];
  240.     }
  241.  
  242.     if ($ins &&
  243.     $ins->has_signal($name, $interface) &&
  244.     $ins->is_signal_deprecated($name, $interface)) {
  245.     warn "signal $name in interface $interface on " . $self->get_object_path . " is deprecated";
  246.     }
  247.  
  248.     $self->get_service->
  249.     get_bus()->
  250.     _add_signal_receiver(sub {
  251.         my $signal = shift;
  252.         my $ins = $self->_introspector;
  253.         my @params;
  254.         if ($ins) {
  255.         @params = $ins->decode($signal, "signals", $signal->get_member, "params");
  256.         } else {
  257.         @params = $signal->get_args_list;
  258.         }
  259.         &$code(@params);
  260.     },
  261.                  $name,
  262.                  $interface,
  263.                  $self->{service}->get_owner_name(),
  264.                  $self->{object_path});
  265. }
  266.  
  267.  
  268. sub DESTROY {
  269.     # No op merely to stop AutoLoader trying to
  270.     # call DESTROY on remote object
  271. }
  272.  
  273. sub AUTOLOAD {
  274.     my $self = shift;
  275.     my $sub = $AUTOLOAD;
  276.  
  277.     my $mode = dbus_call_sync;
  278.     if (@_ && UNIVERSAL::isa($_[0], "Net::DBus::Annotation")) {
  279.     $mode = shift;
  280.     }
  281.  
  282.     (my $name = $AUTOLOAD) =~ s/.*:://;
  283.  
  284.     my $interface = $self->{interface};
  285.  
  286.     # If introspection data is available, use that
  287.     # to resolve correct interface (if object is not
  288.     # cast to an explicit interface already)
  289.     my $ins = $self->_introspector();
  290.     if ($ins) {
  291.     if ($interface) {
  292.         if ($ins->has_method($name, $interface)) {
  293.         return $self->_call_method($mode, $name, $interface, 1, @_);
  294.         }
  295.         if ($ins->has_property($name, $interface)) {
  296.         if ($ins->is_property_deprecated($name, $interface)) {
  297.             warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated";
  298.         }
  299.  
  300.         if (@_) {
  301.             $self->_call_method($mode, "Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
  302.             return ();
  303.         } else {
  304.             return $self->_call_method($mode, "Get", "org.freedesktop.DBus.Properties", $interface, 1, $name);
  305.         }
  306.         }
  307.     } else {
  308.         my @interfaces = $ins->has_method($name);
  309.  
  310.         if (@interfaces) {
  311.         if ($#interfaces > 0) {
  312.             die "method with name '$name' is exported " .
  313.             "in multiple interfaces of '" . $self->get_object_path . "'";
  314.         }
  315.         return $self->_call_method($mode, $name, $interfaces[0], 1, @_);
  316.         }
  317.         @interfaces = $ins->has_property($name);
  318.  
  319.         if (@interfaces) {
  320.         if ($#interfaces > 0) {
  321.             die "property with name '$name' is exported " .
  322.             "in multiple interfaces of '" . $self->get_object_path . "'";
  323.         }
  324.         $interface = $interfaces[0];
  325.         if ($ins->is_property_deprecated($name, $interface)) {
  326.             warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated";
  327.         }
  328.         if (@_) {
  329.             $self->_call_method($mode, "Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]);
  330.             return ();
  331.         } else {
  332.             return $self->_call_method($mode, "Get", "org.freedesktop.DBus.Properties", $interface, 1, $name);
  333.         }
  334.         }
  335.     }
  336.     }
  337.  
  338.     if (!$interface) {
  339.     die "no introspection data available for method '" . $name . "' in object '" .
  340.         $self->get_object_path . "', and object is not cast to any interface";
  341.     }
  342.  
  343.     return $self->_call_method($mode, $name, $interface, 0, @_);
  344. }
  345.  
  346.  
  347. sub _call_method {
  348.     my $self = shift;
  349.     my $mode = shift;
  350.     my $name = shift;
  351.     my $interface = shift;
  352.     my $introspect = shift;
  353.  
  354.     my $ins = $introspect ? $self->_introspector : undef;
  355.     if ($ins &&
  356.     $ins->is_method_deprecated($name, $interface)) {
  357.     warn "method '$name' in interface $interface on object " . $self->get_object_path . " is deprecated\n";
  358.     }
  359.  
  360.     my $call = Net::DBus::Binding::Message::MethodCall->
  361.     new(service_name => $self->{service}->get_service_name(),
  362.         object_path => $self->{object_path},
  363.         method_name => $name,
  364.         interface => $interface);
  365.  
  366.     #$call->set_destination($self->get_service->get_owner_name);
  367.  
  368.     if ($ins) {
  369.     $ins->encode($call, "methods", $name, "params", @_);
  370.     } else {
  371.     $call->append_args_list(@_);
  372.     }
  373.  
  374.     if ($mode == dbus_call_sync) {
  375.     my $reply = $self->{service}->
  376.         get_bus()->
  377.         get_connection()->
  378.         send_with_reply_and_block($call, 60 * 1000);
  379.  
  380.     my @reply;
  381.     if ($ins) {
  382.         @reply = $ins->decode($reply, "methods", $name, "returns");
  383.     } else {
  384.         @reply = $reply->get_args_list;
  385.     }
  386.  
  387.     return wantarray ? @reply : $reply[0];
  388.     } elsif ($mode == dbus_call_async) {
  389.     my $pending_call = $self->{service}->
  390.         get_bus()->
  391.         get_connection()->
  392.         send_with_reply($call, 60 * 1000);
  393.     my $reply = Net::DBus::ASyncReply->_new(pending_call => $pending_call,
  394.                         ($ins ? (introspector => $ins,
  395.                              method_name => $name)
  396.                          : ()));
  397.     return $reply;
  398.     } elsif ($mode == dbus_call_noreply) {
  399.     $call->set_no_reply(1);
  400.     $self->{service}->
  401.         get_bus()->
  402.         get_connection()->
  403.         send($call, 60 * 1000);
  404.     } else {
  405.     die "unsupported annotation '$mode'";
  406.     }
  407. }
  408.  
  409.  
  410. 1;
  411.  
  412. =pod
  413.  
  414. =back
  415.  
  416. =head1 AUTHOR
  417.  
  418. Daniel Berrange <dan@berrange.com>
  419.  
  420. =head1 COPYRIGHT
  421.  
  422. Copright (C) 2004-2005, Daniel Berrange.
  423.  
  424. =head1 SEE ALSO
  425.  
  426. L<Net::DBus::RemoteService>, L<Net::DBus::Object>
  427.  
  428. =cut
  429.