home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / lib / perl5 / Net / DBus / Test / MockObject.pm < prev   
Encoding:
Perl POD Document  |  2006-02-19  |  8.6 KB  |  317 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: MockObject.pm,v 1.5 2006/02/03 13:30:14 dan Exp $
  20.  
  21. =pod
  22.  
  23. =head1 NAME
  24.  
  25. Net::DBus::Test::MockObject - Fake an object from the bus for unit testing
  26.  
  27. =head1 SYNOPSIS
  28.  
  29.   use Net::DBus;
  30.   use Net::DBus::Test::MockObject;
  31.  
  32.   my $bus = Net::DBus->test
  33.  
  34.   # Lets fake presence of HAL...
  35.  
  36.   # First we need to define the service 
  37.   my $service = $bus->export_service("org.freedesktop.Hal");
  38.  
  39.   # Then create a mock object
  40.   my $object = Net::DBus::Test::MockObject->new($service,
  41.                                                 "/org/freedesktop/Hal/Manager");
  42.  
  43.   # Fake the 'GetAllDevices' method
  44.   $object->seed_action("org.freedesktop.Hal.Manager", 
  45.                        "GetAllDevices",
  46.                        reply => {
  47.                          return => [ "/org/freedesktop/Hal/devices/computer_i8042_Aux_Port",
  48.                                      "/org/freedesktop/Hal/devices/computer_i8042_Aux_Port_logicaldev_input",
  49.                                      "/org/freedesktop/Hal/devices/computer_i8042_Kbd_Port",
  50.                                      "/org/freedesktop/Hal/devices/computer_i8042_Kbd_Port_logicaldev_input"
  51.                          ],
  52.                        });
  53.  
  54.  
  55.   # Now can test any class which calls out to 'GetAllDevices' in HAL
  56.   ....test stuff....
  57.  
  58. =head1 DESCRIPTION
  59.  
  60. This provides an alternate for L<Net::DBus::Object> to enable bus 
  61. objects to be quickly mocked up, thus facilitating creation of unit 
  62. tests for services which may need to call out to objects provided
  63. by 3rd party services on the bus. It is typically used as a companion
  64. to the L<Net::DBus::MockBus> object, to enable complex services to
  65. be tested without actually starting a real bus.
  66.  
  67. !!!!! WARNING !!!
  68.  
  69. This object & its APIs should be considered very experimental at
  70. this point in time, and no guarentees about future API compatability
  71. are provided what-so-ever. Comments & suggestions on how to evolve
  72. this framework are, however, welcome & encouraged.
  73.  
  74. =head1 METHODS
  75.  
  76. =over 4
  77.  
  78. =cut
  79.  
  80. package Net::DBus::Test::MockObject;
  81.  
  82. use strict;
  83. use warnings;
  84.  
  85. use Net::DBus::Binding::Message::MethodReturn;
  86. use Net::DBus::Binding::Message::Error;
  87.  
  88. =item my $object = Net::DBus::Test::MockObject->new($service, $path, $interface);
  89.  
  90. Create a new mock object, attaching to the service defined by the C<$service>
  91. parameter. This would be an instance of the L<Net::DBus::Service> object. The
  92. C<$path> parameter defines the object path at which to attach this mock object,
  93. and C<$interface> defines the interface it will support.
  94.  
  95. =cut
  96.  
  97. sub new {
  98.     my $class = shift;
  99.     my $self = {};
  100.  
  101.     $self->{service} = shift;
  102.     $self->{object_path} = shift;
  103.     $self->{interface} = shift;
  104.     $self->{actions} = {};
  105.     $self->{message} = shift;
  106.  
  107.     bless $self, $class;
  108.    
  109.     $self->get_service->_register_object($self);
  110.  
  111.     return $self;
  112. }
  113.  
  114.  
  115. =item my $service = $object->get_service
  116.  
  117. Retrieves the L<Net::DBus::Service> object within which this
  118. object is exported.
  119.  
  120. =cut
  121.  
  122. sub get_service {
  123.     my $self = shift;
  124.     return $self->{service};
  125. }
  126.  
  127. =item my $path = $object->get_object_path
  128.  
  129. Retrieves the path under which this object is exported
  130.  
  131. =cut
  132.  
  133. sub get_object_path {
  134.     my $self = shift;
  135.     return $self->{object_path};
  136. }
  137.  
  138.  
  139. =item my $msg = $object->get_last_message
  140.  
  141. Retrieves the last message processed by this object. The returned
  142. object is an instance of L<Net::DBus::Binding::Message>
  143.  
  144. =cut
  145.  
  146. sub get_last_message {
  147.     my $self = shift;
  148.     return $self->{message};
  149. }
  150.  
  151. =item my $sig = $object->get_last_message_signature
  152.  
  153. Retrieves the type signature of the last processed message.
  154.  
  155. =cut
  156.  
  157. sub get_last_message_signature {
  158.     my $self = shift;
  159.     return $self->{message}->get_signature;
  160. }
  161.  
  162. =item my $value = $object->get_last_message_param
  163.  
  164. Returns the first value supplied as an argument to the last
  165. processed message.
  166.  
  167. =cut
  168.  
  169. sub get_last_message_param {
  170.     my $self = shift;
  171.     my @args = $self->{message}->get_args_list;
  172.     return $args[0];
  173. }
  174.  
  175. =item my @values = $object->get_last_message_param_list
  176.  
  177. Returns a list of all the values supplied as arguments to 
  178. the last processed message.
  179.  
  180. =cut
  181.  
  182. sub get_last_message_param_list {
  183.     my $self = shift;
  184.     my @args = $self->{message}->get_args_list;
  185.     return \@args;
  186. }
  187.  
  188. =item $object->seed_action($interface, $method, %action);
  189.  
  190. Registers an action to be performed when a message corresponding
  191. to the method C<$method> within the interface C<$interface> is
  192. received. The C<%action> parameter can have a number of possible
  193. keys set:
  194.  
  195. =over 4
  196.  
  197. =item signals
  198.  
  199. Causes a signal to be emitted when the method is invoked. The 
  200. value associated with this key should be an instance of the
  201. L<Net::DBus::Binding::Message::Signal> class.
  202.  
  203. =item error
  204.  
  205. Causes an error to be generated when the method is invoked. The
  206. value associated with this key should be a hash reference, with
  207. two elements. The first, C<name>, giving the error name, and the
  208. second, C<description>, providing the descriptive text.
  209.  
  210. =item reply
  211.  
  212. Causes a normal method return to be generated. The value associated
  213. with this key should be an array reference, whose elements are the
  214. values to be returned by the method.
  215.  
  216. =back
  217.  
  218. =cut
  219.  
  220. sub seed_action {
  221.     my $self = shift;
  222.     my $interface = shift;
  223.     my $method = shift;
  224.     my %action = @_;
  225.     
  226.     $self->{actions}->{$method} = {} unless exists $self->{actions}->{$method};
  227.     $self->{actions}->{$method}->{$interface} = \%action;
  228. }
  229.  
  230. sub _dispatch {
  231.     my $self = shift;
  232.     my $connection = shift;
  233.     my $message = shift;
  234.     
  235.     my $interface = $message->get_interface;
  236.     my $method = $message->get_member;
  237.  
  238.     if (!exists $self->{actions}->{$method}) {
  239.     my $error = Net::DBus::Binding::Message::Error->new(replyto => $message,
  240.                                 name => "org.freedesktop.DBus.Failed",
  241.                                 description => "no action seeded for method " . $message->get_member);
  242.     $self->get_service->get_bus->get_connection->send($error);
  243.     return;
  244.     }
  245.     
  246.     my $action;
  247.     if ($interface) {
  248.     if (!exists $self->{actions}->{$method}->{$interface}) {
  249.         my $error = Net::DBus::Binding::Message::Error->new(replyto => $message,
  250.                                 name => "org.freedesktop.DBus.Failed",
  251.                                 description => "no action with correct interface seeded for method " . $message->get_member);
  252.         $self->get_service->get_bus->get_connection->send($error);
  253.         return;
  254.     }
  255.     $action = $self->{actions}->{$method}->{$interface};
  256.     } else {
  257.     my @interfaces = keys %{$self->{actions}->{$method}};
  258.     if ($#interfaces > 0) {
  259.         my $error = Net::DBus::Binding::Message::Error->new(replyto => $message,
  260.                                 name => "org.freedesktop.DBus.Failed",
  261.                                 description => "too many actions seeded for method " . $message->get_member);
  262.         $self->get_service->get_bus->get_connection->send($error);
  263.         return;
  264.     }
  265.     $action = $self->{actions}->{$method}->{$interfaces[0]};
  266.     }
  267.  
  268.     if (exists $action->{signals}) {
  269.     my $sigs = $action->{signals};
  270.     if (ref($sigs) ne "ARRAY") {
  271.         $sigs = [ $sigs ];
  272.     }
  273.     foreach my $sig (@{$sigs}) {
  274.         $self->get_service->get_bus->get_connection->send($sig);
  275.     }
  276.     }
  277.  
  278.     $self->{message} = $message;
  279.     
  280.     if (exists $action->{error}) {
  281.     my $error = Net::DBus::Binding::Message::Error->new(replyto => $message,
  282.                                 name => $action->{error}->{name},
  283.                                 description => $action->{error}->{description});
  284.     $self->get_service->get_bus->get_connection->send($error);
  285.     } elsif (exists $action->{reply}) {
  286.     my $reply = Net::DBus::Binding::Message::MethodReturn->new(call => $message);
  287.     my $iter = $reply->iterator(1);
  288.     foreach my $value (@{$action->{reply}->{return}}) {
  289.         $iter->append($value);
  290.     }
  291.     $self->get_service->get_bus->get_connection->send($reply);
  292.     }
  293. }
  294.  
  295.  
  296. 1;
  297.  
  298. =pod
  299.  
  300. =back
  301.  
  302. =head1 BUGS
  303.  
  304. It doesn't completely replicate the API of L<Net::DBus::Binding::Object>, 
  305. merely enough to make the high level bindings work in a test scenario.
  306.  
  307. =head1 SEE ALSO
  308.  
  309. L<Net::DBus>, L<Net::DBus::Object>, L<Net::DBus::Test::MockConnection>,
  310. L<http://www.mockobjects.com/Faq.html>
  311.  
  312. =head1 COPYRIGHT
  313.  
  314. Copyright 2005 Daniel Berrange <dan@berrange.com>
  315.  
  316. =cut
  317.