File: | blib/lib/Test/Mocha.pm |
Coverage: | 99.6% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Test::Mocha; | ||||||
2 | # ABSTRACT: Test Spy/Stub Framework | ||||||
3 | $Test::Mocha::VERSION = '0.61'; | ||||||
4 | |||||||
5 | 12 12 12 | 1369274 11 271 | use strict; | ||||
6 | 12 12 12 | 28 8 198 | use warnings; | ||||
7 | |||||||
8 | 12 12 12 | 27 20 464 | use Carp 'croak'; | ||||
9 | 12 12 12 | 28 12 204 | use Exporter 'import'; | ||||
10 | 12 12 12 | 24 15 396 | use Scalar::Util 'blessed'; | ||||
11 | 12 12 12 | 4619 16 169 | use Test::Mocha::CalledOk::Times; | ||||
12 | 12 12 12 | 4643 18 164 | use Test::Mocha::CalledOk::AtLeast; | ||||
13 | 12 12 12 | 4615 16 174 | use Test::Mocha::CalledOk::AtMost; | ||||
14 | 12 12 12 | 4544 16 154 | use Test::Mocha::CalledOk::Between; | ||||
15 | 12 12 12 | 4344 24 291 | use Test::Mocha::Mock; | ||||
16 | 12 12 12 | 61 13 100 | use Test::Mocha::Types 'NumRange', Mock => { -as => 'MockType' }; | ||||
17 | 12 12 12 | 4889 11 501 | use Test::Mocha::Util qw( get_method_call extract_method_name ); | ||||
18 | 12 12 12 | 50 11 53 | use Types::Standard qw( ArrayRef HashRef Num slurpy ); | ||||
19 | |||||||
20 | our @EXPORT = qw( | ||||||
21 | mock | ||||||
22 | class_mock | ||||||
23 | stub | ||||||
24 | returns | ||||||
25 | throws | ||||||
26 | executes | ||||||
27 | called_ok | ||||||
28 | times | ||||||
29 | atleast | ||||||
30 | atmost | ||||||
31 | between | ||||||
32 | verify | ||||||
33 | inspect | ||||||
34 | inspect_all | ||||||
35 | clear | ||||||
36 | SlurpyArray | ||||||
37 | SlurpyHash | ||||||
38 | ); | ||||||
39 | |||||||
40 | # croak() messages should not trace back to Mocha modules | ||||||
41 | $Carp::Internal{$_}++ foreach qw( | ||||||
42 | Test::Mocha | ||||||
43 | Test::Mocha::CalledOk | ||||||
44 | Test::Mocha::Mock | ||||||
45 | Test::Mocha::Util | ||||||
46 | Test::Mocha::MethodStub | ||||||
47 | Test::Mocha::Verify | ||||||
48 | ); | ||||||
49 | |||||||
50 | sub mock { | ||||||
51 | 34 | 1 | 959505 | return Test::Mocha::Mock->__new(@_); | |||
52 | } | ||||||
53 | |||||||
54 | sub stub (&@) { | ||||||
55 | 40 | 1 | 2615 | my ( $coderef, @responses ) = @_; | |||
56 | |||||||
57 | 40 | 40 | foreach (@responses) { | ||||
58 | 38 | 233 | croak 'stub() responses should be supplied using ', | ||||
59 | 'returns(), throws() or executes()' | ||||||
60 | if ref ne 'CODE'; | ||||||
61 | } | ||||||
62 | |||||||
63 | 39 | 31 | $Test::Mocha::Mock::num_method_calls = 0; | ||||
64 | 39 | 57 | my $method_call = get_method_call($coderef); | ||||
65 | 34 | 39 | my $stubs = $method_call->invocant->__stubs; | ||||
66 | 34 34 | 15 37 | unshift @{ $stubs->{ $method_call->name } }, $method_call; | ||||
67 | |||||||
68 | 34 | 55 | Test::Mocha::MethodStub->cast($method_call); | ||||
69 | 34 34 | 19 37 | push @{ $method_call->__responses }, @responses; | ||||
70 | 34 | 37 | return; | ||||
71 | } | ||||||
72 | |||||||
73 | sub returns (@) { | ||||||
74 | 24 | 1 | 3527 | my (@return_values) = @_; | |||
75 | 43 | 105 | return sub { $return_values[0] } | ||||
76 | 24 | 81 | if @return_values == 1; | ||||
77 | 2 | 6 | return sub { @return_values } | ||||
78 | 2 | 6 | if @return_values > 1; | ||||
79 | 1 2 | 4 4 | return sub { }; # if @return_values == 0 | ||||
80 | } | ||||||
81 | |||||||
82 | sub throws (@) { | ||||||
83 | 10 | 1 | 4233 | my (@exception) = @_; | |||
84 | |||||||
85 | # check if first arg is a throwable exception | ||||||
86 | 1 | 2 | return sub { $exception[0]->throw } | ||||
87 | 10 | 42 | if blessed( $exception[0] ) && $exception[0]->can('throw'); | ||||
88 | |||||||
89 | 9 10 | 26 446 | return sub { croak @exception }; | ||||
90 | |||||||
91 | } | ||||||
92 | |||||||
93 | sub executes (&) { | ||||||
94 | 3 | 1 | 9 | my ($callback) = @_; | |||
95 | 3 | 5 | return $callback; | ||||
96 | } | ||||||
97 | |||||||
98 | ## no critic (RequireArgUnpacking,ProhibitMagicNumbers) | ||||||
99 | sub called_ok (&;@) { | ||||||
100 | 93 | 1 | 4250 | my $coderef = shift; | |||
101 | 93 | 55 | my $called_ok; | ||||
102 | my $test_name; | ||||||
103 | |||||||
104 | # unpack the args | ||||||
105 | 93 | 284 | if ( @_ > 0 && ref $_[0] eq 'CODE' ) { | ||||
106 | 57 | 35 | $called_ok = shift; | ||||
107 | } | ||||||
108 | 93 | 113 | if ( @_ > 0 ) { | ||||
109 | 53 | 44 | $test_name = shift; | ||||
110 | } | ||||||
111 | |||||||
112 | 93 | 78 | $Test::Mocha::Mock::num_method_calls = 0; | ||||
113 | 93 | 131 | my $method_call = get_method_call($coderef); | ||||
114 | |||||||
115 | ## no critic (ProhibitAmpersandSigils) | ||||||
116 | 90 | 68 | local $Test::Builder::Level = $Test::Builder::Level + 1; | ||||
117 | 90 | 121 | $called_ok ||= ×(1); # default if no times() is specified | ||||
118 | 90 | 93 | $called_ok->( $method_call, $test_name ); | ||||
119 | 90 | 151 | return; | ||||
120 | } | ||||||
121 | ## use critic | ||||||
122 | |||||||
123 | ## no critic (ProhibitBuiltinHomonyms) | ||||||
124 | sub times ($) { | ||||||
125 | 80 | 1 | 1817 | my ($n) = @_; | |||
126 | 80 | 109 | croak 'times() must be given a number' | ||||
127 | unless Num->check($n); | ||||||
128 | |||||||
129 | return sub { | ||||||
130 | 79 | 49 | my ( $method_call, $test_name ) = @_; | ||||
131 | 79 | 147 | Test::Mocha::CalledOk::Times->test( $method_call, $n, $test_name ); | ||||
132 | 79 | 684 | }; | ||||
133 | } | ||||||
134 | ## use critic | ||||||
135 | |||||||
136 | sub atleast ($) { | ||||||
137 | 4 | 1 | 861 | my ($n) = @_; | |||
138 | 4 | 5 | croak 'atleast() must be given a number' | ||||
139 | unless Num->check($n); | ||||||
140 | |||||||
141 | return sub { | ||||||
142 | 3 | 4 | my ( $method_call, $test_name ) = @_; | ||||
143 | 3 | 8 | Test::Mocha::CalledOk::AtLeast->test( $method_call, $n, $test_name ); | ||||
144 | 3 | 29 | }; | ||||
145 | } | ||||||
146 | |||||||
147 | sub atmost ($) { | ||||||
148 | 4 | 1 | 794 | my ($n) = @_; | |||
149 | 4 | 7 | croak 'atmost() must be given a number' | ||||
150 | unless Num->check($n); | ||||||
151 | |||||||
152 | return sub { | ||||||
153 | 3 | 3 | my ( $method_call, $test_name ) = @_; | ||||
154 | 3 | 9 | Test::Mocha::CalledOk::AtMost->test( $method_call, $n, $test_name ); | ||||
155 | 3 | 29 | }; | ||||
156 | } | ||||||
157 | |||||||
158 | sub between ($$) { | ||||||
159 | 7 | 1 | 1465 | my ( $lower, $upper ) = @_; | |||
160 | 7 | 10 | croak 'between() must be given 2 numbers in ascending order' | ||||
161 | unless NumRange->check( [ $lower, $upper ] ); | ||||||
162 | |||||||
163 | return sub { | ||||||
164 | 5 | 3 | my ( $method_call, $test_name ) = @_; | ||||
165 | 5 | 15 | Test::Mocha::CalledOk::Between->test( $method_call, [ $lower, $upper ], | ||||
166 | $test_name ); | ||||||
167 | 5 | 49 | }; | ||||
168 | } | ||||||
169 | |||||||
170 | sub inspect (&) { | ||||||
171 | 7 | 1 | 928 | my ($coderef) = @_; | |||
172 | |||||||
173 | 7 | 9 | $Test::Mocha::Mock::num_method_calls = 0; | ||||
174 | 7 | 10 | my $method_call = get_method_call($coderef); | ||||
175 | return | ||||||
176 | 30 5 | 33 5 | grep { $method_call->satisfied_by($_) } | ||||
177 | 5 | 3 | @{ $method_call->invocant->__calls }; | ||||
178 | } | ||||||
179 | |||||||
180 | sub inspect_all ($) { | ||||||
181 | 2 | 1 | 699 | my ($mock) = @_; | |||
182 | |||||||
183 | 2 | 5 | croak 'inspect_all() must be given a mock object' | ||||
184 | if !MockType->check($mock); | ||||||
185 | |||||||
186 | 1 1 | 1 3 | return @{ $mock->{calls} }; | ||||
187 | } | ||||||
188 | |||||||
189 | sub clear (@) { | ||||||
190 | 3 | 1 | 928 | my @mocks = @_; | |||
191 | |||||||
192 | ## no critic (ProhibitBooleanGrep) | ||||||
193 | 3 | 8 | croak 'clear() must be given mock objects only' | ||||
194 | 3 | 113 | if !@mocks || grep { !MockType->check($_) } @mocks; | ||||
195 | ## use critic | ||||||
196 | |||||||
197 | 1 2 | 3 4 | @{ $_->__calls } = () foreach @mocks; | ||||
198 | |||||||
199 | 1 | 2 | return; | ||||
200 | } | ||||||
201 | |||||||
202 | ## no critic (NamingConventions::Capitalization) | ||||||
203 | sub SlurpyArray () { | ||||||
204 | # uncoverable pod | ||||||
205 | 10 | 0 | 33 | return slurpy(ArrayRef); | |||
206 | } | ||||||
207 | |||||||
208 | sub SlurpyHash () { | ||||||
209 | # uncoverable pod | ||||||
210 | 3 | 0 | 10 | return slurpy(HashRef); | |||
211 | } | ||||||
212 | ## use critic | ||||||
213 | |||||||
214 | sub class_mock { | ||||||
215 | 3 | 1 | 85579 | my ($mocked_class) = @_; | |||
216 | |||||||
217 | 3 | 9 | my $module_file = join( q{/}, split q{::}, $mocked_class ) . '.pm'; | ||||
218 | 3 | 4 | my $caller_pkg = caller; | ||||
219 | 12 12 12 | 12115 11 1176 | no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict) | ||||
220 | |||||||
221 | # make sure the real module is not already loaded | ||||||
222 | 3 | 111 | croak "Package '$mocked_class' is already loaded so it cannot be mocked" | ||||
223 | 3 | 2 | if defined ${ $caller_pkg . '::INC' }{$module_file}; | ||||
224 | |||||||
225 | # check if package has already been mocked | ||||||
226 | 2 | 64 | croak "Package '$mocked_class' is already mocked" | ||||
227 | 2 | 1 | if defined *{ $mocked_class . '::AUTOLOAD' }{CODE}; | ||||
228 | |||||||
229 | 1 | 3 | my $mock = mock($mocked_class); | ||||
230 | |||||||
231 | 1 | 3 | *{ $mocked_class . '::AUTOLOAD' } = sub { | ||||
232 | 16 | 144 | my ($method) = extract_method_name( our $AUTOLOAD ); | ||||
233 | 16 | 55 | $mock->$method(@_); | ||||
234 | 1 | 3 | }; | ||||
235 | 1 | 2 | return $mock; | ||||
236 | } | ||||||
237 | |||||||
238 | 1; | ||||||
239 |