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 | 12 12 12 | 31 8 39 | use parent 'Test::Mocha::Method'; | ||||
5 | 12 12 12 | 404 13 153 | use strict; | ||||
6 | 12 12 12 | 23 12 1188 | use warnings; | ||||
7 | |||||||
8 | sub new { | ||||||
9 | # uncoverable pod | ||||||
10 | 72 | 0 | 297 | my $class = shift; | |||
11 | 72 | 149 | my $self = $class->SUPER::new(@_); | ||||
12 | |||||||
13 | 72 | 674 | $self->{responses} ||= []; # ArrayRef[ CodeRef ] | ||||
14 | |||||||
15 | 72 | 141 | return $self; | ||||
16 | } | ||||||
17 | |||||||
18 | sub __responses { | ||||||
19 | 93 | 53 | my ($self) = @_; | ||||
20 | 93 | 218 | return $self->{responses}; | ||||
21 | } | ||||||
22 | |||||||
23 | sub cast { | ||||||
24 | # """Convert the type of the given object to this class""" | ||||||
25 | # uncoverable pod | ||||||
26 | 34 | 0 | 23 | my ( $class, $obj ) = @_; | |||
27 | 34 | 86 | $obj->{responses} ||= []; | ||||
28 | 34 | 45 | return bless $obj, $class; | ||||
29 | } | ||||||
30 | |||||||
31 | sub execute_next_response { | ||||||
32 | # uncoverable pod | ||||||
33 | 59 | 0 | 49 | my ( $self, @args ) = @_; | |||
34 | 59 | 47 | my $responses = $self->__responses; | ||||
35 | |||||||
36 | # return undef by default | ||||||
37 | 59 59 | 24 71 | return if @{$responses} == 0; | ||||
38 | |||||||
39 | # shift the next response off the front of the queue | ||||||
40 | # ... except for the last one | ||||||
41 | 57 | 68 | my $response = | ||||
42 | 57 5 | 35 3 | @{$responses} > 1 ? shift( @{$responses} ) : $responses->[0]; | ||||
43 | |||||||
44 | 57 | 70 | return $response->(@args); | ||||
45 | } | ||||||
46 | |||||||
47 | 1; |