File: | blib/lib/Test/Mocha/MethodStub.pm |
Coverage: | 95.5% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Test::Mocha::MethodStub; | ||||||
2 | # ABSTRACT: Objects to represent stubbed methods with arguments and responses | ||||||
3 | $Test::Mocha::MethodStub::VERSION = '0.61'; | ||||||
4 | 24 24 24 | 67 18 80 | use parent 'Test::Mocha::Method'; | ||||
5 | 24 24 24 | 819 22 316 | use strict; | ||||
6 | 24 24 24 | 49 22 2443 | use warnings; | ||||
7 | |||||||
8 | sub new { | ||||||
9 | # uncoverable pod | ||||||
10 | 144 | 0 | 669 | my $class = shift; | |||
11 | 144 | 335 | my $self = $class->SUPER::new(@_); | ||||
12 | |||||||
13 | 144 | 1534 | $self->{responses} ||= []; # ArrayRef[ CodeRef ] | ||||
14 | |||||||
15 | 144 | 311 | return $self; | ||||
16 | } | ||||||
17 | |||||||
18 | sub __responses { | ||||||
19 | 186 | 106 | my ($self) = @_; | ||||
20 | 186 | 456 | return $self->{responses}; | ||||
21 | } | ||||||
22 | |||||||
23 | sub cast { | ||||||
24 | # """Convert the type of the given object to this class""" | ||||||
25 | # uncoverable pod | ||||||
26 | 68 | 0 | 52 | my ( $class, $obj ) = @_; | |||
27 | 68 | 178 | $obj->{responses} ||= []; | ||||
28 | 68 | 97 | return bless $obj, $class; | ||||
29 | } | ||||||
30 | |||||||
31 | sub execute_next_response { | ||||||
32 | # uncoverable pod | ||||||
33 | 118 | 0 | 108 | my ( $self, @args ) = @_; | |||
34 | 118 | 96 | my $responses = $self->__responses; | ||||
35 | |||||||
36 | # return undef by default | ||||||
37 | 118 118 | 59 159 | return if @{$responses} == 0; | ||||
38 | |||||||
39 | # shift the next response off the front of the queue | ||||||
40 | # ... except for the last one | ||||||
41 | 114 | 140 | my $response = | ||||
42 | 114 10 | 64 6 | @{$responses} > 1 ? shift( @{$responses} ) : $responses->[0]; | ||||
43 | |||||||
44 | 114 | 157 | return $response->(@args); | ||||
45 | } | ||||||
46 | |||||||
47 | 1; |