| 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 | 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 | |||||||
| 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 | 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 | |||||||
| 60 | sub __object { | ||||||
| 61 | 24 | 322 | my ($self) = @_; | ||||
| 62 | 24 | 92 | return $self->{object}; | ||||
| 63 | } | ||||||
| 64 | |||||||
| 65 | sub 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 | |||||||
| 111 | sub 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 | |||||||
| 123 | sub 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 | |||||||
| 137 | sub 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 | |||||||
| 148 | sub 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 | |||||||
| 157 | 1; | ||||||