File Coverage

blib/lib/Test/Spec/Mocks.pm
Criterion Covered Total %
statement 301 328 91.7
branch 107 134 79.8
condition 26 52 50.0
subroutine 74 77 96.1
pod 4 4 100.0
total 512 595 86.0


line stmt bran cond sub pod time code
1             package Test::Spec::Mocks;
2 14     14   100 use strict;
  14         39  
  14         422  
3 14     14   75 use warnings;
  14         65  
  14         374  
4 14     14   78 use Carp ();
  14         27  
  14         193  
5 14     14   69 use Scalar::Util ();
  14         30  
  14         231  
6 14     14   3920 use Test::Deep::NoTest ();
  14         2219  
  14         1563  
7              
8             require Test::Spec;
9              
10             our @EXPORT_OK = qw(stubs stub expects mock);
11             our @EXPORT = @EXPORT_OK;
12              
13             our $Debug = $ENV{TEST_SPEC_MOCKS_DEBUG};
14              
15             our %To_Universal = map { $_ => 1 } qw(stubs expects);
16              
17             #
18             # use Test::Spec::Mocks (); # nothing (import never called)
19             # use Test::Spec::Mocks; # stubs,expects=>UNIVERSAL, stub,mock=>caller
20             # use Test::Spec::Mocks qw(stubs stub); # stubs=>UNIVERSAL, stub=>caller
21             #
22             sub import {
23 18     18   272 my $srcpkg = shift;
24 18         44 my $callpkg = caller(0);
25 18 100       84 my @syms = @_ ? @_ : @EXPORT;
26 18         48 SYMBOL: for my $orig_sym (@syms) {
27 14     14   88 no strict 'refs';
  14         32  
  14         37527  
28             # accept but ignore leading '&', we only export subs
29 67         136 (my $sym = $orig_sym) =~ s{\A\&}{};
30 67 50       161 if (not grep { $_ eq $sym } @EXPORT_OK) {
  268         563  
31 0         0 Carp::croak("\"$orig_sym\" is not exported by the $srcpkg module");
32             }
33 67 100       164 my $destpkg = $To_Universal{$sym} ? 'UNIVERSAL' : $callpkg;
34 67         138 my $src = join("::", $srcpkg, $sym);
35 67         123 my $dest = join("::", $destpkg, $sym);
36 67 50       278 if (defined &$dest) {
37 0 0       0 if (*{$dest}{CODE} == *{$src}{CODE}) {
  0         0  
  0         0  
38             # already exported, ignore request
39 0         0 next SYMBOL;
40             }
41             else {
42 0         0 Carp::carp("Clobbering existing \"$orig_sym\" in package $destpkg");
43             }
44             }
45 67         10763 *$dest = \&$src;
46             }
47             }
48              
49             # Foo->stubs("name") # empty return value
50             # Foo->stubs("name" => "value") # static return value
51             # Foo->stubs("name" => sub { "value" }) # dynamic return value
52              
53             sub stubs {
54 11     11 1 118 _install('Test::Spec::Mocks::Stub', @_);
55             }
56              
57             # Foo->expects("name") # empty return value
58             sub expects {
59 60 50 33 60 1 620 if (@_ != 2 || ref($_[1])) {
60 0         0 Carp::croak "usage: ->expects('foo')";
61             }
62 60         217 _install('Test::Spec::Mocks::Expectation', @_);
63             }
64              
65             sub _install {
66 71     71   128 my $stub_class = shift;
67 71         1011 my ($caller) = ((caller(1))[3] =~ /.*::(.*)/);
68              
69 71         194 my $target = shift;
70 71         116 my @methods;
71              
72             # normalize name/value pairs to name/subroutine pairs
73 71 100 66     836 if (@_ > 0 && @_ % 2 == 0) {
    100 66        
    50 33        
74             # list of name/value pairs
75 7         27 while (my ($name,$value) = splice(@_,0,2)) {
76 7         32 push @methods, { name => $name, value => $value };
77             }
78             }
79             elsif (@_ == 1 && ref($_[0]) eq 'HASH') {
80             # hash ref of name/value pairs
81 1         3 my $args = shift;
82 1         7 while (my ($name,$value) = each %$args) {
83 1         6 push @methods, { name => $name, value => $value };
84             }
85             }
86             elsif (@_ == 1 && !ref($_[0])) {
87             # name only
88 63         249 push @methods, { name => shift };
89             }
90             else {
91 0         0 Carp::croak "usage: $caller('foo'), $caller(foo=>'bar') or $caller({foo=>'bar'})";
92             }
93              
94 71   33     340 my $context = Test::Spec->current_context
95             || Carp::croak "Test::Spec::Mocks only works in conjunction with Test::Spec";
96 71         117 my $retval; # for chaining. last wins.
97              
98 71         149 for my $method (@methods) {
99 71         408 my $stub = $stub_class->new({ target => $target, method => $method->{name} });
100 71 100       284 $stub->returns($method->{value}) if exists $method->{value};
101 71     764   422 $context->on_enter(sub { $stub->setup });
  764         1516  
102 71     764   365 $context->on_leave(sub { $stub->teardown });
  764         1455  
103 71         175 $retval = $stub;
104             }
105              
106 71         324 return $retval;
107             }
108              
109             # $stub_object = stub();
110             # $stub_object = stub(method => 'result');
111             # $stub_object = stub(method => sub { 'result' });
112             sub stub {
113 29     29 1 138 my $args;
114 29 50 0     125 if (@_ % 2 == 0) {
    0          
115 29         81 $args = { @_ };
116             }
117             elsif (@_ == 1 && ref($_[0]) eq 'HASH') {
118 0         0 $args = shift;
119             }
120             else {
121 0         0 Carp::croak "usage: stub(%HASH) or stub(\\%HASH)";
122             }
123 29         76 my $blank = _make_mock();
124 29 100       80 $blank->stubs($args) if @_;
125 29         81 return $blank;
126             }
127              
128             # $mock_object = mock(); $mock_object->expects(...)
129             sub mock {
130 1 50   1 1 8 Carp::croak "usage: mock()" if @_;
131 1         4 return _make_mock();
132             }
133              
134             {
135             package Test::Spec::Mocks::MockObject;
136             # this page intentionally left blank
137             }
138              
139             # keep this out of the MockObject class, so it has a blank slate
140             sub _make_mock {
141 30     30   81 return bless({}, 'Test::Spec::Mocks::MockObject');
142             }
143              
144             {
145             package Test::Spec::Mocks::Expectation;
146              
147             sub new {
148 71     71   138 my $class = shift;
149 71         195 my $self = bless {}, $class;
150              
151             # expect to be called exactly one time in the default case
152 71         237 $self->once;
153              
154 71 50       153 if (@_) {
155 71         122 my $args = shift;
156 71 50 33     292 if (@_ || ref($args) ne 'HASH') {
157 0         0 Carp::croak "usage: $class->new(\\%args)";
158             }
159 71         306 while (my ($name,$val) = each (%$args)) {
160 142 100       353 if ($name eq 'target') {
    50          
161 71         117 $name = '_target';
162             }
163             elsif ($name eq 'method') {
164 71         107 $name = '_method';
165             }
166 142         370 $self->$name($val);
167             }
168             }
169              
170 71         138 return $self;
171             }
172              
173             sub _target {
174 1628     1628   2164 my $self = shift;
175 1628 100       2688 $self->{__target} = shift if @_;
176 1628         3561 return $self->{__target};
177             }
178              
179             sub _target_class {
180 1611     1611   2086 my $self = shift;
181 1611 100       3223 $self->{__target_class} = shift if @_;
182 1611         3759 return $self->{__target_class};
183             }
184              
185             sub _original_code {
186 3654     3654   4542 my $self = shift;
187 3654 100       7260 $self->{__original_code} = shift if @_;
188 3654         6837 return $self->{__original_code};
189             }
190              
191             sub _method {
192 2429     2429   3123 my $self = shift;
193 2429 100       4000 $self->{__method} = shift if @_;
194 2429         9572 return $self->{__method};
195             }
196              
197             sub _retval {
198 198     198   273 my $self = shift;
199 198 100       357 $self->{__retval} = shift if @_;
200 198   100 22   602 return $self->{__retval} ||= sub {};
201             }
202              
203             sub _canceled {
204 820     820   1127 my $self = shift;
205 820 100       1548 $self->{__canceled} = shift if @_;
206 820 100       1593 if (not exists $self->{__canceled}) {
207 15         26 $self->{__canceled} = 0;
208             }
209 820         2229 return $self->{__canceled};
210             }
211              
212             sub cancel {
213 56     56   262 my $self = shift;
214 56         155 $self->_canceled(1);
215 56         201 return;
216             }
217              
218             sub _call_count {
219 284     284   379 my $self = shift;
220 284 100       606 if (not defined $self->{__call_count}) {
221 69         158 $self->{__call_count} = 0;
222             }
223 284         825 return $self->{__call_count};
224             }
225              
226             sub _called {
227 155     155   221 my $self = shift;
228 155         248 my @args = @_;
229 155         392 $self->_given_args(\@args);
230 155         301 $self->{__call_count} = $self->_call_count + 1;
231             }
232              
233             sub _check_call_count {
234 199     199   288 my $self = shift;
235 199 100       540 $self->{__check_call_count} = shift if @_;
236 199         353 return $self->{__check_call_count};
237             }
238              
239             # sets _retval to a subroutine that returns the desired value, which
240             # lets us allow users to pass their own subroutines as well as
241             # immediate values.
242             sub returns {
243 44     44   80 my $self = shift;
244 44 100 66     253 if (@_ == 1 && ref($_[0]) eq 'CODE') {
    50          
245             # no boxing necessary
246 7         19 $self->_retval(shift);
247             }
248             elsif (@_ == 1) {
249 37         58 my $val = shift;
250             $self->_retval(sub {
251 123     123   253 return $val;
252 37         167 });
253             }
254             else {
255 0         0 my @list = @_;
256             $self->_retval(sub {
257 0     0   0 return @list;
258 0         0 });
259             }
260 44         108 return $self;
261             }
262              
263             #
264             # ARGUMENT MATCHING
265             #
266              
267             sub with {
268 12     12   75 my $self = shift;
269 12         37 return $self->with_eq(@_);
270             }
271              
272             sub with_eq {
273 12     12   27 my $self = shift;
274 12         46 $self->_eq_args(\@_);
275 12         28 return $self;
276             }
277              
278             sub with_deep {
279 14     14   128 my $self = shift;
280 14         70 $self->_deep_args(\@_);
281 14         37 return $self;
282             }
283              
284             sub _eq_args {
285 123     123   195 my $self = shift;
286 123 100       270 $self->{__eq_args} = shift if @_;
287 123   100     623 return $self->{__eq_args} ||= undef;
288             }
289              
290             sub _deep_args {
291 112     112   170 my $self = shift;
292 112 100       247 $self->{__deep_args} = shift if @_;
293 112   100     487 return $self->{__deep_args} ||= undef;
294             }
295              
296             sub _given_args {
297 195     195   251 my $self = shift;
298 195 100       448 $self->{__given_args} = shift if @_;
299 195   50     474 return $self->{__given_args} ||= undef;
300             }
301              
302             sub _check_eq_args {
303 86     86   141 my $self = shift;
304 86 100       225 return unless defined $self->_eq_args;
305 12 100       64 return unless $self->_call_count;
306              
307 10 100 66     25 if (!defined $self->_given_args || scalar(@{$self->_eq_args}) != scalar(@{$self->_given_args})) {
  10         18  
  10         20  
308 3         11 return "Number of arguments don't match expectation";
309             }
310 7         16 my @problems = ();
311 7         10 for my $i (0..$#{$self->_eq_args}) {
  7         14  
312 8         19 my $a = $self->_eq_args->[$i];
313 8         21 my $b = $self->_given_args->[$i];
314 8 100       25 unless ($self->_match_arguments($a, $b)) {
315 3 50       8 $a = 'undef' unless defined $a;
316 3 50       9 $b = 'undef' unless defined $b;
317 3         29 push @problems, sprintf("Expected argument in position %d to be '%s', but it was '%s'", $i, $a, $b);
318             }
319             }
320 7         26 return @problems;
321             }
322              
323             sub _match_arguments {
324 8     8   14 my $self = shift;
325 8         15 my ($a, $b) = @_;
326 8 0 33     19 return 1 if !defined $a && !defined $b;
327 8 50 33     32 return unless defined $a && defined $b;
328 8         77 return $a eq $b;
329             }
330              
331             sub _check_deep_args {
332 86     86   144 my $self = shift;
333 86 100       201 return unless defined $self->_deep_args;
334 14 100       38 return unless $self->_call_count;
335              
336 12         28 my @got = $self->_given_args;
337 12         34 my @expected = $self->_deep_args;
338 12         78 my ($same, $stack) = Test::Deep::cmp_details(\@got, \@expected);
339 12 100       40142 if ( !$same ) {
340 5         46 return Test::Deep::deep_diag($stack);
341             }
342 7         57 return; # args are the same
343             }
344              
345             #
346             # EXCEPTIONS
347             #
348              
349             sub raises {
350 1     1   5 my $self = shift;
351 1         3 my ($message) = @_;
352 1         6 $self->_exception($message);
353 1         2 return $self;
354             }
355              
356             sub _exception {
357 157     157   210 my $self = shift;
358 157 100       276 $self->{__exception} = shift if @_;
359 157   100     551 return $self->{__exception} ||= undef;
360             }
361              
362              
363              
364             #
365             # CALL COUNT CHECKS
366             #
367              
368             sub _times {
369 20     20   62 my ($self,$n,$msg,@params) = @_;
370 20 100       48 my $times = $n == 1 ? "time" : "times";
371 20         89 $msg =~ s{%times}{$times}g;
372 20 100       145 return @params ? sprintf($msg,@params) : $msg;
373             }
374              
375             # ensures that the expected method is called exactly N times
376             sub exactly {
377 5     5   18 my $self = shift;
378 5         9 my $n_times = shift;
379 5 50 33     43 if (!defined($n_times) || $n_times !~ /^\A\d+\z/) {
380 0         0 Carp::croak "Usage: ->exactly(INTEGER)";
381             }
382             $self->_check_call_count(sub {
383 5 100   5   13 if ($self->_call_count != $n_times) {
384 3         17 return $self->_times($n_times, "exactly $n_times %times");
385             }
386 5         31 });
387 5         17 $self;
388             }
389              
390             # ensures that the expected method is never called
391             sub never {
392 2     2   8 my $self = shift;
393 2         6 return $self->exactly(0);
394             }
395              
396             # ensures that the expected method is called exactly one time
397             sub once {
398 74     74   131 my $self = shift;
399             $self->_check_call_count(sub {
400 30 100   30   78 if ($self->_call_count != 1) {
401 4         13 return "exactly once";
402             }
403 74         393 });
404 74         116 $self;
405             }
406              
407             # ensures that the expected method is called at least N times
408             sub at_least {
409 17     17   37 my $self = shift;
410 17         26 my $n_times = shift;
411 17 50 33     134 if (!defined($n_times) || $n_times !~ /^\A\d+\z/) {
412 0         0 Carp::croak "Usage: ->at_least(INTEGER)";
413             }
414             $self->_check_call_count(sub {
415 34 100   34   69 if ($self->_call_count < $n_times) {
416 2         11 return $self->_times($n_times, "at least $n_times %times");
417             }
418 17         99 });
419 17         39 $self;
420             }
421              
422             sub at_least_once {
423 3     3   18 my $self = shift;
424 3         12 return $self->at_least(1);
425             }
426              
427             # ensures that the expected method is called at most N times
428             sub at_most {
429 10     10   44 my $self = shift;
430 10         19 my $n_times = shift;
431 10 50 33     115 if (!defined($n_times) || $n_times !~ /^\A\d+\z/) {
432 0         0 Carp::croak "Usage: ->at_most(INTEGER)";
433             }
434             $self->_check_call_count(sub {
435 10 100   10   31 if ($self->_call_count > $n_times) {
436 3         18 return $self->_times($n_times, "at most $n_times %times");
437             }
438 10         76 });
439 10         48 $self;
440             }
441              
442             sub at_most_once {
443 6     6   26 my $self = shift;
444 6         26 return $self->at_most(1);
445             }
446              
447             sub maybe {
448 3     3   16 my $self = shift;
449 3         8 return $self->at_most_once;
450             }
451              
452             sub any_number {
453 7     7   42 my $self = shift;
454 7     7   41 $self->_check_call_count(sub {});
455 7         37 $self;
456             }
457              
458             # dummy method for syntactic sugar
459             sub times {
460 0     0   0 my $self = shift;
461 0         0 $self;
462             }
463              
464             sub verify {
465 32     32   49 my $self = shift;
466 32         54 my @msgs = $self->problems;
467 32 100       66 die join("\n", @msgs) if @msgs;
468 31         75 return 1;
469             }
470              
471             sub problems {
472 86     86   295 my $self = shift;
473 86         124 my @prob;
474 86 100       179 if (my $message = $self->_check_call_count->()) {
475 12         28 push @prob, $self->_times(
476             $self->_call_count,
477             "expected %s to be called %s, but it was called %d %times\n",
478             $self->_method, $message, $self->_call_count,
479             );
480             }
481 86         247 for my $message ($self->_check_eq_args) {
482 6         16 push @prob, $message;
483             }
484 86         256 for my $message ($self->_check_deep_args) {
485 5         1054 push @prob, $message;
486             }
487 86         449 return @prob;
488             }
489              
490             sub setup {
491 764     764   1077 my $self = shift;
492 764 50       1317 if ($Debug) {
493 0         0 print STDERR "Setting up stub for @{[ $self->_target ]}->@{[ $self->_method ]}\n";
  0         0  
  0         0  
494             }
495              
496             # both these methods set _replaced_qualified_name and
497             # _original_code, which we'll use in teardown()
498 764 100       1307 if (ref $self->_target) {
499 735         1353 $self->_replace_instance_method;
500             }
501             else {
502 29         66 $self->_replace_class_method;
503             }
504             }
505              
506             sub teardown {
507 764     764   970 my $self = shift;
508              
509 764 50       1256 if ($Debug) {
510 0         0 print STDERR "Tearing down stub for @{[ $self->_target ]}->@{[ $self->_method ]}\n";
  0         0  
  0         0  
511             }
512              
513 14     14   124 no strict 'refs';
  14         36  
  14         489  
514 14     14   82 no warnings 'redefine';
  14         29  
  14         2543  
515              
516 764 100       1254 if ($self->_original_code) {
517 681         1082 *{ $self->_replaced_qualified_name } = $self->_original_code;
  681         1135  
518             }
519             else {
520             # avoid nuking aliases (including our _retval) by assigning a blank sub first.
521             # this technique stolen from ModPerl::Util::unload_package_pp
522 83     0   309 *{ $self->_replaced_qualified_name } = sub {};
  83         206  
523              
524             # Simply undefining &foo breaks in some cases by leaving some Perl
525             # droppings that cause subsequent calls to this function to die with
526             # "Not a CODE reference". It sounds harmless until Perl tries to
527             # call this method in an inheritance chain. Using Package::Stash solves
528             # that problem. It actually clones the original glob, leaving out the
529             # part being deleted.
530 83         931 require Package::Stash;
531 83         5935 my $stash = Package::Stash->new($self->_target_class);
532 83         290 $stash->remove_symbol('&' . $self->_method);
533             }
534              
535 764 100       1873 $self->verify unless $self->_canceled;
536             }
537              
538             sub _replaced_qualified_name {
539 764     764   1002 my $self = shift;
540 764         1200 return join("::", $self->_target_class, $self->_method);
541             }
542              
543             sub _replace_instance_method {
544 14     14   112 no strict 'refs';
  14         33  
  14         391  
545 14     14   78 no warnings qw(uninitialized);
  14         38  
  14         2893  
546              
547 735     735   1051 my $self = shift;
548 735         1207 my $target = $self->_target;
549 735         1340 my $class = ref($target);
550 735         1242 my $dest = join("::", $class, $self->_method);
551 735         1323 my $original_method = $class->can($self->_method);
552              
553             # save to be restored later
554 735         1728 $self->_target_class($class);
555 735         1675 $self->_original_code($original_method);
556              
557             $self->_install($dest => sub {
558             # Use refaddr() to prevent an overridden equality operator from
559             # making two objects appear equal when they are only equivalent.
560 146 100   146   768 if (Scalar::Util::refaddr($_[0]) == Scalar::Util::refaddr($target)) {
    50          
561             # do extreme late binding here, so calls to returns() after the
562             # mock has already been installed will take effect.
563 144         267 my @args = @_;
564 144         183 shift @args;
565 144         344 $self->_called(@args);
566 144 100       318 die $self->_exception if $self->_exception;
567 143         275 return $self->_retval->(@_);
568             }
569             elsif (!$original_method) {
570             # method didn't exist before, mimic Perl's behavior
571 0         0 Carp::croak sprintf("Can't locate object method \"%s\" " .
572             "via package \"%s\"", $self->_method, $class);
573             }
574             else {
575             # run the original as if we were never here.
576             # to that end, use goto to prevent the extra stack frame
577 2         5 goto $original_method;
578             }
579 735         3778 });
580             }
581              
582             sub _replace_class_method {
583 14     14   93 no strict 'refs';
  14         30  
  14         2420  
584              
585 29     29   38 my $self = shift;
586 29         51 my $dest = join("::", $self->_target, $self->_method);
587              
588 29         62 $self->_target_class($self->_target);
589 29 100       121 $self->_original_code(defined(&$dest) ? \&$dest : undef);
590              
591             $self->_install($dest => sub {
592             # do extreme late binding here, so calls to returns() after the
593             # mock has already been installed will take effect.
594 11     11   52 my @args = @_;
595 11         13 shift @args;
596 11         34 $self->_called(@args);
597 11 50       25 die $self->_exception if $self->_exception;
598 11         25 $self->_retval->(@_);
599 29         120 });
600             }
601              
602             sub _install {
603 764     764   1719 my ($self,$dest,$code) = @_;
604 764 100       1278 if ($self->_original_code) {
605             # avoid "Prototype mismatch"
606             # this code borrowed/enhanced from Moose::Exporter
607 681 50       1137 if (defined(my $proto = prototype $self->_original_code)) {
608             # XXX - Perl's prototype sucks. Use & to make set_prototype
609             # ignore the fact that we're passing "private variables"
610 0         0 &Scalar::Util::set_prototype($code, $proto);
611             }
612             }
613 14     14   94 no strict 'refs';
  14         27  
  14         424  
614 14     14   81 no warnings 'redefine';
  14         29  
  14         872  
615 764         3335 *$dest = $code;
616             }
617              
618             }
619              
620             {
621             package Test::Spec::Mocks::Stub;
622 14     14   87 use base qw(Test::Spec::Mocks::Expectation);
  14         26  
  14         4708  
623              
624             # A stub is a special case of expectation that doesn't actually
625             # expect anything.
626              
627             sub new {
628 11     11   17 my $class = shift;
629 11         38 my $self = $class->SUPER::new(@_);
630 11         32 $self->at_least(0);
631 11         16 return $self;
632             }
633              
634             }
635              
636             1;
637              
638             =head1 NAME
639              
640             Test::Spec::Mocks - Object Simulation Plugin for Test::Spec
641              
642             =head1 SYNOPSIS
643              
644             use Test::Spec;
645             use base qw(Test::Spec);
646              
647             use My::RSS::Tool; # this is what we're testing
648             use LWP::UserAgent;
649              
650             describe "RSS tool" => sub {
651             it "should fetch and parse an RSS feed" => sub {
652             my $xml = load_rss_fixture();
653             LWP::Simple->expects('get')->returns($xml);
654              
655             # calls LWP::Simple::get, but returns our $xml instead
656             my @stories = My::RSS::Tool->run;
657              
658             is_deeply(\@stories, load_stories_fixture());
659             };
660             };
661              
662             =head1 DESCRIPTION
663              
664             Test::Spec::Mocks is a plugin for Test::Spec that provides mocking and
665             stubbing of objects, individual methods and plain subroutines on both
666             object instances and classes. This module is inspired by and heavily
667             borrows from Mocha, a library for the Ruby programming language. Mocha
668             itself is inspired by JMock.
669              
670             Mock objects provide a way to simulate the behavior of real objects, while
671             providing consistent, repeatable results. This is very useful when you need
672             to test a function whose results are dependent upon an external factor that
673             is normally uncontrollable (like the time of day). Mocks also allow you to
674             test your code in isolation, a tenet of unit testing.
675              
676             There are many other reasons why mock objects might come in handy. See the
677             L article at Wikipedia
678             for lots more examples and more in-depth coverage of the philosophy behind
679             object mocking.
680              
681             =head2 Ecosystem
682              
683             Test::Spec::Mocks is currently only usable from within tests built with
684             the Test::Spec BDD framework.
685              
686             =head2 Terminology
687              
688             Familiarize yourself with these terms:
689              
690             =over 4
691              
692             =item * Stub object
693              
694             A stub object is an object created specifically to return canned responses for
695             a specific set of methods. These are created with the L function.
696              
697             =item * Mock object
698              
699             Mock objects are similar to stub objects, but are programmed with both
700             prepared responses and expectations for how they will be called. If the
701             expectations are not met, they raise an exception to indicate that the test
702             failed. Mock objects are created with the L function.
703              
704             =item * Stubbed method
705              
706             Stubbed methods temporarily replace existing methods on a class or object
707             instance. This is useful when you only want to override a subset of an object
708             or class's behavior. For example, you might want to override the C method
709             of a DBI handle so it doesn't make changes to your database, but still need
710             the handle to respond as usual to the C method. You'll stub
711             methods using the Lstubs($method_name)"> method.
712              
713             =item * Mocked method
714              
715             If you've been reading up to this point, this will be no surprise. Mocked
716             methods are just like stubbed methods, but they come with expectations that
717             will raise an exception if not met. For example, you can mock a C method
718             on an object to ensure it is called by the code you are testing, while
719             preventing the data from actually being committed to disk in your test. Use
720             the Lexpects($method)"> method to create mock methods.
721              
722             =item * "stub", "mock"
723              
724             Depending on context, these can refer to stubbed objects and methods, or
725             mocked objects and methods, respectively.
726              
727             =back
728              
729             =head2 Using stub objects (anonymous stubs)
730              
731             Sometimes the code you're testing requires that you pass it an object that
732             conforms to a specific interface. For example, you are testing a console
733             prompting library, but you don't want to require a real person to stand by,
734             waiting to type answers into the console. The library requires an object
735             that returns a string when the C method is called.
736              
737             You could create a class specifically for returning test console input. But
738             why do that? You can create a stub object in one line:
739              
740             describe "An Asker" => sub {
741             my $asker = Asker->new;
742              
743             it "returns true when a yes_or_no question is answered 'yes'" => sub {
744             my $console_stub = stub(read_line => "yes");
745             # $console_stub->read_line returns "yes"
746             ok( $asker->yes_or_no($console_stub, "Am I awesome?") );
747             };
748              
749             it "returns false when a yes_or_no question is answered 'no'" => sub {
750             my $console_stub = stub(read_line => "no");
751             ok( ! $asker->yes_or_no($console_stub, "Am I second best?") );
752             };
753             };
754              
755             Stubs can also take subroutine references. This is useful when the behavior
756             you need to mimic is a little more complex.
757              
758             it "keeps asking until it gets an answer" => sub {
759             my @answers = (undef, "yes");
760             my $console_stub = stub(read_line => sub { shift @answers });
761             # when console_stub is called the first time, it returns undef
762             # the second time returns "yes"
763             ok( $asker->yes_or_no($console_stub, "Do I smell nice?") );
764             };
765              
766             =head2 Using mock objects
767              
768             If you want to take your tests one step further, you can use mock objects
769             instead of stub objects. Mocks ensure the methods you expect to be called
770             actually are called. If they aren't, the mock will raise an exception which
771             causes your test to fail.
772              
773             In this example, we are testing that C is called once and only
774             once (the default for mocks).
775              
776             it "returns true when a yes_or_no question is answered 'yes'" => sub {
777             my $console_mock = mock();
778             $console_mock->expects('read_line')
779             ->returns("yes");
780             # $console_mock->read_line returns "yes"
781             ok( $asker->yes_or_no($console_mock, "Am I awesome?") );
782             };
783              
784             If Asker's C method doesn't call C on our mock exactly
785             one time, the test would fail with a message like:
786              
787             expected read_line to be called exactly 1 time, but it was called 0 times
788              
789             You can specify how many times your mock should be called with "exactly":
790              
791             it "keeps asking until it gets an answer" => sub {
792             my @answers = (undef, "yes");
793             my $console_mock = mock();
794             $console_mock->expects('read_line')
795             ->returns(sub { shift @answers })
796             ->exactly(2);
797             # when console_mock is called the first time, it returns undef
798             # the second time returns "yes"
799             ok( $asker->yes_or_no($console_mock, "Do I smell nice?") );
800             };
801              
802             If you want something more flexible than "exactly", you can choose from
803             "at_least", "at_most", "any_number" and others. See L.
804              
805              
806             =head2 Stubbing methods
807              
808             Sometimes you want to override just a small subset of an object's behavior.
809              
810             describe "The old audit system" => sub {
811             my $dbh;
812             before sub { $dbh = SomeExternalClass->get_dbh };
813              
814             it "executes the expected sql" => sub {
815             my $sql;
816             $dbh->stubs(do => sub { $sql = shift; return 1 });
817              
818             # $dbh->do("foo") now sets $sql to "foo"
819             # $dbh->quote still does what it normally would
820              
821             audit_event($dbh, "server crash, oh noes!!");
822              
823             like( $sql, qr/insert into audit_event.*'server crash, oh noes!!!'/ );
824             };
825             };
826              
827             You can also stub class methods:
828              
829             # 1977-05-26T14:11:55
830             my $event_datetime = DateTime->new(from_epoch => 0xdeafcab);
831              
832             it "should tag each audit event with the current time" => sub {
833             DateTime->stubs('now' => sub { $event_datetime });
834             is( audit_timestamp(), '19770526.141155' );
835             };
836              
837             =head2 Mocking methods
838              
839             Mocked methods are to stubbed methods as mock objects are to stub objects.
840              
841             it "executes the expected sql" => sub {
842             $dbh->expects('do')->returns(sub { $sql = shift; return 1 });
843              
844             # $dbh->do("foo") now sets $sql to "foo"
845             # $dbh->quote still does what it normally would
846              
847             audit_event($dbh, "server crash, oh noes!!");
848             like( $sql, qr/insert into audit_event.*'server crash, oh noes!!!'/ );
849              
850             # if audit_event doesn't call $dbh->do exactly once, KABOOM!
851             };
852              
853             =head1 CONSTRUCTORS
854              
855             =over 4
856              
857             =item stub()
858              
859             =item stub($method_name => $result, ...)
860              
861             =item stub($method_name => sub { $result }, ...)
862              
863             =item stub({ $method_name => $result, ... })
864              
865             Returns a new anonymous stub object. Takes a list of
866             C<$method_name>/C<$result> pairs or a reference to a hash containing the same.
867             Each C<$method_name> listed is stubbed to return the associated value
868             (C<$result>); or if the value is a subroutine reference, it is stubbed
869             in-place (the subroutine becomes the method).
870              
871             Examples:
872              
873             # A blank object with no methods.
874             # Gives a true response to ref() and blessed().
875             my $blank = stub();
876              
877             # Static responses to width() and height():
878             my $rect = stub(width => 5, height => 5);
879              
880             # Dynamic response to area():
881             my $radius = 1.0;
882             my $circle_stub = stub(area => sub { PI * $radius * $radius });
883              
884             You can also stub more methods, just like with any other object:
885              
886             my $rect = stub(width => 5, height => 5);
887             $rect->stubs(area => sub { my $self = shift; $self->width * $self->height });
888              
889              
890             =item $thing->stubs($method_name)
891              
892             =item $thing->stubs($method_name => $result)
893              
894             =item $thing->stubs($method_name => sub { $result })
895              
896             =item $thing->stubs({ $method_name => $result })
897              
898             Stubs one or more methods on an existing class or instance, C<$thing>.
899              
900             If passed only one (non-hash) argument, it is interpreted as a method name.
901             The return value of the stubbed method will be C.
902              
903             Otherwise, the arguments are a list of C<$method_name> and C<$result>
904             pairs, either as a flat list or as a hash reference. Each method is
905             installed onto C<$thing>, and returns the specified result. If the result is a
906             subroutine reference, it will be called for every invocation of the method.
907              
908              
909             =item mock()
910              
911             Returns a new blank, anonymous mock object, suitable for mocking methods with
912             Lexpects($method)">.
913              
914             my $rect = mock();
915             $rect->expects('area')->returns(100);
916              
917              
918             =item $thing->expects($method)
919              
920             Installs a mock method named C<$method> onto the class or object C<$thing> and
921             returns an Test::Spec::Mocks::Expectation object, which you can use to set the
922             return value with C and other expectations. By default, the method
923             is expected to be called L.
924              
925             If the expectation is not met before the enclosing example completes, the
926             mocked method will raise an exception that looks something like:
927              
928             expected foo to be called exactly 1 time, but it was called 0 times
929              
930             =back
931              
932             =head1 EXPECTATION ADJUSTMENT METHODS
933              
934             These are methods of the Test::Spec::Mocks::Expectation class, which you'll
935             receive by calling C on a class or object instance.
936              
937             =over 4
938              
939             =item returns( $result )
940              
941             =item returns( @result )
942              
943             =item returns( \&callback )
944              
945             Configures the mocked method to return the specified result when called. If
946             passed a subroutine reference, the subroutine will be executed when the method
947             is called, and the result is the return value.
948              
949             $rect->expects('height')->returns(5);
950             # $rect->height ==> 5
951              
952             @points = ( [0,0], [1,0], [1,1], [1,0] );
953             $rect->expects('points')->returns(@points);
954             # (@p = $rect->points) ==> ( [0,0], [1,0], [1,1], [1,0] )
955             # ($p = $rect->points) ==> 4
956              
957             @points = ( [0,0], [1,0], [1,1], [1,0] );
958             $rect->expects('next_point')->returns(sub { shift @points });
959             # $rect->next_point ==> [0,0]
960             # $rect->next_point ==> [1,0]
961             # ...
962              
963             =item exactly($N)
964              
965             Configures the mocked method so that it must be called exactly $N times.
966              
967             =item never
968              
969             Configures the mocked method so that it must never be called.
970              
971             =item once
972              
973             Configures the mocked method so that it must be called exactly one time.
974              
975             =item at_least($N)
976              
977             Configures the mocked method so that it must be called at least $N times.
978              
979             =item at_least_once
980              
981             Configures the mocked method so that it must be called at least 1 time.
982             This is just syntactic sugar for C.
983              
984             =item at_most($N)
985              
986             Configures the mocked method so that it must be called no more than $N times.
987              
988             =item at_most_once
989              
990             Configures the mocked method so that it must be called either zero or 1
991             times.
992              
993             =item maybe
994              
995             An alias for L.
996              
997             =item any_number
998              
999             Configures the mocked method so that it can be called zero or more times.
1000              
1001             =item times
1002              
1003             A syntactic sugar no-op:
1004              
1005             $io->expects('print')->exactly(3)->times;
1006              
1007             I
1008              
1009             =item with(@arguments) / with_eq(@arguments)
1010              
1011             Configures the mocked method so that it must be called with arguments as
1012             specified. The arguments will be compared using the "eq" operator, so it works
1013             for most scalar values with no problem. If you want to check objects here,
1014             they must be the exact same instance or you must overload the "eq" operator to
1015             provide the behavior you desire.
1016              
1017             =item with_deep(@arguments)
1018              
1019             Similar to C except the arguments are compared using L: scalars are
1020             compared by value, arrays and hashes must have the same elements and references
1021             must be blessed into the same class.
1022              
1023             $cache->expects('set')
1024             ->with_deep($customer_id, { name => $customer_name });
1025              
1026             Use L's comparison functions for more flexibility:
1027              
1028             use Test::Deep::NoTest ();
1029             $s3->expects('put')
1030             ->with_deep('test-bucket', 'my-doc', Test::Deep::ignore());
1031              
1032             =item raises($exception)
1033              
1034             Configures the mocked method so that it raises C<$exception> when called.
1035              
1036             =back
1037              
1038             =head1 OTHER EXPECTATION METHODS
1039              
1040             =over 4
1041              
1042             =item verify
1043              
1044             Allows you to verify manually that the expectation was met. If the expectation
1045             has not been met, the method dies with an error message containing specifics
1046             of the failure. Returns true otherwise.
1047              
1048             =item problems
1049              
1050             If the expectation has not been met, returns a list of problem description
1051             strings. Otherwise, returns an empty list.
1052              
1053             =back
1054              
1055             =head1 KNOWN ISSUES
1056              
1057             =over 4
1058              
1059             =item Memory leaks
1060              
1061             Because of the way the mock objects (C, C, C, and C)
1062             are integrated into the Test::Spec runtime they will leak memory. It is
1063             not recommended to use the Test::Spec mocks in any long-running program.
1064              
1065             Patches welcome.
1066              
1067             =back
1068              
1069             =head1 SEE ALSO
1070              
1071             There are other less sugary mocking systems for Perl, including
1072             L and L.
1073              
1074             This module is a plugin for L. It is inspired by
1075             L.
1076              
1077             The Wikipedia article L
1078             is very informative.
1079              
1080             =head1 AUTHOR
1081              
1082             Philip Garrett,
1083              
1084             =head1 COPYRIGHT & LICENSE
1085              
1086             Copyright (c) 2011 by Informatics Corporation of America.
1087              
1088             This program is free software; you can redistribute it and/or modify it
1089             under the same terms as Perl itself.
1090              
1091             =cut