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 | 34 13 291 | use strict; | ||||
5 | 12 12 12 | 29 15 181 | use warnings; | ||||
6 | 12 12 12 | 35 7 40 | use parent 'Test::Mocha::Method'; | ||||
7 | |||||||
8 | sub new { | ||||||
9 | # uncoverable pod | ||||||
10 | 48 | 0 | 210 | my $class = shift; | |||
11 | 48 | 123 | my $self = $class->SUPER::new(@_); | ||||
12 | |||||||
13 | 48 | 474 | $self->{responses} ||= []; # ArrayRef[ CodeRef ] | ||||
14 | |||||||
15 | 48 | 82 | return $self; | ||||
16 | } | ||||||
17 | |||||||
18 | sub __responses { | ||||||
19 | 194 | 95 | my ($self) = @_; | ||||
20 | 194 | 260 | 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 | 24 | my ( $class, $obj ) = @_; | |||
27 | 34 | 77 | $obj->{responses} ||= []; | ||||
28 | 34 | 46 | return bless $obj, $class; | ||||
29 | } | ||||||
30 | |||||||
31 | sub execute_next_response { | ||||||
32 | # uncoverable pod | ||||||
33 | 80 | 0 | 66 | my ( $self, @args ) = @_; | |||
34 | 80 | 57 | my $responses = $self->__responses; | ||||
35 | |||||||
36 | # return undef by default | ||||||
37 | 80 80 | 35 98 | return if @{$responses} == 0; | ||||
38 | |||||||
39 | # shift the next response off the front of the queue | ||||||
40 | # ... except for the last one | ||||||
41 | 77 | 86 | my $response = | ||||
42 | 77 7 | 39 5 | @{$responses} > 1 ? shift( @{$responses} ) : $responses->[0]; | ||||
43 | |||||||
44 | 77 | 113 | return $response->(@args); | ||||
45 | } | ||||||
46 | |||||||
47 | 1; |