| 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 | 25 10 28 | use parent 'Test::Mocha::SpyBase'; | ||||
| 5 | 12 12 12 | 292 9 190 | use strict; | ||||
| 6 | 12 12 12 | 23 10 126 | use warnings; | ||||
| 7 | |||||||
| 8 | 12 12 12 | 4522 22 169 | use Test::Mocha::MethodCall; | ||||
| 9 | 12 12 12 | 4271 16 188 | use Test::Mocha::MethodStub; | ||||
| 10 | 12 12 12 | 29 10 353 | use Test::Mocha::Util qw( check_slurpy_arg extract_method_name find_caller ); | ||||
| 11 | 12 12 12 | 25 11 31 | use Types::Standard 'Str'; | ||||
| 12 | 12 12 12 | 6628 887451 47 | 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 | 37 | my ( $class, $mocked_class ) = @_; | ||||
| 56 | |||||||
| 57 | 33 | 111 | my $args = $class->SUPER::__new; | ||||
| 58 | |||||||
| 59 | 33 | 39 | $args->{mocked_class} = $mocked_class; | ||||
| 60 | 132 | 191 | $args->{stubs} = { | ||||
| 61 | 33 | 63 | map { $_ => [ $DEFAULT_STUBS{$_} ] } | ||||
| 62 | keys %DEFAULT_STUBS | ||||||
| 63 | }; | ||||||
| 64 | 33 | 95 | return bless $args, $class; | ||||
| 65 | } | ||||||
| 66 | |||||||
| 67 | sub __mocked_class { | ||||||
| 68 | 260 | 151 | my ($self) = @_; | ||||
| 69 | 260 | 220 | return $self->{mocked_class}; | ||||
| 70 | } | ||||||
| 71 | |||||||
| 72 | sub AUTOLOAD { | ||||||
| 73 | 267 | 18951 | my ( $self, @args ) = @_; | ||||
| 74 | 267 | 368 | check_slurpy_arg(@args); | ||||
| 75 | |||||||
| 76 | 260 | 295 | my $method_name = extract_method_name($AUTOLOAD); | ||||
| 77 | |||||||
| 78 | # If a class method or module function, then transform method name | ||||||
| 79 | 260 | 273 | my $mocked_class = $self->__mocked_class; | ||||
| 80 | 260 | 275 | if ($mocked_class) { | ||||
| 81 | 16 | 16 | if ( $args[0] eq $mocked_class ) { | ||||
| 82 | 9 | 4 | shift @args; | ||||
| 83 | 9 | 13 | $method_name = "${mocked_class}->${method_name}"; | ||||
| 84 | } | ||||||
| 85 | else { | ||||||
| 86 | 7 | 8 | $method_name = "${mocked_class}::${method_name}"; | ||||
| 87 | } | ||||||
| 88 | } | ||||||
| 89 | |||||||
| 90 | 260 | 377 | 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 | 418 | if ( $self->CaptureMode ) { | ||||
| 98 | 131 | 180 | $self->NumMethodCalls( $self->NumMethodCalls + 1 ); | ||||
| 99 | 131 | 195 | $self->LastMethodCall($method_call); | ||||
| 100 | 131 | 197 | return; | ||||
| 101 | } | ||||||
| 102 | |||||||
| 103 | # record the method call to allow for verification | ||||||
| 104 | 129 129 | 74 181 | push @{ $self->__calls }, $method_call; | ||||
| 105 | |||||||
| 106 | # find a stub to return a response | ||||||
| 107 | 129 | 199 | if ( my $stub = $self->__find_stub($method_call) ) { | ||||
| 108 | 56 | 74 | return $stub->execute_next_response( $self, @args ); | ||||
| 109 | } | ||||||
| 110 | 73 | 106 | return; | ||||
| 111 | } | ||||||
| 112 | |||||||
| 113 | # Let AUTOLOAD() handle the UNIVERSAL methods | ||||||
| 114 | |||||||
| 115 | sub isa { | ||||||
| 116 | # uncoverable pod | ||||||
| 117 | 31 | 0 | 434 | my ( $self, $class ) = @_; | |||
| 118 | |||||||
| 119 | # Handle internal calls from UNIVERSAL::ref::_hook() | ||||||
| 120 | # when ref($mock) is called | ||||||
| 121 | 31 | 48 | 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 | 58 | return if exists $NOT_ISA{$class}; | ||||
| 127 | |||||||
| 128 | 5 | 5 | $AUTOLOAD = 'isa'; | ||||
| 129 | 5 | 11 | goto &AUTOLOAD; | ||||
| 130 | } | ||||||
| 131 | |||||||
| 132 | sub DOES { | ||||||
| 133 | # uncoverable pod | ||||||
| 134 | 22 | 0 | 73 | my ( $self, $role ) = @_; | |||
| 135 | |||||||
| 136 | # Handle internal calls from UNIVERSAL::ref::_hook() | ||||||
| 137 | # when ref($mock) is called | ||||||
| 138 | 22 | 30 | return 1 if $role eq __PACKAGE__; | ||||
| 139 | |||||||
| 140 | 13 | 29 | return if !ref $self; | ||||
| 141 | |||||||
| 142 | 4 | 13 | $AUTOLOAD = 'DOES'; | ||||
| 143 | 4 | 8 | goto &AUTOLOAD; | ||||
| 144 | } | ||||||
| 145 | |||||||
| 146 | sub can { | ||||||
| 147 | # uncoverable pod | ||||||
| 148 | 17 | 0 | 1280 | my ( $self, $method_name ) = @_; | |||
| 149 | |||||||
| 150 | # Handle can('CARP_TRACE') for internal croak()'s (Carp v1.32+) | ||||||
| 151 | 17 | 419 | return if $method_name eq 'CARP_TRACE'; | ||||
| 152 | |||||||
| 153 | 4 | 5 | $AUTOLOAD = 'can'; | ||||
| 154 | 4 | 6 | goto &AUTOLOAD; | ||||
| 155 | } | ||||||
| 156 | |||||||
| 157 | sub ref { ## no critic (ProhibitBuiltinHomonyms) | ||||||
| 158 | # uncoverable pod | ||||||
| 159 | 5 | 0 | 10 | $AUTOLOAD = 'ref'; | |||
| 160 | 5 | 6 | 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; | ||||||