| 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; | ||||||