File: | blib/lib/Test/Mocha/Spy.pm |
Coverage: | 95.1% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Test::Mocha::Spy; | ||||||
2 | # ABSTRACT: Spy objects | ||||||
3 | $Test::Mocha::Spy::VERSION = '0.61'; | ||||||
4 | 12 12 12 | 34 12 43 | use parent 'Test::Mocha::SpyBase'; | ||||
5 | 12 12 12 | 470 13 216 | use strict; | ||||
6 | 12 12 12 | 23 10 239 | use warnings; | ||||
7 | |||||||
8 | 12 12 12 | 26 191 463 | use Carp 1.22 'croak'; | ||||
9 | 12 12 12 | 29 10 248 | use Scalar::Util 'blessed'; | ||||
10 | 12 12 12 | 26 12 148 | use Test::Mocha::MethodCall; | ||||
11 | 12 12 12 | 25 8 291 | use Test::Mocha::Util qw( check_slurpy_arg extract_method_name find_caller ); | ||||
12 | 12 12 12 | 23 11 70 | use Types::Standard 'Str'; | ||||
13 | 12 12 12 | 3355 9 35 | use UNIVERSAL::ref; | ||||
14 | |||||||
15 | our $AUTOLOAD; | ||||||
16 | |||||||
17 | # can() should return a reference to C<AUTOLOAD()> for all methods | ||||||
18 | my %DEFAULT_STUBS = ( | ||||||
19 | can => Test::Mocha::MethodStub->new( | ||||||
20 | name => 'can', | ||||||
21 | args => [Str], | ||||||
22 | responses => [ | ||||||
23 | sub { | ||||||
24 | my ( $self, $method_name ) = @_; | ||||||
25 | return if !$self->__object->can($method_name); | ||||||
26 | return sub { | ||||||
27 | $AUTOLOAD = $method_name; | ||||||
28 | goto &AUTOLOAD; | ||||||
29 | }; | ||||||
30 | } | ||||||
31 | ], | ||||||
32 | ), | ||||||
33 | ref => Test::Mocha::MethodStub->new( | ||||||
34 | name => 'ref', | ||||||
35 | args => [], | ||||||
36 | responses => [ | ||||||
37 | sub { | ||||||
38 | my ($self) = @_; | ||||||
39 | return ref( $self->__object ); | ||||||
40 | } | ||||||
41 | ], | ||||||
42 | ), | ||||||
43 | ); | ||||||
44 | |||||||
45 | sub __new { | ||||||
46 | # uncoverable pod | ||||||
47 | 2 | 3 | my ( $class, $object ) = @_; | ||||
48 | 2 | 22 | croak "Can't spy on an unblessed reference" if !blessed $object; | ||||
49 | |||||||
50 | 1 | 8 | my $args = $class->SUPER::__new; | ||||
51 | |||||||
52 | 1 | 1 | $args->{object} = $object; | ||||
53 | 2 | 5 | $args->{stubs} = { | ||||
54 | 1 | 3 | map { $_ => [ $DEFAULT_STUBS{$_} ] } | ||||
55 | keys %DEFAULT_STUBS | ||||||
56 | }; | ||||||
57 | 1 | 3 | return bless $args, $class; | ||||
58 | } | ||||||
59 | |||||||
60 | sub __object { | ||||||
61 | 24 | 220 | my ($self) = @_; | ||||
62 | 24 | 71 | return $self->{object}; | ||||
63 | } | ||||||
64 | |||||||
65 | sub AUTOLOAD { | ||||||
66 | 13 | 42 | my ( $self, @args ) = @_; | ||||
67 | 13 | 21 | check_slurpy_arg(@args); | ||||
68 | |||||||
69 | 13 | 19 | my $method_name = extract_method_name($AUTOLOAD); | ||||
70 | |||||||
71 | # record the method call for verification | ||||||
72 | 13 | 21 | my $method_call = Test::Mocha::MethodCall->new( | ||||
73 | invocant => $self, | ||||||
74 | name => $method_name, | ||||||
75 | args => \@args, | ||||||
76 | caller => [find_caller], | ||||||
77 | ); | ||||||
78 | |||||||
79 | 13 | 30 | if ( $self->CaptureMode ) { | ||||
80 | 1 | 1 | croak( | ||||
81 | sprintf | ||||||
82 | qq{Can't stub object method "%s" because it can't be located via package "%s"}, | ||||||
83 | $method_name, | ||||||
84 | ref( $self->__object ) | ||||||
85 | ) if !$self->__object->can($method_name); | ||||||
86 | |||||||
87 | 0 | 0 | $self->NumMethodCalls( $self->NumMethodCalls + 1 ); | ||||
88 | 0 | 0 | $self->LastMethodCall($method_call); | ||||
89 | 0 | 0 | return; | ||||
90 | } | ||||||
91 | |||||||
92 | # record the method call to allow for verification | ||||||
93 | 12 12 | 8 20 | push @{ $self->__calls }, $method_call; | ||||
94 | |||||||
95 | # find a stub to return a response | ||||||
96 | 12 | 21 | if ( my $stub = $self->__find_stub($method_call) ) { | ||||
97 | 3 | 8 | return $stub->execute_next_response( $self, @args ); | ||||
98 | } | ||||||
99 | |||||||
100 | # delegate the method call to the real object | ||||||
101 | croak( | ||||||
102 | 9 | 11 | sprintf | ||||
103 | qq{Can't call object method "%s" because it can't be located via package "%s"}, | ||||||
104 | $method_name, | ||||||
105 | ref( $self->__object ) | ||||||
106 | ) if !$self->__object->can($method_name); | ||||||
107 | |||||||
108 | 8 | 10 | return $self->__object->$method_name(@args); | ||||
109 | } | ||||||
110 | |||||||
111 | sub isa { | ||||||
112 | # uncoverable pod | ||||||
113 | 2 | 0 | 210 | my ( $self, $class ) = @_; | |||
114 | |||||||
115 | # Handle internal calls from UNIVERSAL::ref::_hook() | ||||||
116 | # when ref($spy) is called | ||||||
117 | 2 | 5 | return 1 if $class eq __PACKAGE__; | ||||
118 | |||||||
119 | 2 | 3 | $AUTOLOAD = 'isa'; | ||||
120 | 2 | 4 | goto &AUTOLOAD; | ||||
121 | } | ||||||
122 | |||||||
123 | sub DOES { | ||||||
124 | # uncoverable pod | ||||||
125 | 16 | 0 | 384 | my ( $self, $role ) = @_; | |||
126 | |||||||
127 | # Handle internal calls from UNIVERSAL::ref::_hook() | ||||||
128 | # when ref($mock) is called | ||||||
129 | 16 | 19 | return 1 if $role eq __PACKAGE__; | ||||
130 | |||||||
131 | 11 | 21 | return if !ref $self; | ||||
132 | |||||||
133 | 2 | 6 | $AUTOLOAD = 'DOES'; | ||||
134 | 2 | 4 | goto &AUTOLOAD; | ||||
135 | } | ||||||
136 | |||||||
137 | sub can { | ||||||
138 | # uncoverable pod | ||||||
139 | 2 | 0 | 742 | my ( $self, $method_name ) = @_; | |||
140 | |||||||
141 | # Handle can('CARP_TRACE') for internal croak()'s (Carp v1.32+) | ||||||
142 | #return if $method_name eq 'CARP_TRACE'; | ||||||
143 | |||||||
144 | 2 | 3 | $AUTOLOAD = 'can'; | ||||
145 | 2 | 3 | goto &AUTOLOAD; | ||||
146 | } | ||||||
147 | |||||||
148 | sub ref { ## no critic (ProhibitBuiltinHomonyms) | ||||||
149 | # uncoverable pod | ||||||
150 | 1 | 0 | 4 | $AUTOLOAD = 'ref'; | |||
151 | 1 | 1 | goto &AUTOLOAD; | ||||
152 | } | ||||||
153 | |||||||
154 | # Don't let AUTOLOAD() handle DESTROY() so that object can be destroyed | ||||||
155 | 1 | 2 | sub DESTROY { } | ||||
156 | |||||||
157 | 1; |