File Coverage

File:blib/lib/Test/Mocha.pm
Coverage:99.6%

linestmtbrancondsubpodtimecode
1package 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
20our @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
50sub mock {
51
34
1
959505
    return Test::Mocha::Mock->__new(@_);
52}
53
54sub 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
73sub 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
82sub 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
93sub executes (&) {
94
3
1
9
    my ($callback) = @_;
95
3
5
    return $callback;
96}
97
98## no critic (RequireArgUnpacking,ProhibitMagicNumbers)
99sub 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 ||= &times(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)
124sub 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
136sub 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
147sub 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
158sub 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
170sub 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
180sub 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
189sub 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)
203sub SlurpyArray () {
204    # uncoverable pod
205
10
0
33
    return slurpy(ArrayRef);
206}
207
208sub SlurpyHash () {
209    # uncoverable pod
210
3
0
10
    return slurpy(HashRef);
211}
212## use critic
213
214sub 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
2381;
239