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