File Coverage

File:blib/lib/Test/Mocha/Spy.pm
Coverage:95.1%

linestmtbrancondsubpodtimecode
1package 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
15our $AUTOLOAD;
16
17# can() should return a reference to C<AUTOLOAD()> for all methods
18my %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
45sub __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
60sub __object {
61
24
220
    my ($self) = @_;
62
24
71
    return $self->{object};
63}
64
65sub 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
111sub 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
123sub 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
137sub 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
148sub 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
1571;