File Coverage

blib/lib/Test/MockModule.pm
Criterion Covered Total %
statement 154 155 99.3
branch 54 58 93.1
condition 20 21 95.2
subroutine 29 30 96.6
pod 12 12 100.0
total 269 276 97.4


line stmt bran cond sub pod time code
1             package Test::MockModule;
2 9     9   551563 use warnings;
  9         56  
  9         308  
3 9     9   46 use strict qw/subs vars/;
  9         15  
  9         248  
4 9     9   43 use vars qw/$VERSION/;
  9         15  
  9         403  
5 9     9   61 use Scalar::Util qw/reftype weaken/;
  9         15  
  9         567  
6 9     9   60 use Carp;
  9         24  
  9         468  
7 9     9   4675 use SUPER;
  9         22739  
  9         59  
8             $VERSION = '0.177.0';
9              
10             sub import {
11 13     13   555 my ( $class, @args ) = @_;
12              
13             # default if no args
14 13         73 $^H{'Test::MockModule/STRICT_MODE'} = 0;
15              
16 13         35 foreach my $arg (@args) {
17 5 100       17 if ( $arg eq 'strict' ) {
    50          
18 3         9 $^H{'Test::MockModule/STRICT_MODE'} = 1;
19             } elsif ( $arg eq 'nostrict' ) {
20 2         6 $^H{'Test::MockModule/STRICT_MODE'} = 0;
21             } else {
22 0         0 warn "Test::MockModule unknown import option '$arg'";
23             }
24             }
25 13         3658 return;
26             }
27              
28             sub _strict_mode {
29 26     26   47 my $depth = 0;
30 26         224 while(my @fields = caller($depth++)) {
31 51         89 my $hints = $fields[10];
32 51 100 66     255 if($hints && grep { /^Test::MockModule\// } keys %{$hints}) {
  13         89  
  13         71  
33 13         434 return $hints->{'Test::MockModule/STRICT_MODE'};
34             }
35             }
36 13         32 return 0;
37             }
38              
39             my %mocked;
40             sub new {
41 22     22 1 8546 my $class = shift;
42 22         63 my ($package, %args) = @_;
43 22 100 100     173 if ($package && (my $existing = $mocked{$package})) {
44 1         4 return $existing;
45             }
46              
47 21 100 100     278 croak "Cannot mock $package" if $package && $package eq $class;
48 20 100       53 unless (_valid_package($package)) {
49 2 100       12 $package = 'undef' unless defined $package;
50 2         176 croak "Invalid package name $package";
51             }
52              
53 18 100 100     164 unless ($package eq "CORE::GLOBAL" || $package eq 'main' || $args{no_auto} || ${"$package\::VERSION"}) {
  12   100     82  
      100        
54 6         27 (my $load_package = "$package.pm") =~ s{::}{/}g;
55 6         25 TRACE("$package is empty, loading $load_package");
56 6         361 require $load_package;
57             }
58              
59 18         187 TRACE("Creating MockModule object for $package");
60 18         83 my $self = bless {
61             _package => $package,
62             _mocked => {},
63             }, $class;
64 18         44 $mocked{$package} = $self;
65 18         79 weaken $mocked{$package};
66 18         63 return $self;
67             }
68              
69             sub DESTROY {
70 18     18   9083 my $self = shift;
71 18         72 $self->unmock_all;
72             }
73              
74             sub get_package {
75 1     1 1 826 my $self = shift;
76 1         4 return $self->{_package};
77             }
78              
79             sub redefine {
80 10     10 1 67 my ($self, @mocks) = (shift, @_);
81              
82 10         58 while ( my ($name, $value) = splice @mocks, 0, 2 ) {
83 10         31 my $sub_name = $self->_full_name($name);
84 10         23 my $coderef = *{$sub_name}{'CODE'};
  10         40  
85 10 100       54 next if 'CODE' eq ref $coderef;
86              
87 4 50       107 if ( $sub_name =~ qr{^(.+)::([^:]+)$} ) {
88 4         19 my ( $pkg, $sub ) = ( $1, $2 );
89 4 100       62 next if $pkg->can( $sub );
90             }
91              
92 3 50       14 if ('CODE' ne ref $coderef) {
93 3         410 croak "$sub_name does not exist!";
94             }
95             }
96              
97 7         34 return $self->_mock(@_);
98             }
99              
100             sub define {
101 5     5 1 608 my ($self, @mocks) = (shift, @_);
102              
103 5         20 while ( my ($name, $value) = splice @mocks, 0, 2 ) {
104 5         13 my $sub_name = $self->_full_name($name);
105 5         9 my $coderef = *{$sub_name}{'CODE'};
  5         16  
106              
107 5 100       31 if ('CODE' eq ref $coderef) {
108 1         141 croak "$sub_name exists!";
109             }
110             }
111              
112 4         13 return $self->_mock(@_);
113             }
114              
115             sub mock {
116 21     21 1 6948 my ($self, @mocks) = (shift, @_);
117              
118 21 100       60 croak "mock is not allowed in strict mode. Please use define or redefine" if($self->_strict_mode());
119              
120 18         58 return $self->_mock(@mocks);
121             }
122              
123             sub _mock {
124 32     32   55 my $self = shift;
125              
126 32         117 while (my ($name, $value) = splice @_, 0, 2) {
127 34     1   114 my $code = sub { };
128 34 100 100     181 if (ref $value && reftype $value eq 'CODE') {
    100          
129 13         42 $code = $value;
130             } elsif (defined $value) {
131 19     15   77 $code = sub {$value};
  15         660  
132             }
133              
134 34         156 TRACE("$name: $code");
135 34 100       79 croak "Invalid subroutine name: $name" unless _valid_subname($name);
136 33         90 my $sub_name = _full_name($self, $name);
137 33 100       97 if (!$self->{_mocked}{$name}) {
138 26         101 TRACE("Storing existing $sub_name");
139 26         61 $self->{_mocked}{$name} = 1;
140 26 100       44 if (defined &{$sub_name}) {
  26         89  
141 15         49 $self->{_orig}{$name} = \&$sub_name;
142             } else {
143 11         61 $self->{_orig}{$name} = undef;
144             }
145             }
146 33         119 TRACE("Installing mocked $sub_name");
147 33         71 _replace_sub($sub_name, $code);
148             }
149              
150 31         96 return $self;
151             }
152              
153             sub noop {
154 3     3 1 1190 my $self = shift;
155              
156 3 100       10 croak "noop is not allowed in strict mode. Please use define or redefine" if($self->_strict_mode());
157              
158 2         9 $self->_mock($_,1) for @_;
159              
160 2         5 return;
161             }
162              
163             sub original {
164 7     7 1 3811 my $self = shift;
165 7         14 my ($name) = @_;
166             return carp _full_name($self, $name) . " is not mocked"
167 7 100       22 unless $self->{_mocked}{$name};
168 6 100       42 return defined $self->{_orig}{$name} ? $self->{_orig}{$name} : $self->{_package}->super($name);
169             }
170             sub unmock {
171 30     30 1 4297 my $self = shift;
172              
173 30 100       156 carp 'Nothing to unmock' unless @_;
174 30         98 for my $name (@_) {
175 29 100       61 croak "Invalid subroutine name: $name" unless _valid_subname($name);
176              
177 28         69 my $sub_name = _full_name($self, $name);
178 28 100       122 unless ($self->{_mocked}{$name}) {
179 2         151 carp $sub_name . " was not mocked";
180 2         79 next;
181             }
182              
183 26         94 TRACE("Restoring original $sub_name");
184 26         68 _replace_sub($sub_name, $self->{_orig}{$name});
185 26         58 delete $self->{_mocked}{$name};
186 26         71 delete $self->{_orig}{$name};
187             }
188 29         56 return $self;
189             }
190              
191             sub unmock_all {
192 19     19 1 35 my $self = shift;
193 19         32 foreach (keys %{$self->{_mocked}}) {
  19         82  
194 20         51 $self->unmock($_);
195             }
196              
197 19         973 return;
198             }
199              
200             sub is_mocked {
201 5     5 1 1661 my $self = shift;
202 5         12 my ($name) = shift;
203 5         22 return $self->{_mocked}{$name};
204             }
205              
206             sub _full_name {
207 77     77   152 my ($self, $sub_name) = @_;
208 77         415 sprintf "%s::%s", $self->{_package}, $sub_name;
209             }
210              
211             sub _valid_package {
212 20 100   20   187 defined($_[0]) && $_[0] =~ /^[a-z_]\w*(?:::\w+)*$/i;
213             }
214              
215             sub _valid_subname {
216 63     63   543 $_[0] =~ /^[a-z_]\w*$/i;
217             }
218              
219             sub _replace_sub {
220 59     59   114 my ($sub_name, $coderef) = @_;
221              
222 9     9   14416 no warnings 'redefine';
  9         29  
  9         401  
223 9     9   55 no warnings 'prototype';
  9         33  
  9         2430  
224              
225 59 100       136 if (defined $coderef) {
226 48         65 *{$sub_name} = $coderef;
  48         288  
227             } else {
228 11         46 TRACE("removing subroutine: $sub_name");
229 11         58 my ($package, $sub) = $sub_name =~ /(.*::)(.*)/;
230 11         26 my %symbols = %{$package};
  11         91  
231              
232             # save a copy of all non-code slots
233 11         23 my %slot;
234 11         26 foreach (qw(ARRAY FORMAT HASH IO SCALAR)) {
235 55 100       70 next unless defined(my $elem = *{$symbols{$sub}}{$_});
  55         185  
236 12         48 $slot{$_} = $elem;
237             }
238              
239             # clear the symbol table entry for the subroutine
240 11         45 undef *$sub_name;
241              
242             # restore everything except the code slot
243 11 50       34 return unless keys %slot;
244 11         29 foreach (keys %slot) {
245 12         76 *$sub_name = $slot{$_};
246             }
247             }
248             }
249              
250             # Log::Trace stubs
251       154 1   sub TRACE {}
252       0 1   sub DUMP {}
253              
254             1;
255              
256             =pod
257              
258             =head1 NAME
259              
260             Test::MockModule - Override subroutines in a module for unit testing
261              
262             =head1 SYNOPSIS
263              
264             use Module::Name;
265             use Test::MockModule;
266              
267             {
268             my $module = Test::MockModule->new('Module::Name');
269             $module->mock('subroutine', sub { ... });
270             Module::Name::subroutine(@args); # mocked
271              
272             # Same effect, but this will die() if other_subroutine()
273             # doesn't already exist, which is often desirable.
274             $module->redefine('other_subroutine', sub { ... });
275              
276             # This will die() if another_subroutine() is defined.
277             $module->define('another_subroutine', sub { ... });
278             }
279              
280             {
281             # you can also chain new/mock/redefine/define
282              
283             Test::MockModule->new('Module::Name')
284             ->mock( one_subroutine => sub { ... })
285             ->redefine( other_subroutine => sub { ... } )
286             ->define( a_new_sub => 1234 );
287             }
288              
289             Module::Name::subroutine(@args); # original subroutine
290              
291             # Working with objects
292             use Foo;
293             use Test::MockModule;
294             {
295             my $mock = Test::MockModule->new('Foo');
296             $mock->mock(foo => sub { print "Foo!\n"; });
297              
298             my $foo = Foo->new();
299             $foo->foo(); # prints "Foo!\n"
300             }
301              
302             # If you want to prevent noop and mock from working, you can
303             # load Test::MockModule in strict mode.
304              
305             use Test::MockModule qw/strict/;
306             my $module = Test::MockModule->new('Module::Name');
307              
308             # Redefined the other_subroutine or dies if it's not there.
309             $module->redefine('other_subroutine', sub { ... });
310              
311             # Dies since you specified you wanted strict mode.
312             $module->mock('subroutine', sub { ... });
313              
314             # Turn strictness off in this lexical scope
315             {
316             use Test::MockModule 'nostrict';
317             # ->mock() works now
318             $module->mock('subroutine', sub { ... });
319             }
320              
321             # Back in the strict scope, so mock() dies here
322             $module->mock('subroutine', sub { ... });
323              
324             =head1 DESCRIPTION
325              
326             C lets you temporarily redefine subroutines in other packages
327             for the purposes of unit testing.
328              
329             A C object is set up to mock subroutines for a given
330             module. The object remembers the original subroutine so it can be easily
331             restored. This happens automatically when all MockModule objects for the given
332             module go out of scope, or when you C the subroutine.
333              
334             =head1 STRICT MODE
335              
336             One of the weaknesses of testing using mocks is that the implementation of the
337             interface that you are mocking might change, while your mocks get left alone.
338             You are not now mocking what you thought you were, and your mocks might now be
339             hiding bugs that will only be spotted in production. To help prevent this you
340             can load Test::MockModule in 'strict' mode:
341              
342             use Test::MockModule qw(strict);
343              
344             This will disable use of the C method, making it a fatal runtime error.
345             You should instead define mocks using C, which will only mock
346             things that already exist and die if you try to redefine something that doesn't
347             exist.
348              
349             Strictness is lexically scoped, so you can do this in one file:
350              
351             use Test::MockModule qw(strict);
352            
353             ...->redefine(...);
354              
355             and this in another:
356              
357             use Test::MockModule; # the default is nostrict
358              
359             ...->mock(...);
360              
361             You can even mix n match at different places in a single file thus:
362              
363             use Test::MockModule qw(strict);
364             # here mock() dies
365              
366             {
367             use Test::MockModule qw(nostrict);
368             # here mock() works
369             }
370              
371             # here mock() goes back to dieing
372              
373             use Test::MockModule qw(nostrict);
374             # and from here on mock() works again
375              
376             NB that strictness must be defined at compile-time, and set using C. If
377             you think you're going to try and be clever by calling Test::MockModule's
378             C method at runtime then what happens in undefined, with results
379             differing from one version of perl to another. What larks!
380              
381             =head1 METHODS
382              
383             =over 4
384              
385             =item new($package[, %options])
386              
387             Returns an object that will mock subroutines in the specified C<$package>.
388              
389             If there is no C<$VERSION> defined in C<$package>, the module will be
390             automatically loaded. You can override this behaviour by setting the C
391             option:
392              
393             my $mock = Test::MockModule->new('Module::Name', no_auto => 1);
394              
395             =item get_package()
396              
397             Returns the target package name for the mocked subroutines
398              
399             =item is_mocked($subroutine)
400              
401             Returns a boolean value indicating whether or not the subroutine is currently
402             mocked
403              
404             =item mock($subroutine =E \Ecoderef)
405              
406             Temporarily replaces one or more subroutines in the mocked module. A subroutine
407             can be mocked with a code reference or a scalar. A scalar will be recast as a
408             subroutine that returns the scalar.
409              
410             Returns the current C object, so you can chain L with L.
411              
412             my $mock = Test::MockModule->new->(...)->mock(...);
413              
414             The following statements are equivalent:
415              
416             $module->mock(purge => 'purged');
417             $module->mock(purge => sub { return 'purged'});
418              
419             When dealing with references, things behave slightly differently. The following
420             statements are B equivalent:
421              
422             # Returns the same arrayref each time, with the localtime() at time of mocking
423             $module->mock(updated => [localtime()]);
424             # Returns a new arrayref each time, with up-to-date localtime() value
425             $module->mock(updated => sub { return [localtime()]});
426              
427             The following statements are in fact equivalent:
428              
429             my $array_ref = [localtime()]
430             $module->mock(updated => $array_ref)
431             $module->mock(updated => sub { return $array_ref });
432              
433              
434             However, C is a special case. If you mock a subroutine with C it
435             will install an empty subroutine
436              
437             $module->mock(purge => undef);
438             $module->mock(purge => sub { });
439              
440             rather than a subroutine that returns C:
441              
442             $module->mock(purge => sub { undef });
443              
444             You can call C for the same subroutine many times, but when you call
445             C, the original subroutine is restored (not the last mocked
446             instance).
447              
448             B
449              
450             If you are trying to mock a subroutine exported from another module, this may
451             not behave as you initially would expect, since Test::MockModule is only mocking
452             at the target module, not anything importing that module. If you mock the local
453             package, or use a fully qualified function name, you will get the behavior you
454             desire:
455              
456             use Test::MockModule;
457             use Test::More;
458             use POSIX qw/strftime/;
459              
460             my $posix = Test::MockModule->new("POSIX");
461              
462             $posix->mock("strftime", "Yesterday");
463             is strftime("%D", localtime(time)), "Yesterday", "`strftime` was mocked successfully"; # Fails
464             is POSIX::strftime("%D", localtime(time)), "Yesterday", "`strftime` was mocked successfully"; # Succeeds
465              
466             my $main = Test::MockModule->new("main", no_auto => 1);
467             $main->mock("strftime", "today");
468             is strftime("%D", localtime(time)), "today", "`strftime` was mocked successfully"; # Succeeds
469              
470             If you are trying to mock a subroutine that was exported into a module that you're
471             trying to test, rather than mocking the subroutine in its originating module,
472             you can instead mock it in the module you are testing:
473              
474             package MyModule;
475             use POSIX qw/strftime/;
476              
477             sub minus_twentyfour
478             {
479             return strftime("%a, %b %d, %Y", localtime(time - 86400));
480             }
481              
482             package main;
483             use Test::More;
484             use Test::MockModule;
485              
486             my $posix = Test::MockModule->new("POSIX");
487             $posix->mock("strftime", "Yesterday");
488              
489             is MyModule::minus_twentyfour(), "Yesterday", "`minus-twentyfour` got mocked"; # fails
490              
491             my $mymodule = Test::MockModule->new("MyModule", no_auto => 1);
492             $mymodule->mock("strftime", "Yesterday");
493             is MyModule::minus_twentyfour(), "Yesterday", "`minus-twentyfour` got mocked"; # succeeds
494              
495             =item redefine($subroutine)
496              
497             The same behavior as C, but this will preemptively check to be
498             sure that all passed subroutines actually exist. This is useful to ensure that
499             if a mocked module's interface changes the test doesn't just keep on testing a
500             code path that no longer behaves consistently with the mocked behavior.
501              
502             Note that redefine is also now checking if one of the parent provides the sub
503             and will not die if it's available in the chain.
504              
505             Returns the current C object, so you can chain L with L.
506              
507             my $mock = Test::MockModule->new->(...)->redefine(...);
508              
509             =item define($subroutine)
510              
511             The reverse of redefine, this will fail if the passed subroutine exists.
512             While this use case is rare, there are times where the perl code you are
513             testing is inspecting a package and adding a missing subroutine is actually
514             what you want to do.
515              
516             By using define, you're asserting that the subroutine you want to be mocked
517             should not exist in advance.
518              
519             Note: define does not check for inheritance like redefine.
520              
521             Returns the current C object, so you can chain L with L.
522              
523             my $mock = Test::MockModule->new->(...)->define(...);
524              
525             =item original($subroutine)
526              
527             Returns the original (unmocked) subroutine
528              
529             Here is a sample how to wrap a function with custom arguments using the original subroutine.
530             This is useful when you cannot (do not) want to alter the original code to abstract
531             one hardcoded argument pass to a function.
532              
533             package MyModule;
534              
535             sub sample {
536             return get_path_for("/a/b/c/d");
537             }
538              
539             sub get_path_for {
540             ... # anything goes there...
541             }
542              
543             package main;
544             use Test::MockModule;
545              
546             my $mock = Test::MockModule->new("MyModule");
547             # replace all calls to get_path_for using a different argument
548             $mock->redefine("get_path_for", sub {
549             return $mock->original("get_path_for")->("/my/custom/path");
550             });
551              
552             # or
553              
554             $mock->redefine("get_path_for", sub {
555             my $path = shift;
556             if ( $path && $path eq "/a/b/c/d" ) {
557             # only alter calls with path set to "/a/b/c/d"
558             return $mock->original("get_path_for")->("/my/custom/path");
559             } else { # preserve the original arguments
560             return $mock->original("get_path_for")->($path, @_);
561             }
562             });
563              
564              
565             =item unmock($subroutine [, ...])
566              
567             Restores the original C<$subroutine>. You can specify a list of subroutines to
568             C in one go.
569              
570             =item unmock_all()
571              
572             Restores all the subroutines in the package that were mocked. This is
573             automatically called when all C objects for the given package
574             go out of scope.
575              
576             =item noop($subroutine [, ...])
577              
578             Given a list of subroutine names, mocks each of them with a no-op subroutine. Handy
579             for mocking methods you want to ignore!
580              
581             # Neuter a list of methods in one go
582             $module->noop('purge', 'updated');
583              
584              
585             =back
586              
587             =over 4
588              
589             =item TRACE
590              
591             A stub for Log::Trace
592              
593             =item DUMP
594              
595             A stub for Log::Trace
596              
597             =back
598              
599             =head1 SEE ALSO
600              
601             L
602              
603             L
604              
605             =head1 AUTHORS
606              
607             Current Maintainer: Geoff Franks
608              
609             Original Author: Simon Flack Esimonflk _AT_ cpan.orgE
610              
611             Lexical scoping of strictness: David Cantrell Edavid@cantrell.org.ukE
612              
613             =head1 COPYRIGHT
614              
615             Copyright 2004 Simon Flack Esimonflk _AT_ cpan.orgE.
616             All rights reserved
617              
618             You may distribute under the terms of either the GNU General Public License or
619             the Artistic License, as specified in the Perl README file.
620              
621             =cut