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 | 28 8 30 | use parent 'Test::Mocha::SpyBase'; | ||||
5 | 12 12 12 | 348 12 226 | use strict; | ||||
6 | 12 12 12 | 29 14 167 | use warnings; | ||||
7 | |||||||
8 | 12 12 12 | 5153 19 184 | use Test::Mocha::MethodCall; | ||||
9 | 12 12 12 | 4587 17 199 | use Test::Mocha::MethodStub; | ||||
10 | 12 12 12 | 30 12 370 | use Test::Mocha::Util qw( check_slurpy_arg extract_method_name find_caller ); | ||||
11 | 12 12 12 | 28 8 34 | use Types::Standard 'Str'; | ||||
12 | 12 12 12 | 7034 999373 60 | use UNIVERSAL::ref; | ||||
13 | |||||||
14 | our $AUTOLOAD; | ||||||
15 | |||||||
16 | # Lookup table of classes for which mock isa() should return false | ||||||
17 | my %NOT_ISA = | ||||||
18 | map { $_ => undef } ( 'Type::Tiny', 'Moose::Meta::TypeConstraint', ); | ||||||
19 | |||||||
20 | # By default, isa(), DOES() and does() should return true for everything, and | ||||||
21 | # can() should return a reference to C<AUTOLOAD()> for all methods | ||||||
22 | my %DEFAULT_STUBS = ( | ||||||
23 | isa => Test::Mocha::MethodStub->new( | ||||||
24 | name => 'isa', | ||||||
25 | args => [Str], | ||||||
26 | responses => [ sub { 1 } ], | ||||||
27 | ), | ||||||
28 | DOES => Test::Mocha::MethodStub->new( | ||||||
29 | name => 'DOES', | ||||||
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 | can => Test::Mocha::MethodStub->new( | ||||||
39 | name => 'can', | ||||||
40 | args => [Str], | ||||||
41 | responses => [ | ||||||
42 | sub { | ||||||
43 | my ( $self, $method_name ) = @_; | ||||||
44 | return sub { | ||||||
45 | $AUTOLOAD = $method_name; | ||||||
46 | goto &AUTOLOAD; | ||||||
47 | }; | ||||||
48 | } | ||||||
49 | ], | ||||||
50 | ), | ||||||
51 | ); | ||||||
52 | |||||||
53 | sub __new { | ||||||
54 | # uncoverable pod | ||||||
55 | 33 | 41 | my ( $class, $mocked_class ) = @_; | ||||
56 | |||||||
57 | 33 | 117 | my $args = $class->SUPER::__new; | ||||
58 | |||||||
59 | 33 | 44 | $args->{mocked_class} = $mocked_class; | ||||
60 | 132 | 190 | $args->{stubs} = { | ||||
61 | 33 | 60 | map { $_ => [ $DEFAULT_STUBS{$_} ] } | ||||
62 | keys %DEFAULT_STUBS | ||||||
63 | }; | ||||||
64 | 33 | 95 | return bless $args, $class; | ||||
65 | } | ||||||
66 | |||||||
67 | sub __mocked_class { | ||||||
68 | 260 | 148 | my ($self) = @_; | ||||
69 | 260 | 249 | return $self->{mocked_class}; | ||||
70 | } | ||||||
71 | |||||||
72 | sub AUTOLOAD { | ||||||
73 | 267 | 18739 | my ( $self, @args ) = @_; | ||||
74 | 267 | 381 | check_slurpy_arg(@args); | ||||
75 | |||||||
76 | 260 | 314 | my $method_name = extract_method_name($AUTOLOAD); | ||||
77 | |||||||
78 | # If a class method or module function, then transform method name | ||||||
79 | 260 | 280 | my $mocked_class = $self->__mocked_class; | ||||
80 | 260 | 283 | if ($mocked_class) { | ||||
81 | 16 | 18 | if ( $args[0] eq $mocked_class ) { | ||||
82 | 9 | 2 | shift @args; | ||||
83 | 9 | 12 | $method_name = "${mocked_class}->${method_name}"; | ||||
84 | } | ||||||
85 | else { | ||||||
86 | 7 | 8 | $method_name = "${mocked_class}::${method_name}"; | ||||
87 | } | ||||||
88 | } | ||||||
89 | |||||||
90 | 260 | 369 | my $method_call = Test::Mocha::MethodCall->new( | ||||
91 | invocant => $self, | ||||||
92 | name => $method_name, | ||||||
93 | args => \@args, | ||||||
94 | caller => [find_caller], | ||||||
95 | ); | ||||||
96 | |||||||
97 | 260 | 434 | if ( $self->__CaptureMode ) { | ||||
98 | 131 | 185 | $self->__NumMethodCalls( $self->__NumMethodCalls + 1 ); | ||||
99 | 131 | 175 | $self->__LastMethodCall($method_call); | ||||
100 | 131 | 224 | return; | ||||
101 | } | ||||||
102 | |||||||
103 | # record the method call to allow for verification | ||||||
104 | 129 129 | 91 179 | push @{ $self->__calls }, $method_call; | ||||
105 | |||||||
106 | # find a stub to return a response | ||||||
107 | 129 | 201 | if ( my $stub = $self->__find_stub($method_call) ) { | ||||
108 | 56 | 79 | return $stub->execute_next_response( $self, @args ); | ||||
109 | } | ||||||
110 | 73 | 105 | return; | ||||
111 | } | ||||||
112 | |||||||
113 | # Let AUTOLOAD() handle the UNIVERSAL methods | ||||||
114 | |||||||
115 | sub isa { | ||||||
116 | # uncoverable pod | ||||||
117 | 31 | 0 | 441 | my ( $self, $class ) = @_; | |||
118 | |||||||
119 | # Handle internal calls from UNIVERSAL::ref::_hook() | ||||||
120 | # when ref($mock) is called | ||||||
121 | 31 | 53 | return 1 if $class eq __PACKAGE__; | ||||
122 | |||||||
123 | # In order to allow mock methods to be called with other mocks as | ||||||
124 | # arguments, mocks cannot have isa() called with type constraints, | ||||||
125 | # which are not allowed as arguments. | ||||||
126 | 27 | 61 | return if exists $NOT_ISA{$class}; | ||||
127 | |||||||
128 | 5 | 7 | $AUTOLOAD = 'isa'; | ||||
129 | 5 | 14 | goto &AUTOLOAD; | ||||
130 | } | ||||||
131 | |||||||
132 | sub DOES { | ||||||
133 | # uncoverable pod | ||||||
134 | 22 | 0 | 93 | my ( $self, $role ) = @_; | |||
135 | |||||||
136 | # Handle internal calls from UNIVERSAL::ref::_hook() | ||||||
137 | # when ref($mock) is called | ||||||
138 | 22 | 39 | return 1 if $role eq __PACKAGE__; | ||||
139 | |||||||
140 | 13 | 33 | return if !ref $self; | ||||
141 | |||||||
142 | 4 | 18 | $AUTOLOAD = 'DOES'; | ||||
143 | 4 | 10 | goto &AUTOLOAD; | ||||
144 | } | ||||||
145 | |||||||
146 | sub can { | ||||||
147 | # uncoverable pod | ||||||
148 | 17 | 0 | 1278 | my ( $self, $method_name ) = @_; | |||
149 | |||||||
150 | # Handle can('CARP_TRACE') for internal croak()'s (Carp v1.32+) | ||||||
151 | 17 | 436 | return if $method_name eq 'CARP_TRACE'; | ||||
152 | |||||||
153 | 4 | 6 | $AUTOLOAD = 'can'; | ||||
154 | 4 | 7 | goto &AUTOLOAD; | ||||
155 | } | ||||||
156 | |||||||
157 | sub ref { ## no critic (ProhibitBuiltinHomonyms) | ||||||
158 | # uncoverable pod | ||||||
159 | 5 | 0 | 10 | $AUTOLOAD = 'ref'; | |||
160 | 5 | 8 | goto &AUTOLOAD; | ||||
161 | } | ||||||
162 | |||||||
163 | # Don't let AUTOLOAD() handle DESTROY() so that object can be destroyed | ||||||
164 | 1 | 1 | sub DESTROY { } | ||||
165 | |||||||
166 | 1; |