File Coverage

File:blib/lib/Test/Mocha/Mock.pm
Coverage:100.0%

linestmtbrancondsubpodtimecode
1package 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
14our $AUTOLOAD;
15
16# Lookup table of classes for which mock isa() should return false
17my %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
22my %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
53sub __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
67sub __mocked_class {
68
260
148
    my ($self) = @_;
69
260
249
    return $self->{mocked_class};
70}
71
72sub 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
115sub 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
132sub 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
146sub 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
157sub 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
1661;