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
42
12
50
use parent 'Test::Mocha::SpyBase';
5
12
12
12
571
12
254
use strict;
6
12
12
12
33
14
270
use warnings;
7
8
12
12
12
31
229
550
use Carp 1.22 'croak';
9
12
12
12
46
8
311
use Scalar::Util 'blessed';
10
12
12
12
35
11
190
use Test::Mocha::MethodCall;
11
12
12
12
32
6
361
use Test::Mocha::Util qw( check_slurpy_arg extract_method_name find_caller );
12
12
12
12
29
9
82
use Types::Standard 'Str';
13
12
12
12
3951
13
45
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
2
    my ( $class, $object ) = @_;
48
2
22
    croak "Can't spy on an unblessed reference" if !blessed $object;
49
50
1
5
    my $args = $class->SUPER::__new;
51
52
1
2
    $args->{object} = $object;
53
2
5
    $args->{stubs}  = {
54
1
2
        map { $_ => [ $DEFAULT_STUBS{$_} ] }
55          keys %DEFAULT_STUBS
56    };
57
1
2
    return bless $args, $class;
58}
59
60sub __object {
61
24
322
    my ($self) = @_;
62
24
92
    return $self->{object};
63}
64
65sub AUTOLOAD {
66
13
51
    my ( $self, @args ) = @_;
67
13
25
    check_slurpy_arg(@args);
68
69
13
23
    my $method_name = extract_method_name($AUTOLOAD);
70
71    # record the method call for verification
72
13
23
    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
34
    if ( $self->__CaptureMode ) {
80
1
2
        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
7
25
    push @{ $self->__calls }, $method_call;
94
95    # find a stub to return a response
96
12
23
    if ( my $stub = $self->__find_stub($method_call) ) {
97
3
7
        return $stub->execute_next_response( $self, @args );
98    }
99
100    # delegate the method call to the real object
101    croak(
102
9
12
        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
9
    return $self->__object->$method_name(@args);
109}
110
111sub isa {
112    # uncoverable pod
113
2
0
245
    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
5
    goto &AUTOLOAD;
121}
122
123sub DOES {
124    # uncoverable pod
125
16
0
490
    my ( $self, $role ) = @_;
126
127    # Handle internal calls from UNIVERSAL::ref::_hook()
128    # when ref($mock) is called
129
16
23
    return 1 if $role eq __PACKAGE__;
130
131
11
33
    return if !ref $self;
132
133
2
7
    $AUTOLOAD = 'DOES';
134
2
4
    goto &AUTOLOAD;
135}
136
137sub can {
138    # uncoverable pod
139
2
0
995
    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
4
    goto &AUTOLOAD;
146}
147
148sub ref {  ## no critic (ProhibitBuiltinHomonyms)
149           # uncoverable pod
150
1
0
4
    $AUTOLOAD = 'ref';
151
1
6
    goto &AUTOLOAD;
152}
153
154# Don't let AUTOLOAD() handle DESTROY() so that object can be destroyed
155
1
1
sub DESTROY { }
156
1571;