File Coverage

blib/lib/LWP/UserAgent/Mockable.pm
Criterion Covered Total %
statement 96 101 95.0
branch 30 36 83.3
condition 5 5 100.0
subroutine 18 18 100.0
pod 6 6 100.0
total 155 166 93.3


line stmt bran cond sub pod time code
1             package LWP::UserAgent::Mockable;
2              
3 11     11   400673 use warnings;
  11         17  
  11         362  
4 11     11   38 use strict;
  11         15  
  11         178  
5              
6 11     11   4024 use Hook::LexWrap;
  11         11535  
  11         36  
7 11     11   825 use LWP::UserAgent;
  11         29307  
  11         247  
8 11     11   4308 use Safe::Isa '$_isa';
  11         3761  
  11         1232  
9 11     11   51 use Storable qw( dclone nstore retrieve );
  11         15  
  11         8844  
10              
11             our $VERSION = '1.18';
12              
13             my $instance = __PACKAGE__->__instance;
14             sub __instance {
15 11     11   15 my ( $class ) = @_;
16              
17 11 50       41 if ( not defined $instance ) {
18 11         45 $instance = bless {
19             action => undef,
20             file => undef,
21             current_request => undef,
22             actions => [],
23             callbacks => {},
24             wrappers => {},
25             }, $class;
26              
27             my $action = defined $ENV{ LWP_UA_MOCK }
28             ? lc $ENV{ LWP_UA_MOCK }
29 11 100       53 : 'passthrough';
30              
31 11         42 $instance->reset( $action, $ENV{ LWP_UA_MOCK_FILE } );
32             }
33              
34 9         298 return $instance;
35             }
36              
37             sub reset {
38 22     22 1 80 my ( $class, $action, $file ) = @_;
39              
40 22 50       25 if ( scalar @{ $instance->{ actions } } ) {
  22         173  
41 0         0 die "Can't reset state whilst pending actions. Need to call finish first";
42             }
43              
44 22 100       72 if ( not defined $action ) {
45 9         18 $action = "passthrough";
46             }
47              
48 22 50       123 if ( $action !~ /^(playback|record|passthrough)/ ) {
49 0         0 die "Action must be one of 'passthrough', 'playback' or 'record'";
50             }
51              
52 22 100 100     98 if ( $action ne 'passthrough' and not defined $file ) {
53 1         16 die "No file defined. Should point to file you wish to record to or playback from";
54             }
55              
56 21         36 $instance->{ wrappers } = {};
57 21         54 $instance->{ action } = $action;
58 21         124 $instance->{ file } = $file;
59 21         27 $instance->{ callbacks } = {};
60              
61 21         45 $instance->__reset;
62             }
63              
64             sub __reset {
65 21     21   28 my ( $self ) = @_;
66              
67             my ( $action, $file, $callbacks, $wrappers )
68 21         29 = @{ $self }{ qw( action file callbacks wrappers ) };
  21         43  
69              
70 21 100       51 if ( $action eq 'playback' ) {
71 5         7 local $Storable::Eval = 1;
72              
73 5         23 $self->{ actions } = retrieve( $file );
74              
75             $wrappers->{ pre } = wrap 'LWP::UserAgent::simple_request',
76             pre => sub {
77 18     18   42563 my ( $wrapped, $request ) = @_;
78              
79 18         20 my $current = shift @{ $self->{ actions } };
  18         39  
80 18 50       43 if ( not defined $current ) {
81 0         0 die "No further HTTP requests exist. You possibly need to re-record the LWP session";
82             }
83              
84 18         26 my $response = $current->{ response };
85              
86 18 100       34 if ( $callbacks->{ playback_validation } ) {
87 3         4 my $mock_request = $current->{ request };
88              
89 3         7 $callbacks->{ playback_validation }( $request, $mock_request );
90             }
91              
92 18 100       112 if ( $callbacks->{ playback }) {
93 1         3 $response = $callbacks->{ playback }( $request, $response );
94              
95 1 50       26 if ( not $response->$_isa( 'HTTP::Response' ) ) {
96 0         0 die "playback callback didn't return an HTTP::Response object";
97             }
98             }
99              
100 18         126 $_[ -1 ] = $response;
101 4         17334 };
102             } else {
103             $wrappers->{ pre } = wrap 'LWP::UserAgent::simple_request',
104             pre => sub {
105 27     27   110473 my ( $wrapped, $request ) = @_;
106              
107 27         64 $self->{ current_request } = $request;
108              
109 27 100       180 if ( $callbacks->{ pre_record } ) {
110 9         25 $_[ -1 ] = $callbacks->{ pre_record }( $request );
111              
112 9 100       391 if ( not $_[ -1 ]->$_isa( 'HTTP::Response' ) ) {
113 3         79 die "pre-record callback didn't return an HTTP::Response object";
114             }
115             }
116 16         102 };
117              
118             # It's intentional that wrap is called separately for this. We want the
119             # post action to always be called, even if the pre-action short-circuits
120             # the request. Otherwise, would need to duplicate the storing logic.
121             # This does mean that, when both pre- and post-record callbacks are being
122             # used, that the post-callback will take precedence.
123              
124             $wrappers->{ post } = wrap 'LWP::UserAgent::simple_request',
125             post => sub {
126 24     24   1233241 my $response = $_[ -1 ];
127 24 100       129 if ( $callbacks->{ record }) {
128             $response = $callbacks->{ record }(
129             $self->{ current_request },
130 9         46 $response
131             );
132              
133 9 100       225 if ( not $response->$_isa( 'HTTP::Response' ) ) {
134 3         91 die "record callback didn't return an HTTP::Response object";
135             }
136             }
137              
138 21 100       157 if ( $action eq 'record' ) {
139 13         23 local $Storable::Eval = 1;
140 13         22 local $Storable::Deparse = 1;
141              
142             my $cloned = dclone {
143             request => $self->{ current_request },
144 13         850 response => $response
145             };
146              
147 13         1085 push @{ $self->{ actions } }, $cloned;
  13         89  
148             }
149 16         613 };
150             }
151             }
152              
153             sub finished {
154 9     9 1 6605 my ( $class ) = @_;
155              
156 9         23 my $action = $instance->{ action };
157              
158 9 100 100     65 if ( $action eq 'record' ) {
    50          
159 3         31 local $Storable::Deparse = 1;
160 3         6 local $Storable::Eval = 1;
161              
162 3         20 nstore $instance->{ actions }, $instance->{ file };
163 4         14 } elsif ( $action eq 'playback' and scalar @{ $instance->{ actions } } ) {
164 0         0 warn "Not all HTTP requests have been played back. You possibly need to re-record the LWP session";
165             }
166              
167 9         1535 $instance->{ actions } = [];
168 9         114 $instance->{ action } = 'passthrough';
169 9         19 $instance->{ file } = undef;
170              
171 9         40 $instance->reset;
172             }
173              
174             sub set_playback_callback {
175 2     2 1 12522 my ( $class, $cb ) = @_;
176              
177 2         7 $instance->__set_cb( playback => $cb );
178             }
179              
180             sub set_record_callback {
181 15     15 1 5416 my ( $class, $cb ) = @_;
182              
183 15         45 $instance->__set_cb( record => $cb );
184             }
185              
186             sub set_record_pre_callback {
187 12     12 1 4209 my ( $class, $cb ) = @_;
188              
189 12         35 $instance->__set_cb( pre_record => $cb );
190             }
191              
192             sub set_playback_validation_callback {
193 1     1 1 739 my ( $class, $cb ) = @_;
194              
195 1         3 $instance->__set_cb( playback_validation => $cb );
196             }
197              
198             sub __set_cb {
199 30     30   44 my ( $self, $type, $cb ) = @_;
200              
201 30         83 $self->{ callbacks }{ $type } = $cb;
202             }
203              
204             1;
205              
206             __END__