| File: | blib/lib/Test/Mocha.pm |
| Coverage: | 99.6% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package Test::Mocha; | ||||||
| 2 | # ABSTRACT: Test Spy/Stub Framework | ||||||
| 3 | $Test::Mocha::VERSION = '0.61'; | ||||||
| 4 | |||||||
| 5 | 12 12 12 | 1313013 10 229 | use strict; | ||||
| 6 | 12 12 12 | 29 9 156 | use warnings; | ||||
| 7 | |||||||
| 8 | 12 12 12 | 25 19 421 | use Carp 'croak'; | ||||
| 9 | 12 12 12 | 26 9 162 | use Exporter 'import'; | ||||
| 10 | 12 12 12 | 25 7 340 | use Scalar::Util 'blessed'; | ||||
| 11 | 12 12 12 | 4535 16 140 | use Test::Mocha::CalledOk::Times; | ||||
| 12 | 12 12 12 | 4249 15 135 | use Test::Mocha::CalledOk::AtLeast; | ||||
| 13 | 12 12 12 | 4166 18 139 | use Test::Mocha::CalledOk::AtMost; | ||||
| 14 | 12 12 12 | 4182 15 136 | use Test::Mocha::CalledOk::Between; | ||||
| 15 | 12 12 12 | 4112 37 206 | use Test::Mocha::Mock; | ||||
| 16 | 12 12 12 | 6011 14 214 | use Test::Mocha::Spy; | ||||
| 17 | 12 12 12 | 34 10 69 | use Test::Mocha::Types 'NumRange', Mock => { -as => 'MockType' }; | ||||
| 18 | 12 12 12 | 3607 10 289 | use Test::Mocha::Util qw( extract_method_name ); | ||||
| 19 | 12 12 12 | 25 9 25 | use Types::Standard qw( ArrayRef HashRef Num slurpy ); | ||||
| 20 | |||||||
| 21 | our @EXPORT = qw( | ||||||
| 22 | mock | ||||||
| 23 | spy | ||||||
| 24 | class_mock | ||||||
| 25 | stub | ||||||
| 26 | returns | ||||||
| 27 | throws | ||||||
| 28 | executes | ||||||
| 29 | called_ok | ||||||
| 30 | times | ||||||
| 31 | atleast | ||||||
| 32 | atmost | ||||||
| 33 | between | ||||||
| 34 | verify | ||||||
| 35 | inspect | ||||||
| 36 | inspect_all | ||||||
| 37 | clear | ||||||
| 38 | SlurpyArray | ||||||
| 39 | SlurpyHash | ||||||
| 40 | ); | ||||||
| 41 | |||||||
| 42 | # croak() messages should not trace back to Mocha modules | ||||||
| 43 | $Carp::Internal{$_}++ foreach qw( | ||||||
| 44 | Test::Mocha | ||||||
| 45 | Test::Mocha::CalledOk | ||||||
| 46 | Test::Mocha::MethodStub | ||||||
| 47 | Test::Mocha::Mock | ||||||
| 48 | Test::Mocha::Spy | ||||||
| 49 | Test::Mocha::Util | ||||||
| 50 | ); | ||||||
| 51 | |||||||
| 52 | sub mock { | ||||||
| 53 | 33 | 1 | 875587 | return Test::Mocha::Mock->__new(@_); | |||
| 54 | } | ||||||
| 55 | |||||||
| 56 | sub spy ($) { | ||||||
| 57 | 2 | 1 | 64879 | return Test::Mocha::Spy->__new(@_); | |||
| 58 | } | ||||||
| 59 | |||||||
| 60 | sub stub (&@) { | ||||||
| 61 | 41 | 1 | 2346 | my ( $coderef, @responses ) = @_; | |||
| 62 | |||||||
| 63 | 41 | 44 | foreach (@responses) { | ||||
| 64 | 39 | 207 | croak 'stub() responses should be supplied using ', | ||||
| 65 | 'returns(), throws() or executes()' | ||||||
| 66 | if ref ne 'CODE'; | ||||||
| 67 | } | ||||||
| 68 | |||||||
| 69 | # add stub to mock | ||||||
| 70 | 40 | 90 | my $method_call = Test::Mocha::Mock->__capture_method_call($coderef); | ||||
| 71 | 34 | 39 | my $stubs = $method_call->invocant->__stubs; | ||||
| 72 | 34 34 | 36 54 | unshift @{ $stubs->{ $method_call->name } }, $method_call; | ||||
| 73 | |||||||
| 74 | # add response to stub | ||||||
| 75 | 34 | 66 | Test::Mocha::MethodStub->cast($method_call); | ||||
| 76 | 34 34 | 17 42 | push @{ $method_call->__responses }, @responses; | ||||
| 77 | 34 | 30 | return; | ||||
| 78 | } | ||||||
| 79 | |||||||
| 80 | sub returns (@) { | ||||||
| 81 | 25 | 1 | 3417 | my (@return_values) = @_; | |||
| 82 | 29 | 81 | return sub { $return_values[0] } | ||||
| 83 | 25 | 87 | if @return_values == 1; | ||||
| 84 | 2 | 7 | return sub { @return_values } | ||||
| 85 | 2 | 5 | if @return_values > 1; | ||||
| 86 | 1 2 | 3 6 | return sub { }; # if @return_values == 0 | ||||
| 87 | } | ||||||
| 88 | |||||||
| 89 | sub throws (@) { | ||||||
| 90 | 10 | 1 | 4072 | my (@exception) = @_; | |||
| 91 | |||||||
| 92 | # check if first arg is a throwable exception | ||||||
| 93 | 1 | 2 | return sub { $exception[0]->throw } | ||||
| 94 | 10 | 41 | if blessed( $exception[0] ) && $exception[0]->can('throw'); | ||||
| 95 | |||||||
| 96 | 9 9 | 22 453 | return sub { croak @exception }; | ||||
| 97 | |||||||
| 98 | } | ||||||
| 99 | |||||||
| 100 | sub executes (&) { | ||||||
| 101 | 3 | 1 | 10 | my ($callback) = @_; | |||
| 102 | 3 | 4 | return $callback; | ||||
| 103 | } | ||||||
| 104 | |||||||
| 105 | ## no critic (RequireArgUnpacking,ProhibitMagicNumbers) | ||||||
| 106 | sub called_ok (&;@) { | ||||||
| 107 | 93 | 1 | 4589 | my $coderef = shift; | |||
| 108 | |||||||
| 109 | 93 | 59 | my $called_ok; | ||||
| 110 | my $test_name; | ||||||
| 111 | 93 | 259 | if ( @_ > 0 && ref $_[0] eq 'CODE' ) { | ||||
| 112 | 57 | 35 | $called_ok = shift; | ||||
| 113 | } | ||||||
| 114 | 93 | 111 | if ( @_ > 0 ) { | ||||
| 115 | 53 | 44 | $test_name = shift; | ||||
| 116 | } | ||||||
| 117 | |||||||
| 118 | 93 | 181 | my $method_call = Test::Mocha::Mock->__capture_method_call($coderef); | ||||
| 119 | |||||||
| 120 | ## no critic (ProhibitAmpersandSigils) | ||||||
| 121 | 90 | 79 | local $Test::Builder::Level = $Test::Builder::Level + 1; | ||||
| 122 | 90 | 120 | $called_ok ||= ×(1); # default if no times() is specified | ||||
| 123 | 90 | 86 | $called_ok->( $method_call, $test_name ); | ||||
| 124 | 90 | 156 | return; | ||||
| 125 | } | ||||||
| 126 | ## use critic | ||||||
| 127 | |||||||
| 128 | ## no critic (ProhibitBuiltinHomonyms) | ||||||
| 129 | sub times ($) { | ||||||
| 130 | 80 | 1 | 1931 | my ($n) = @_; | |||
| 131 | 80 | 116 | croak 'times() must be given a number' | ||||
| 132 | unless Num->check($n); | ||||||
| 133 | |||||||
| 134 | return sub { | ||||||
| 135 | 79 | 42 | my ( $method_call, $test_name ) = @_; | ||||
| 136 | 79 | 153 | Test::Mocha::CalledOk::Times->test( $method_call, $n, $test_name ); | ||||
| 137 | 79 | 721 | }; | ||||
| 138 | } | ||||||
| 139 | ## use critic | ||||||
| 140 | |||||||
| 141 | sub atleast ($) { | ||||||
| 142 | 4 | 1 | 902 | my ($n) = @_; | |||
| 143 | 4 | 8 | croak 'atleast() must be given a number' | ||||
| 144 | unless Num->check($n); | ||||||
| 145 | |||||||
| 146 | return sub { | ||||||
| 147 | 3 | 2 | my ( $method_call, $test_name ) = @_; | ||||
| 148 | 3 | 10 | Test::Mocha::CalledOk::AtLeast->test( $method_call, $n, $test_name ); | ||||
| 149 | 3 | 28 | }; | ||||
| 150 | } | ||||||
| 151 | |||||||
| 152 | sub atmost ($) { | ||||||
| 153 | 4 | 1 | 827 | my ($n) = @_; | |||
| 154 | 4 | 6 | croak 'atmost() must be given a number' | ||||
| 155 | unless Num->check($n); | ||||||
| 156 | |||||||
| 157 | return sub { | ||||||
| 158 | 3 | 3 | my ( $method_call, $test_name ) = @_; | ||||
| 159 | 3 | 8 | Test::Mocha::CalledOk::AtMost->test( $method_call, $n, $test_name ); | ||||
| 160 | 3 | 26 | }; | ||||
| 161 | } | ||||||
| 162 | |||||||
| 163 | sub between ($$) { | ||||||
| 164 | 7 | 1 | 1449 | my ( $lower, $upper ) = @_; | |||
| 165 | 7 | 15 | croak 'between() must be given 2 numbers in ascending order' | ||||
| 166 | unless NumRange->check( [ $lower, $upper ] ); | ||||||
| 167 | |||||||
| 168 | return sub { | ||||||
| 169 | 5 | 5 | my ( $method_call, $test_name ) = @_; | ||||
| 170 | 5 | 14 | Test::Mocha::CalledOk::Between->test( $method_call, [ $lower, $upper ], | ||||
| 171 | $test_name ); | ||||||
| 172 | 5 | 49 | }; | ||||
| 173 | } | ||||||
| 174 | |||||||
| 175 | sub inspect (&) { | ||||||
| 176 | 7 | 1 | 842 | my ($coderef) = @_; | |||
| 177 | 7 | 15 | my $method_call = Test::Mocha::Mock->__capture_method_call($coderef); | ||||
| 178 | |||||||
| 179 | return | ||||||
| 180 | 30 5 | 33 9 | grep { $method_call->__satisfied_by($_) } | ||||
| 181 | 5 | 3 | @{ $method_call->invocant->__calls }; | ||||
| 182 | } | ||||||
| 183 | |||||||
| 184 | sub inspect_all ($) { | ||||||
| 185 | 2 | 1 | 923 | my ($mock) = @_; | |||
| 186 | |||||||
| 187 | 2 | 4 | croak 'inspect_all() must be given a mock object' | ||||
| 188 | if !MockType->check($mock); | ||||||
| 189 | |||||||
| 190 | 1 1 | 1 3 | return @{ $mock->{calls} }; | ||||
| 191 | } | ||||||
| 192 | |||||||
| 193 | sub clear (@) { | ||||||
| 194 | 3 | 1 | 847 | my @mocks = @_; | |||
| 195 | |||||||
| 196 | ## no critic (ProhibitBooleanGrep) | ||||||
| 197 | 3 | 5 | croak 'clear() must be given mock objects only' | ||||
| 198 | 3 | 100 | if !@mocks || grep { !MockType->check($_) } @mocks; | ||||
| 199 | ## use critic | ||||||
| 200 | |||||||
| 201 | 1 2 | 2 4 | @{ $_->__calls } = () foreach @mocks; | ||||
| 202 | |||||||
| 203 | 1 | 2 | return; | ||||
| 204 | } | ||||||
| 205 | |||||||
| 206 | ## no critic (NamingConventions::Capitalization) | ||||||
| 207 | sub SlurpyArray () { | ||||||
| 208 | # uncoverable pod | ||||||
| 209 | 10 | 0 | 32 | return slurpy(ArrayRef); | |||
| 210 | } | ||||||
| 211 | |||||||
| 212 | sub SlurpyHash () { | ||||||
| 213 | # uncoverable pod | ||||||
| 214 | 3 | 0 | 10 | return slurpy(HashRef); | |||
| 215 | } | ||||||
| 216 | ## use critic | ||||||
| 217 | |||||||
| 218 | sub class_mock { | ||||||
| 219 | 3 | 1 | 83361 | my ($mocked_class) = @_; | |||
| 220 | |||||||
| 221 | 3 | 10 | my $module_file = join( q{/}, split q{::}, $mocked_class ) . '.pm'; | ||||
| 222 | 3 | 4 | my $caller_pkg = caller; | ||||
| 223 | 12 12 12 | 11831 7 1105 | no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict) | ||||
| 224 | |||||||
| 225 | # make sure the real module is not already loaded | ||||||
| 226 | 3 | 111 | croak "Package '$mocked_class' is already loaded so it cannot be mocked" | ||||
| 227 | 3 | 2 | if defined ${ $caller_pkg . '::INC' }{$module_file}; | ||||
| 228 | |||||||
| 229 | # check if package has already been mocked | ||||||
| 230 | 2 | 63 | croak "Package '$mocked_class' is already mocked" | ||||
| 231 | 2 | 2 | if defined *{ $mocked_class . '::AUTOLOAD' }{CODE}; | ||||
| 232 | |||||||
| 233 | 1 | 3 | my $mock = mock($mocked_class); | ||||
| 234 | |||||||
| 235 | 1 | 3 | *{ $mocked_class . '::AUTOLOAD' } = sub { | ||||
| 236 | 16 | 110 | my ($method) = extract_method_name( our $AUTOLOAD ); | ||||
| 237 | 16 | 45 | $mock->$method(@_); | ||||
| 238 | 1 | 3 | }; | ||||
| 239 | 1 | 3 | return $mock; | ||||
| 240 | } | ||||||
| 241 | |||||||
| 242 | 1; | ||||||
| 243 | |||||||