1 package Test::MockObject;
6 use vars qw( $VERSION $AUTOLOAD );
9 use Scalar::Util qw( blessed refaddr reftype weaken );
15 my $Test = Test::Builder->new();
20 my ($class, $type) = @_;
27 my ($self, $name, $sub) = @_;
30 # leading dash means unlog, otherwise do log
31 _set_log( $self, $name, ( $name =~ s/^-// ? 0 : 1 ) );
32 _subs( $self )->{$name} = $sub;
39 my ($self, @supers) = @_;
40 my $supers = _isas( $self );
41 $supers->{$_} = 1 for @supers;
46 my ($self, $name, $value) = @_;
47 $self->mock( $name, sub { $value } );
56 $self->mock( $name, sub { 1 } );
68 $self->mock( $name, sub {} );
76 my ($self, $name, @list) = @_;
77 $self->mock( $name, sub { @{[ @list ]} } );
82 my ($self, $name, @list) = @_;
83 $self->mock( $name, sub { return unless @list; shift @list } );
88 my ($self, $name, $ref) = @_;
92 SCALAR => sub { $$ref },
93 ARRAY => sub { @$ref },
94 HASH => sub { %$ref },
97 return unless exists $bindings{reftype( $ref )};
98 $self->mock( $name, $bindings{reftype( $ref )} );
101 # hack around debugging mode being too smart for my sub names
112 ( { sub => \&_subs, name => 'can' }, { sub => \&_isas, name => 'isa' } )
116 my ($self, $sub) = @_;
117 local *__ANON__ = $universal->{name};
119 # mockmethods are special cases, class methods are handled directly
120 my $lookup = $universal->{sub}->( $self );
121 return $lookup->{$sub} if blessed $self and exists $lookup->{$sub};
122 my $parent = 'SUPER::' . $universal->{name};
123 return $self->$parent( $sub );
127 *{ $universal->{name} } = $sub;
135 my ($self, $sub) = @_;
136 delete _subs( $self )->{$sub};
142 my ($self, $sub) = @_;
144 for my $called (reverse @{ _calls( $self ) })
146 return 1 if $called->[0] eq $sub;
155 @{ _calls( $self ) } = ();
161 $_[0]->_call($_[1], 0);
166 return @{ $_[0]->_call($_[1], 1) };
171 my ($self, $pos, $type) = @_;
172 my $calls = _calls( $self );
173 return if abs($pos) > @$calls;
175 return $calls->[$pos][$type];
180 my $args = $_[0]->_call( $_[1], 1 ) or return;
181 return join($_[2] || '', @$args);
186 my ($self, $subpos, $argpos) = @_;
187 my $args = $self->_call( $subpos, 1 ) or return;
188 $argpos-- if $argpos > 0;
189 return $args->[$argpos];
194 my ($self, $num) = @_;
197 my $calls = _calls( $self );
198 return unless @$calls >= $num;
200 my ($call) = (splice(@$calls, 0, $num))[-1];
201 return wantarray() ? @$call : $call->[0];
210 ($sub) = $AUTOLOAD =~ /::(\w+)\z/;
212 return if $sub eq 'DESTROY';
214 $self->dispatch_mocked_method( $sub, @_ );
217 sub dispatch_mocked_method
220 my $sub = splice( @_, 1, 1 );
222 my $subs = _subs( $self );
223 if (exists $subs->{$sub})
225 $self->log_call( $sub, @_ );
226 goto &{ $subs->{$sub} };
231 Carp::carp("Un-mocked method '$sub()' called");
239 my ($self, $sub, @call_args) = @_;
240 return unless _logs( $self, $sub );
242 # prevent circular references with weaken
243 for my $arg ( @call_args )
245 next unless ref $arg;
246 weaken( $arg ) if refaddr( $arg ) eq refaddr( $self );
249 push @{ _calls( $self ) }, [ $sub, \@call_args ];
254 my ($self, $sub, $name) = @_;
255 $name ||= "object called '$sub'";
256 $Test->ok( $self->called($sub), $name );
261 my ($self, $pos, $sub, $name) = @_;
262 $name ||= "object called '$sub' at position $pos";
263 my $called = $self->call_pos($pos, $sub);
264 unless ($Test->ok( (defined $called and $called eq $sub), $name ))
266 $called = 'undef' unless defined $called;
267 $Test->diag("Got:\n\t'$called'\nExpected:\n\t'$sub'\n");
271 sub called_args_string_is
273 my ($self, $pos, $sep, $expected, $name) = @_;
274 $name ||= "object sent expected args to sub at position $pos";
275 $Test->is_eq( $self->call_args_string( $pos, $sep ), $expected, $name );
278 sub called_args_pos_is
280 my ($self, $pos, $argpos, $arg, $name) = @_;
281 $name ||= "object sent expected arg '$arg' to sub at position $pos";
282 $Test->is_eq( $self->call_args_pos( $pos, $argpos ), $arg, $name );
287 my ($class, $modname, %subs) = @_;
289 if ($class->check_class_loaded( $modname ) and ! keys %subs)
292 Carp::croak( "No mocked subs for loaded module '$modname'" );
295 $modname =~ s!::!/!g;
296 $INC{ $modname . '.pm' } = 1;
298 no warnings 'redefine';
301 ${ $modname . '::' }{VERSION} ||= -1;
304 for my $sub (keys %subs)
306 my $type = reftype( $subs{ $sub } ) || '';
307 unless ( $type eq 'CODE' )
310 Carp::carp("'$sub' is not a code reference" );
314 *{ $_[1] . '::' . $sub } = $subs{ $sub };
318 sub check_class_loaded
320 my ($self, $class, $load_flag) = @_;
322 (my $path = $class) =~ s{::}{/}g;
323 return 1 if exists $INC{ $path . '.pm' };
325 my $symtable = \%main::;
328 for my $symbol ( split( '::', $class ))
330 unless (exists $symtable->{ $symbol . '::' })
336 $symtable = $symtable->{ $symbol . '::' };
344 my ($self, $class) = @_;
345 $self->fake_module( $class, new => sub { $self } );
351 $self->_clear_calls();
352 $self->_clear_subs();
353 $self->_clear_logs();
354 $self->_clear_isas();
359 my $invocant = shift;
360 return blessed( $invocant ) ? refaddr( $invocant ) : $invocant;
368 $calls{ _get_key( shift ) } ||= [];
373 delete $calls{ _get_key( shift ) };
382 $subs{ _get_key( shift ) } ||= {};
387 delete $subs{ _get_key( shift ) };
396 my $key = _get_key( shift );
397 my ($name, $log) = @_;
403 $logs{$key}{$name} = 1;
407 delete $logs{$key}{$name};
413 my $key = _get_key( shift );
415 return exists $logs{$key}{$name};
420 delete $logs{ _get_key( shift ) };
429 $isas{ _get_key( shift ) } ||= {};
434 delete $isas{ _get_key( shift ) };
444 Test::MockObject - Perl extension for emulating troublesome interfaces
448 use Test::MockObject;
449 my $mock = Test::MockObject->new();
450 $mock->set_true( 'somemethod' );
451 ok( $mock->somemethod() );
453 $mock->set_true( 'veritas')
454 ->set_false( 'ficta' )
455 ->set_series( 'amicae', 'Sunny', 'Kylie', 'Bella' );
459 It's a simple program that doesn't use any other modules, and those are easy to
460 test. More often, testing a program completely means faking up input to
461 another module, trying to coax the right output from something you're not
462 supposed to be testing anyway.
464 Testing is a lot easier when you can control the entire environment. With
465 Test::MockObject, you can get a lot closer.
467 Test::MockObject allows you to create objects that conform to particular
468 interfaces with very little code. You don't have to reimplement the behavior,
469 just the input and the output.
471 =head2 IMPORTANT CAVEAT FOR TESTERS
473 Please note that it is possible to write highly detailed unit tests that pass
474 even when your integration tests may fail. Testing the pieces individually
475 does not excuse you from testing the whole thing together. I consider this to
478 In cases where you only need to mock one or two pieces of an existing module,
479 consider L<Test::MockObject::Extends> instead.
483 None by default. Maybe the Test::Builder accessories, in a future version.
487 The most important thing a Mock Object can do is to conform sufficiently to an
488 interface. For example, if you're testing something that relies on CGI.pm, you
489 may find it easier to create a mock object that returns controllable results
490 at given times than to fake query string input.
498 Creates a new mock object. By default, this is a blessed hash. Pass a
499 reference to bless that reference.
501 my $mock_array = Test::MockObject->new( [] );
502 my $mock_scalar = Test::MockObject->new( \( my $scalar ) );
503 my $mock_code = Test::MockObject->new( sub {} );
504 my $mock_glob = Test::MockObject->new( \*GLOB );
510 Your mock object is nearly useless if you don't tell it what it's mocking.
511 This is done by installing methods. You control the output of these mocked
512 methods. In addition, any mocked method is tracked. You can tell not only
513 what was called, but which arguments were passed. Please note that you cannot
514 track non-mocked method calls. They will still be allowed, though
515 Test::MockObject will carp() about them. This is considered a feature, though
516 it may be possible to disable this in the future.
518 As implied in the example above, it's possible to chain these calls together.
519 Thanks to a suggestion from the fabulous Piers Cawley (CPAN RT #1249), this
520 feature came about in version 0.09. Shorter testing code is nice!
524 =item * C<mock(I<name>, I<coderef>)>
526 Adds a coderef to the object. This allows code to call the named method on the
527 object. For example, this code:
529 my $mock = Test::MockObject->new();
530 $mock->mock( 'fluorinate',
531 sub { 'impurifying precious bodily fluids' } );
532 print $mock->fluorinate;
534 will print a helpful warning message. Please note that methods are only added
535 to a single object at a time and not the class. (There is no small similarity
536 to the Self programming language or the Class::Prototyped module.)
538 This method forms the basis for most of Test::MockObject's testing goodness.
540 B<Please Note:> this method used to be C<add()>. Due to its ambiguity, it now
541 has a different spelling. For backwards compatibility purposes, add() is
542 available, though version 0.07 deprecated it. It goes to some contortions to
543 try to do what you mean, but I make few guarantees.
545 =item * C<fake_module(I<module name>), [ I<subname> => I<coderef>, ... ]
547 B<Note:> this method will likely become a separate module in the near future.
549 Lies to Perl that it has already loaded a named module. This is handy when
550 providing a mockup of a real module if you'd like to prevent the actual module
551 from interfering with the nice fakery. If you're mocking L<Regexp::English>,
554 $mock->fake_module( 'Regexp::English' );
556 This is both a class and as an object method. Beware that this must take place
557 before the actual module has a chance to load. Either wrap it in a BEGIN block
558 before a use or require or place it before a C<use_ok()> or C<require_ok()>
561 You can optionally add functions to the mocked module by passing them as name
562 => coderef pairs to C<fake_module()>. This is handy if you want to test an
568 import => sub { $import = caller }
570 use_ok( 'Regexp::Esperanto' );
571 is( $import, 'Regexp::Esperanto',
572 'Regexp::Esperanto should use() Regexp::English' );
574 If you use C<fake_module()> to mock a module that already exists in memory --
575 one you've loaded elsewhere perhaps, but do not pass any subroutines to mock,
576 this method will throw an exception. This is because if you call the
577 constructor later on, you probably won't get a mock object back and you'll be
580 =item * C<fake_new(I<module name>)>
582 B<Note:> see L<Test::MockObject::Extends> for a better alternative to this
585 Provides a fake constructor for the given module that returns the invoking mock
586 object. Used in conjunction with C<fake_module()>, you can force the tested
587 unit to work with the mock object instead.
589 $mock->fake_module( 'CGI' );
590 $mock->fake_new( 'CGI' );
592 use_ok( 'Some::Module' );
593 my $s = Some::Module->new();
594 is( $s->{_cgi}, $mock,
595 'new() should create and store a new CGI object' );
597 =item * C<set_always(I<name>, I<value>)>
599 Adds a method of the specified name that always returns the specified value.
601 =item * C<set_true(I<name_1>, I<name_2>, ... I<name_n>)>
603 Adds a method of the specified name that always returns a true value. This can
604 take a list of names.
606 =item * C<set_false(I<name_1>, I<name_2>, ... I<name_n>)>
608 Adds a method of the specified name that always returns a false value. (Since
609 it installs an empty subroutine, the value should be false in both scalar and
610 list contexts.) This can take a list of names.
612 =item * C<set_list(I<name>, [ I<item1>, I<item2>, ... ]>
614 Adds a method that always returns a given list of values. It takes some care
615 to provide a list and not an array, if that's important to you.
617 =item * C<set_series(I<name>, [ I<item1>, I<item2>, ... ]>
619 Adds a method that will return the next item in a series on each call. This
620 can help to test error handling, by forcing a failure on the first method call
621 and then subsequent successes. Note that the series does not repeat; it will
624 =item * C<set_bound(I<name>, I<reference>)>
626 Adds a method bound to a variable. Pass in a reference to a variable in your
627 test. When you change the variable, the return value of the new method will
628 change as well. This is often handier than replacing mock methods.
630 =item * C<set_isa( I<name1>, I<name2>, ... I<namen> )>
632 Adds an apparent parent to the module, so that calling C<isa()> on the mock
633 will return true appropriately. Sometimes you really need this.
635 =item * C<remove(I<name>)>
637 Removes a named method.
641 =head3 Checking Your Mocks
645 =item * C<can( $method_name )>
647 Returns a subroutine reference if this particular mocked object can handle the
648 named method, false otherwise.
650 =item * C<isa( $class_name )>
652 Returns true if the invocant object mocks a particular class. You must have
653 used C<set_isa()> first.
655 =item * C<called(I<name>)>
657 Checks to see if something has called a named method on the object. This
658 returns a boolean value. The current implementation does not scale especially
659 well, so use this sparingly if you need to search through hundreds of calls.
663 Clears the internal record of all method calls on the object. It's handy to do
664 this every now and then. Note that this does not affect the mocked methods,
665 only all of the methods called on the object to this point.
667 It's handy to C<clear()> methods in between series of tests. That makes it
668 much easier to call C<next_method()> without having to skip over the calls from
669 the last set of tests.
671 =item * C<next_call([ I<position> ])>
673 Returns the name and argument list of the next mocked method called on an
674 object, in list context. In scalar context, returns only the method name.
675 There are two important things to know about this method. First, it starts at
676 the beginning of the call list. If your code runs like this:
678 $mock->set_true( 'foo' );
679 $mock->set_true( 'bar' );
680 $mock->set_true( 'baz' );
686 Then you might see output of:
688 my ($name, $args) = $mock->next_call();
689 print "$name (@$args)";
693 $name = $mock->next_call();
698 ($name, $args) = $mock->next_call();
699 print "$name (@$args)";
703 If you provide an optional number as the I<position> argument, the method will
704 skip that many calls, returning the data for the last one skipped.
710 $name = $mock->next_call();
715 $name = $mock->next_call( 2 );
720 When it reaches the end of the list, it returns undef. This is probably the
721 most convenient method in the whole module, but for the sake of completeness
722 and backwards compatibility (it takes me a while to reach the truest state of
723 laziness!), there are several other methods.
725 =item * C<call_pos(I<position>)>
727 Returns the name of the method called on the object at a specified position.
728 This is handy if you need to test a certain order of calls. For example:
730 Some::Function( $mock );
731 is( $mock->call_pos(1), 'setup',
732 'Function() should first call setup()' );
733 is( $mock->call_pos(-1), 'end',
734 '... and last call end()' );
736 Positions can be positive or negative. Please note that the first position is,
737 in fact, 1. (This may change in the future. I like it, but am willing to
740 =item * C<call_args(I<position>)>
742 Returns a list of the arguments provided to the method called at the appropriate
743 position. Following the test above, one might say:
745 is( ($mock->call_args(1))[0], $mock,
746 '... passing the object to setup()' );
747 is( scalar $mock->call_args(-1), 0,
748 '... and no args to end()' );
750 =item * C<call_args_pos(I<call position>, I<argument position>)>
752 Returns the argument at the specified position for the method call at the
753 specified position. One might rewrite the first test of the last example as:
755 is( $mock->call_args_pos(1, 1), $mock,
756 '... passing the object to setup()');
758 =item * C<call_args_string(I<position>, [ I<separator> ])>
760 Returns a stringified version of the arguments at the specified position. If
761 no separator is given, they will not be separated. This can be used as:
763 is( $mock->call_args_string(1), "$mock initialize",
764 '... passing object, initialize as arguments' );
766 =item * C<called_ok(I<method name>, [ I<test name> ])>
768 Tests to see whether a method of the specified name has been called on the
769 object. This and the following methods use Test::Builder, so they integrate
770 nicely with a test suite built around Test::Simple, Test::More, or anything
774 $mock->called_ok( 'foo' );
776 A generic default test name is provided.
778 =item * C<called_pos_ok(I<position>, I<method name>, [ I<test name> ])>
780 Tests to see whether the named method was called at the specified position. A
781 default test name is provided.
783 =item * C<called_args_pos_is(I<method position>, I<argument position>, I<expected>, [ I<test name> ])>
785 Tests to see whether the argument at the appropriate position of the method in
786 the specified position equals a specified value. A default, rather
787 non-descript test name is provided.
789 =item * C<called_args_string_is(I<method position>, I<separator>, I<expected>, [ I<test name> ])>
791 Joins together all of the arguments to a method at the appropriate position and
792 matches against a specified string. A generically bland test name is provided
793 by default. You can probably do much better.
795 =item * C<check_class_loaded( $class_name )>
797 Attempts to determine whether you have a class of the given name loaded and
798 compiled. Returns true or false.
804 Test::MockObject logs all mocked methods by default. Sometimes you don't want
805 to do this. To prevent logging all calls to a given method, prepend the name
806 of the method with C<-> when mocking it.
810 $mock->set_true( '-foo', 'bar' );
812 will set mock both C<foo()> and C<bar()>, causing both to return true.
813 However, the object will log only calls to C<bar()>, not C<foo()>. To log
814 C<foo()> again, merely mock it again without the leading C<->:
816 $mock->set_true( 'foo' );
818 C<$mock> will log all subsequent calls to C<foo()> again.
822 There are two methods provided for subclassing:
826 =item * C<dispatch_mocked_method( $method_name, @_ )>
828 This method determines how to call a method (named as C<$method_name>) not
829 available in this class. It also controls logging. You may or may not find it
830 useful, but I certainly take advantage of it for Test::MockObject::Extends.
832 =item * C<log_call( $method_name, @_ )>
834 This method tracks the call of the named method and its arguments.
842 =item * Add a factory method to avoid namespace collisions (soon)
844 =item * Add more useful methods (catch C<import()>?)
850 chromatic, E<lt>chromatic at wgz dot orgE<gt>
852 Thanks go to Curtis 'Ovid' Poe, as well as ONSITE! Technology, Inc., for
853 finding several bugs and providing several constructive suggestions.
855 Jay Bonci also found a false positive in C<called_ok()>. Thanks!
857 Chris Winters was the first to report I'd accidentally scheduled 0.12 for
858 deletion without uploading a newer version. He also gave useful feedback on
859 Test::MockObject::Extends.
861 Stevan Little provided the impetus and code for C<set_isa()>.
863 Nicholas Clark found a documentation error.
865 Mutant suggested a potential problem with fake_module().
869 L<perl>, L<Test::Tutorial>, L<Test::More>,
870 L<http:E<sol>E<sol>www.perl.comE<sol>pubE<sol>aE<sol>2001E<sol>12E<sol>04E<sol>testing.html>,
872 L<http:E<sol>E<sol>www.perl.comE<sol>pubE<sol>aE<sol>2002E<sol>07E<sol>10E<sol>tmo.html>.
876 Copyright (c) 2002 - 2008 by chromatic E<lt>chromatic at wgz dot orgE<gt>.
878 This program is free software; you can use, modify, and redistribute it under
879 the same terms as Perl 5.10.x itself.
881 See http://www.perl.com/perl/misc/Artistic.html