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 |