File: | blib/lib/Test/Mocha/Mock.pm |
Coverage: | 100.0% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Test::Mocha::Mock; | ||||||
2 | # ABSTRACT: Mock objects | ||||||
3 | $Test::Mocha::Mock::VERSION = '0.61'; | ||||||
4 | 12 12 12 | 31 21 233 | use strict; | ||||
5 | 12 12 12 | 25 11 199 | use warnings; | ||||
6 | |||||||
7 | 12 12 12 | 26 174 353 | use Carp 1.22 'croak'; | ||||
8 | 12 12 12 | 4239 23 225 | use Test::Mocha::MethodCall; | ||||
9 | 12 12 12 | 4946 16 216 | use Test::Mocha::MethodStub; | ||||
10 | 12 12 12 | 38 12 42 | use Test::Mocha::Types qw( Matcher Slurpy ); | ||||
11 | use Test::Mocha::Util | ||||||
12 | 12 12 12 | 3066 13 427 | qw( check_slurpy_arg extract_method_name find_caller find_stub ); | ||||
13 | 12 12 12 | 29 13 34 | use Types::Standard qw( ArrayRef HashRef Str ); | ||||
14 | 12 12 12 | 10388 1051662 70 | use UNIVERSAL::ref; | ||||
15 | |||||||
16 | our $AUTOLOAD; | ||||||
17 | our $num_method_calls = 0; | ||||||
18 | our $last_method_call; | ||||||
19 | our $last_response; | ||||||
20 | |||||||
21 | # Lookup table of classes for which mock isa() should return false | ||||||
22 | my %NOT_ISA = | ||||||
23 | map { $_ => undef } ( 'Type::Tiny', 'Moose::Meta::TypeConstraint', ); | ||||||
24 | |||||||
25 | # By default, isa(), DOES() and does() should return true for everything, and | ||||||
26 | # can() should return a reference to C<AUTOLOAD()> for all methods | ||||||
27 | my %DEFAULT_STUBS = ( | ||||||
28 | isa => Test::Mocha::MethodStub->new( | ||||||
29 | name => 'isa', | ||||||
30 | args => [Str], | ||||||
31 | responses => [ sub { 1 } ], | ||||||
32 | ), | ||||||
33 | DOES => Test::Mocha::MethodStub->new( | ||||||
34 | name => 'DOES', | ||||||
35 | args => [Str], | ||||||
36 | responses => [ sub { 1 } ], | ||||||
37 | ), | ||||||
38 | does => Test::Mocha::MethodStub->new( | ||||||
39 | name => 'does', | ||||||
40 | args => [Str], | ||||||
41 | responses => [ sub { 1 } ], | ||||||
42 | ), | ||||||
43 | can => Test::Mocha::MethodStub->new( | ||||||
44 | name => 'can', | ||||||
45 | args => [Str], | ||||||
46 | responses => [ | ||||||
47 | sub { | ||||||
48 | my ( $self, $method_name ) = @_; | ||||||
49 | return sub { | ||||||
50 | $AUTOLOAD = $method_name; | ||||||
51 | goto &AUTOLOAD; | ||||||
52 | }; | ||||||
53 | } | ||||||
54 | ], | ||||||
55 | ), | ||||||
56 | ); | ||||||
57 | |||||||
58 | sub __new { | ||||||
59 | # uncoverable pod | ||||||
60 | 34 | 38 | my ( $class, $mocked_class ) = @_; | ||||
61 | |||||||
62 | 136 | 239 | my %args = ( | ||||
63 | mocked_class => $mocked_class, | ||||||
64 | calls => [], # ArrayRef[ MethodCall ] | ||||||
65 | stubs => { # $method_name => ArrayRef[ MethodStub ] | ||||||
66 | 34 | 86 | map { $_ => [ $DEFAULT_STUBS{$_} ] } | ||||
67 | keys %DEFAULT_STUBS | ||||||
68 | }, | ||||||
69 | ); | ||||||
70 | 34 | 100 | return bless \%args, $class; | ||||
71 | } | ||||||
72 | |||||||
73 | sub __calls { | ||||||
74 | 496 | 275 | my ($self) = @_; | ||||
75 | 496 | 520 | return $self->{calls}; | ||||
76 | } | ||||||
77 | |||||||
78 | sub __mocked_class { | ||||||
79 | 266 | 163 | my ($self) = @_; | ||||
80 | 266 | 215 | return $self->{mocked_class}; | ||||
81 | } | ||||||
82 | |||||||
83 | sub __stubs { | ||||||
84 | 310 | 171 | my ($self) = @_; | ||||
85 | 310 | 327 | return $self->{stubs}; | ||||
86 | } | ||||||
87 | |||||||
88 | sub AUTOLOAD { | ||||||
89 | 273 | 19351 | my ( $self, @args ) = @_; | ||||
90 | 273 | 342 | check_slurpy_arg(@args); | ||||
91 | |||||||
92 | 266 | 290 | my $method_name = extract_method_name($AUTOLOAD); | ||||
93 | |||||||
94 | # If a class method or module function, then transform method name | ||||||
95 | 266 | 274 | my $mocked_class = $self->__mocked_class; | ||||
96 | 266 | 267 | if ($mocked_class) { | ||||
97 | 16 | 19 | if ( $args[0] eq $mocked_class ) { | ||||
98 | 9 | 6 | shift @args; | ||||
99 | 9 | 12 | $method_name = "${mocked_class}->${method_name}"; | ||||
100 | } | ||||||
101 | else { | ||||||
102 | 7 | 8 | $method_name = "${mocked_class}::${method_name}"; | ||||
103 | } | ||||||
104 | } | ||||||
105 | |||||||
106 | 266 | 171 | undef $last_method_call; | ||||
107 | 266 | 344 | undef $last_response; | ||||
108 | |||||||
109 | 266 | 308 | $num_method_calls++; | ||||
110 | |||||||
111 | # record the method call for verification | ||||||
112 | 266 | 361 | $last_method_call = Test::Mocha::MethodCall->new( | ||||
113 | invocant => $self, | ||||||
114 | name => $method_name, | ||||||
115 | args => \@args, | ||||||
116 | caller => [find_caller], | ||||||
117 | ); | ||||||
118 | 266 266 | 230 248 | push @{ $self->__calls }, $last_method_call; | ||||
119 | |||||||
120 | # find a stub to return a response | ||||||
121 | 266 | 308 | my $stub = find_stub( $self, $last_method_call ); | ||||
122 | 266 | 304 | if ( defined $stub ) { | ||||
123 | # save reference to stub response so it can be restored | ||||||
124 | 80 | 104 | my $responses = $stub->__responses; | ||||
125 | 80 80 | 49 81 | $last_response = $responses->[0] if @{$responses} > 1; | ||||
126 | |||||||
127 | 80 | 108 | return $stub->execute_next_response( $self, @args ); | ||||
128 | } | ||||||
129 | 186 | 253 | return; | ||||
130 | } | ||||||
131 | |||||||
132 | # Let AUTOLOAD() handle the UNIVERSAL methods | ||||||
133 | |||||||
134 | sub isa { | ||||||
135 | # uncoverable pod | ||||||
136 | 34 | 0 | 795 | my ( $self, $class ) = @_; | |||
137 | |||||||
138 | # Handle internal calls from UNIVERSAL::ref::_hook() | ||||||
139 | # when ref($mock) is called | ||||||
140 | 34 | 62 | return 1 if $class eq __PACKAGE__; | ||||
141 | |||||||
142 | # In order to allow mock methods to be called with other mocks as | ||||||
143 | # arguments, mocks cannot have isa() called with type constraints, | ||||||
144 | # which are not allowed as arguments. | ||||||
145 | 30 | 60 | return if exists $NOT_ISA{$class}; | ||||
146 | |||||||
147 | 6 | 6 | $AUTOLOAD = 'isa'; | ||||
148 | 6 | 13 | goto &AUTOLOAD; | ||||
149 | } | ||||||
150 | |||||||
151 | sub DOES { | ||||||
152 | # uncoverable pod | ||||||
153 | 22 | 0 | 82 | my ( $self, $role ) = @_; | |||
154 | |||||||
155 | # Handle internal calls from UNIVERSAL::ref::_hook() | ||||||
156 | # when ref($mock) is called | ||||||
157 | 22 | 38 | return 1 if $role eq __PACKAGE__; | ||||
158 | |||||||
159 | 11 | 30 | return if !ref $self; | ||||
160 | |||||||
161 | 5 | 20 | $AUTOLOAD = 'DOES'; | ||||
162 | 5 | 8 | goto &AUTOLOAD; | ||||
163 | } | ||||||
164 | |||||||
165 | sub can { | ||||||
166 | # uncoverable pod | ||||||
167 | 19 | 0 | 1381 | my ( $self, $method_name ) = @_; | |||
168 | |||||||
169 | # Handle can('CARP_TRACE') for internal croak()'s (Carp v1.32+) | ||||||
170 | 19 | 466 | return if $method_name eq 'CARP_TRACE'; | ||||
171 | |||||||
172 | 5 | 4 | $AUTOLOAD = 'can'; | ||||
173 | 5 | 10 | goto &AUTOLOAD; | ||||
174 | } | ||||||
175 | |||||||
176 | sub ref { ## no critic (ProhibitBuiltinHomonyms) | ||||||
177 | # uncoverable pod | ||||||
178 | 5 | 0 | 10 | $AUTOLOAD = 'ref'; | |||
179 | 5 | 8 | goto &AUTOLOAD; | ||||
180 | } | ||||||
181 | |||||||
182 | # Don't let AUTOLOAD() handle DESTROY() so that object can be destroyed | ||||||
183 | 2 | 4 | sub DESTROY { } | ||||
184 | |||||||
185 | 1; |