local-lib5/lib/perl5/Test/MockObject/Extends.pm

   1 package Test::MockObject::Extends;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::MockObject;
   7
   8 use Devel::Peek  'CvGV';
   9 use Scalar::Util 'blessed';
  10
  11 use vars qw( $VERSION $AUTOLOAD );
  12 $VERSION = '1.09';
  13
  14 sub new
  15 {
  16     my ($class, $fake_class) = @_;
  17
  18     return Test::MockObject->new() unless defined $fake_class;
  19
  20     my $parent_class = $class->get_class( $fake_class );
  21     $class->check_class_loaded( $parent_class );
  22     my $self         = blessed( $fake_class ) ? $fake_class : {};
  23
  24     bless $self, $class->gen_package( $parent_class );
  25 }
  26
  27 sub check_class_loaded
  28 {
  29     my ($self, $parent_class) = @_;
  30     my $result                = Test::MockObject->check_class_loaded(
  31         $parent_class
  32     );
  33     return $result if $result;
  34
  35     (my $load_class  = $parent_class) =~ s/::/\//g;
  36     require $load_class . '.pm';
  37 }
  38
  39 sub get_class
  40 {
  41     my ($self, $invocant) = @_;
  42
  43     return $invocant unless blessed $invocant;
  44     return ref $invocant;
  45 }
  46
  47 my $packname = 'a';
  48
  49 sub gen_package
  50 {
  51     my ($class, $parent)         = @_;
  52     my $package                  = 'T::MO::E::' . $packname++;
  53
  54     no strict 'refs';
  55     *{ $package . '::mock'          } = \&mock;
  56     *{ $package . '::unmock'        } = \&unmock;
  57     @{ $package . '::ISA'           } = ( $parent );
  58     *{ $package . '::can'           } = $class->gen_can( $parent );
  59     *{ $package . '::isa'           } = $class->gen_isa( $parent );
  60     *{ $package . '::AUTOLOAD'      } = $class->gen_autoload( $parent );
  61     *{ $package . '::__get_parents' } = $class->gen_get_parents( $parent );
  62
  63     return $package;
  64 }
  65
  66 sub gen_get_parents
  67 {
  68     my ($self, $parent) = @_;
  69     return sub
  70     {
  71         no strict 'refs';
  72         return @{ $parent . '::ISA' };
  73     };
  74 }
  75
  76 sub gen_isa
  77 {
  78     my ($class, $parent)    = @_;
  79
  80     sub
  81     {
  82         local *__ANON__    = 'isa';
  83         my ($self, $class) = @_;
  84         return 1 if $class eq $parent;
  85         my $isa = $parent->can( 'isa' );
  86         return $isa->( $self, $class );
  87     };
  88 }
  89
  90 sub gen_can
  91 {
  92     my ($class, $parent) = @_;
  93
  94     sub
  95     {
  96         local *__ANON__     = 'can';
  97         my ($self, $method) = @_;
  98         my $parent_method   = $self->SUPER::can( $method );
  99         return $parent_method if $parent_method;
 100         return Test::MockObject->can( $method );
 101     };
 102 }
 103
 104 sub gen_autoload
 105 {
 106     my ($class, $parent) = @_;
 107
 108     sub
 109     {
 110         my $method = substr( $AUTOLOAD, rindex( $AUTOLOAD, ':' ) +1 );
 111         return if $method eq 'DESTROY';
 112
 113         my $self   = shift;
 114
 115         if (my $parent_method  = $parent->can( $method ))
 116         {
 117             return $self->$parent_method( @_ );
 118         }
 119         elsif (my $mock_method = Test::MockObject->can( $method ))
 120         {
 121             return $self->$mock_method( @_ );
 122         }
 123         elsif (my $parent_al = $parent->can( 'AUTOLOAD' ))
 124         {
 125             my ($parent_pack) = CvGV( $parent_al ) =~ /\*(.*)::AUTOLOAD/;
 126             {
 127                 no strict 'refs';
 128                 ${ "${parent_pack}::AUTOLOAD" } = "${parent}::${method}";
 129             }
 130             unshift @_, $self;
 131             goto &$parent_al;
 132         }
 133         else
 134         {
 135             die "Undefined method $method at ", join( ' ', caller() ), "\n";
 136         }
 137     };
 138 }
 139
 140 sub mock
 141 {
 142     my ($self, $name, $sub) = @_;
 143
 144     Test::MockObject::_set_log( $self, $name, ( $name =~ s/^-// ? 0 : 1 ) );
 145
 146     my $mock_sub = sub
 147     {
 148         my ($self) = @_;
 149         $self->log_call( $name, @_ );
 150         $sub->( @_ );
 151     };
 152
 153     {
 154         no strict 'refs';
 155         no warnings 'redefine';
 156         *{ ref( $self ) . '::' . $name } = $mock_sub;
 157     }
 158
 159     return $self;
 160 }
 161
 162 sub unmock
 163 {
 164     my ($self, $name) = @_;
 165
 166     Test::MockObject::_set_log( $self, $name, 0 );
 167     no strict 'refs';
 168     my $glob = *{ ref( $self ) . '::' };
 169     delete $glob->{ $name };
 170     return $self;
 171 }
 172
 173 1;
 174 __END__
 175
 176 =head1 NAME
 177
 178 Test::MockObject::Extends - mock part of an object or class
 179
 180 =head1 SYNOPSIS
 181
 182   use Some::Class;
 183   use Test::MockObject::Extends;
 184
 185   # create an object to mock
 186   my $object      = Some::Class->new();
 187
 188   # wrap that same object with a mocking wrapper
 189   $object         = Test::MockObject::Extends->new( $object );
 190
 191   # now chain mock and control calls
 192   $object->set_true( 'parent_method' )
 193          ->set_always( -grandparent_method => 1 )
 194          ->clear();
 195
 196 =head1 DESCRIPTION
 197
 198 Test::MockObject::Extends lets you mock one or more methods of an existing
 199 object or class.  This can be very handy when you're testing a well-factored
 200 module that does almost exactly what you want.  Wouldn't it be handy to take
 201 control of a method or two to make sure you receive testable results?  Now you
 202 can.
 203
 204 =head1 METHODS
 205
 206 =over 4
 207
 208 =item C<new( $object | $class )>
 209
 210 C<new()> takes one optional argument, the object or class to mock.  If you're
 211 mocking a method for an object that holds internal state, create an appropriate
 212 object, then pass it to this constructor.  B<NOTE:> this will modify the object
 213 in place.
 214
 215 If you're mocking an object that does not need state, as in the cases where
 216 there's no internal data or you'll only be calling class methods, or where
 217 you'll be mocking all of the access to internal data, you can pass in the name
 218 of the class to mock partially.
 219
 220 If you've not yet loaded the class, this method will try to load it for you.
 221 This may fail, so beware.
 222
 223 If you pass no arguments, it will assume you really meant to create a normal
 224 C<Test::MockObject> object and will oblige you.
 225
 226 Note that if you pass a class, the object returned will appear to be an
 227 instance of that class; I<this does not mock the class itself>.
 228
 229 =item C<mock( $methodname, $sub_ref )>
 230
 231 See the documentation for Test::MockObject for all of the ways to mock methods
 232 and to retrieve method logging information.  These methods return the invocant,
 233 so you can chain them.
 234
 235 =item C<unmock( $methodname )>
 236
 237 Removes any active mocking of the named method.  This means any calls to that
 238 method will hit the method of that name in the class being mocked, if it
 239 exists.  This method returns the invocant, you can chain it.
 240
 241 =item C<isa( $class )>
 242
 243 As you'd expect from a mocked object, this will return true for the class it's
 244 mocking.
 245
 246 =back
 247
 248 =head1 INTERNAL METHODS
 249
 250 To do its magic, this module uses several internal methods:
 251
 252 =over 4
 253
 254 =item * C<check_class_loaded( $parent_class )>
 255
 256 This verifies that you have the mockee defined.  If not, it attempts to load
 257 the corresponding module for you.
 258
 259 =item * C<gen_autoload( $extended )>
 260
 261 Returns an AUTOLOAD subroutine for the mock object that checks that the
 262 extended object (or class) can perform the requested method, that
 263 L<Test::MockObject> can perform it, or that the parent has an appropriate
 264 AUTOLOAD of its own.  (It should have its own C<can()> in that case too
 265 though.)
 266
 267 =item * C<gen_can( $extended )>
 268
 269 Returns a C<can()> method for the mock object that respects the same execution
 270 order as C<gen_autoload()>.
 271
 272 =item * C<gen_isa( $extended )>
 273
 274 Returns an C<isa()> method for the mock object that claims to be the
 275 C<$extended> object appropriately.
 276
 277 =item * C<gen_get_parents( $extended )>
 278
 279 Returns a C<__get_parents()> method for the mock object that claims to be the
 280 C<$extended> object appropriately.
 281
 282 =item * C<gen_package( $extended )>
 283
 284 Creates a new unique package for the mock object with the appropriate methods
 285 already installed.
 286
 287 =item * C<get_class( $invocant )>
 288
 289 Returns the class name of the invocant, whether it's an object or a class name.
 290
 291 =back
 292
 293 =head1 CAVEATS
 294
 295 There may be some weird corner cases with dynamically generated methods in the
 296 mocked class.  You really should use subroutine declarations though, or at
 297 least set C<can()> appropriately.
 298
 299 There are also potential name collisions with methods in this module or
 300 C<Test::MockObject>, though this should be rare.
 301
 302 =head1 AUTHOR
 303
 304 chromatic, E<lt>chromatic at wgz dot orgE<gt>
 305
 306 Documentation bug fixed by Stevan Little.  Additional AUTOLOAD approach
 307 suggested by Adam Kennedy.  Other bugs reported by Paul the Nomad and Praveen
 308 Ray.  Thank you all!
 309
 310 =head1 BUGS
 311
 312 No known bugs.
 313
 314 =head1 COPYRIGHT
 315
 316 Copyright (c) 2004 - 2008, chromatic.  All rights reserved.  You may use,
 317 modify, and distribute this module under the same terms as Perl 5.10