File Coverage

blib/lib/Mock/MonkeyPatch.pm
Criterion Covered Total %
statement 63 63 100.0
branch 20 22 90.9
condition 3 5 60.0
subroutine 17 17 100.0
pod 7 7 100.0
total 110 114 96.4


line stmt bran cond sub pod time code
1             package Mock::MonkeyPatch;
2              
3 10     10   11 sub _defined { defined &{$_[0]} }
  10         207  
4             sub _patch {
5 18     18   20 my $p = prototype \&{$_[0]};
  18         44  
6 18 100       37 if (defined $p) {
7 2         11 Sub::Util::set_prototype($p, $_[1]);
8             }
9 18         19 *{$_[0]} = $_[1];
  18         82  
10             }
11              
12 1     1   61275 use strict;
  1         2  
  1         26  
13 1     1   4 use warnings;
  1         2  
  1         40  
14              
15             our $VERSION = '1.01';
16             $VERSION = eval $VERSION;
17              
18 1     1   4 use Carp ();
  1         2  
  1         10  
19 1     1   5 use Scalar::Util ();
  1         1  
  1         15  
20 1     1   501 use Sub::Util 1.40 ();
  1         267  
  1         250  
21              
22             sub ORIGINAL;
23              
24             sub arguments {
25 11     11 1 503 my ($self, $occurance) = @_;
26 11 100       26 $occurance = 0 unless defined $occurance;
27 11         48 return $self->{arguments}[$occurance];
28             }
29              
30 7     7 1 1790 sub called { scalar @{$_[0]{arguments}} }
  7         43  
31              
32             sub method_arguments {
33 3     3 1 7 my ($self, $occurance, $type) = @_;
34             return undef
35 3 50       8 unless my $args = $self->arguments($occurance);
36 3         7 my @args = @$args; # copy
37 3         4 my $inst = shift @args;
38 3 100       9 if ($type) {
39             return undef
40 2 100       13 unless $inst->isa($type);
41             }
42 2         9 return \@args;
43             }
44              
45             sub patch {
46 10     10 1 14439 my ($class, $symbol, $sub, $opts) = @_;
47 10   100     43 $opts ||= {};
48              
49 10         27 $symbol =~ s/^&//;
50              
51 10 100       22 Carp::croak "Symbol &$symbol is not already defined"
52             unless _defined $symbol;
53              
54             my $self = bless {
55             arguments => [],
56 9         54 original => \&{$symbol},
57 9 100       15 store => exists $opts->{store_arguments} ? $opts->{store_arguments} : 1,
58             sub => $sub,
59             symbol => $symbol,
60             }, $class;
61              
62 9         26 Scalar::Util::weaken(my $weak = $self);
63             _patch $symbol => sub {
64 1     1   7 no warnings 'redefine';
  1         2  
  1         346  
65 10     10   903 local *ORIGINAL = $weak->{original};
66 10 100       14 push @{ $weak->{arguments} }, [ $weak->{store} ? @_ : () ];
  10         51  
67 10         23 $sub->(@_);
68 9         33 };
69              
70 9         21 return $self;
71             }
72              
73 1     1 1 4 sub reset { $_[0]{arguments} = []; $_[0] }
  1         2  
74              
75             sub restore {
76 12     12 1 993 my $self = shift;
77 12 100       31 if (my $orig = delete $self->{original}) {
78 9         16 _patch $self->{symbol}, $orig;
79             }
80 12         47 return $self;
81             }
82              
83 4 100   4 1 665 sub store_arguments { @_ == 1 ? $_[0]{store} : do { $_[0]{store} = $_[1]; $_[0] } }
  2         3  
  2         3  
84              
85             sub DESTROY {
86 9     9   3220 my $self = shift;
87 9 50 33     46 return if defined ${^GLOBAL_PHASE} && ${^GLOBAL_PHASE} eq 'DESTRUCT';
88 9         19 $self->restore;
89             }
90              
91             1;
92              
93             =head1 NAME
94              
95             Mock::MonkeyPatch - Monkey patching with test mocking in mind
96              
97             =head1 SYNOPSIS
98              
99             {
100             package MyApp;
101              
102             sub gen_item_id {
103             my $type = shift;
104             # calls external service and gets id for $type
105             }
106              
107             sub build_item {
108             my $type = shift;
109             my $item = Item->new(type => $type);
110             $item->id(gen_item_id($type));
111             return $item;
112             }
113             }
114              
115             use Test::More;
116             use MyApp;
117             use Mock::MonkeyPatch;
118              
119             my $mock = Mock::MonkeyPatch->patch(
120             'MyApp::gen_item_id' => sub { 'abcd' }
121             );
122              
123             my $item = MyApp::build_item('rubber_chicken');
124             is $item->id, 'abcd', 'building item calls MyApp::gen_random_id';
125             ok $mock->called, 'the mock was indeed called';
126             is_deeply $mock->arguments, ['rubber_chicken'], 'the mock was called with expected arguments';
127              
128             =head1 DESCRIPTION
129              
130             Mocking is a common tool, especially for testing.
131             By strategically replacing a subroutine, one can isolate segments (units) of code to test individually.
132             When this is done it is important to know that the mocked sub was actually called and with what arguments it was called.
133              
134             L injects a subroutine in the place of an existing one.
135             It returns an object by which you can revisit the manner in which the mocked subroutine was called.
136             Further when the object goes out of scope (or when the L method is called) the original subroutine is replaced.
137              
138             =head1 CONSTRUCTOR
139              
140             =head2 patch
141              
142             my $mock = Mock::MonkeyPatch->patch('MyPackage::foo' => sub { ... });
143             my $mock = Mock::MonkeyPatch->patch('MyPackage::foo' => sub { ... }, \%options);
144              
145             Mock a subroutine and return a object to represent it.
146             Takes a fully qualifed subroutine name, a subroutine reference to call in its place, and optionally a hash reference of additional constructor arguments.
147              
148             The replacement subroutine will be wrapped in a one that will store calling data, then injected in place of the original.
149             Within the replacement subroutine the original is available as the fully qualified subroutine C.
150             This can be used to inject behavior before, after, or even around the original.
151             This includes munging the arguments passed to the origial (though the actual arguments are what are stored).
152             For example usage, see L.
153              
154             Currently the optional hashref only accepts one option, an initial value for L which is true if not given.
155              
156             The wrapper will have the same prototype as the mocked function if one exists.
157             The replacement need not have any prototype, the arguments received by the wrapper will be passed to the given sub as they were received.
158             (If this doesn't make any sense to you, don't worry about it.)
159              
160             =head1 METHODS
161              
162             =head2 arguments
163              
164             my $args = $mock->arguments;
165             my $args_second_time = $mock->arguments(1);
166              
167             Returns an array reference containing the arguments that were passed to the mocked subroutine (but see also L).
168             Optionally an integer may be passed which designates the call number to fetch arguments in the same manner of indexing an array (zero indexed).
169             If not given, C<0> is assumed, representing the first time the mock was called.
170             Returns C if the mocked subroutine was not called (or was not called enough times).
171              
172             use Test::More;
173             is_deeply $mock->arguments, [1, 2, 3], 'called with the right arguments';
174              
175             =head2 called
176              
177             my $time_called = $mock->called;
178              
179             Returns the number of times the mocked subroutine was called.
180             This means that that there should be values available from L up to the value of C<< $mock->called - 1 >>.
181              
182             use Test::More;
183             ok $mock->called, 'mock was called';
184             is $mock->called, 3, 'mock was called three times';
185              
186             =head2 method_arguments
187              
188             my $args = $mock->method_arguments;
189             my $args_third_time = $mock->method_arguments(2, 'MyClass');
190              
191             A wrapper around L convenient for when the mocked subroutine is called as a method.
192             Like L it returns a subroutine reference, though it removes the first arguments which is the invocant.
193             It also can take a call number designation.
194              
195             Additionally it takes a class name to test against the invocant as C<< $invocant->isa('Class::Name') >>.
196             If the invocant is not an instance of the class or a subclass thereof it returns C.
197              
198             use Test::More;
199             is_deeply $mock->method_arguments(0, 'FrobberCo::Employee'),
200             ['some', 'arguments'], 'mock method called with known arguments on a FrobberCo::Employee instance';
201              
202             =head2 reset
203              
204             $mock = $mock->reset;
205              
206             Reset the historical information stored in the mock, including L and L.
207             Returns the mock instance for chaining if desired.
208              
209             Note that this does not restore the original method. for that, see L.
210              
211             use Test::More;
212             is $mock->called, 3, 'called 3 times';
213             is $mock->reset->called, 0, 'called zero times after reset';
214              
215             =head2 restore
216              
217             $mock = $mock->restore;
218              
219             Restore the original method to its original place in the symbol table.
220             This method is also called automatically when the object goes out of scope and is garbage collected.
221             Returns the mock instance for chaining if desired.
222             This method can only be called once!
223              
224             Note that this does not reset historical information stored in the mock, for that, see L.
225              
226             =head2 store_arguments
227              
228             $mock = $mock->store_arguments(0);
229              
230             When true, the default if not passed to the constructor, arguments passed to the mocked subroutine are stored and accessible later via L and L.
231             However sometimes this isn't desirable, especially in cases where the reference count of items in the arguments matter; notably when an object should be destroyed and the destructor's behavior is important.
232             When this is true set C to a false value and only an empty array reference will be stored.
233              
234             When used as a setter, it returns the mock instance for chaining if desired.
235              
236             =head1 COOKBOOK
237              
238             =head2 Run code before the original
239              
240             The original version of the mocked function (read: the code that was available via the symbol B)
241             is available via the fully qualified symbol C.
242             You can call this in your mock if for example you want to do some setup before calling the function.
243              
244             my $mock = $self->patch($symbol, sub {
245             # do some stuff before the original
246             do_mocked_stuff(@_);
247             # then call the original function/method
248             Mock::MonkeyPatch::ORIGINAL(@_);
249             });
250              
251             =head2 Using ORIGINAL in a nonblocking environment
252              
253             Since the C symbol is implemented via C if you want to call it after leaving the scope you need to store a reference to the function in a lexical.
254              
255             my $mock = $self->patch($symbol, sub {
256             my @args = @_;
257             my $orig = \&Mock::MonkeyPatch::ORIGINAL;
258             Mojo::IOLoop->timer(1 => sub { $orig->(@args) });
259             });
260              
261             =head1 SEE ALSO
262              
263             =over
264              
265             =item *
266              
267             L
268              
269             =item *
270              
271             L
272              
273             =item *
274              
275             L
276              
277             =back
278              
279             =head1 SOURCE REPOSITORY
280              
281             L
282              
283             =head1 AUTHOR
284              
285             Joel Berger, Ejoel.a.berger@gmail.comE
286              
287             =head1 CONTRIBUTORS
288              
289             =over
290              
291             =item *
292              
293             Doug Bell (preaction)
294              
295             =item *
296              
297             Brian Medley (bpmedley)
298              
299             =back
300              
301             =head1 COPYRIGHT AND LICENSE
302              
303             Copyright (C) 2016 by Joel Berger and L
304              
305             This library is free software; you can redistribute it and/or modify
306             it under the same terms as Perl itself.