File Coverage

blib/lib/Test/VCR/LWP.pm
Criterion Covered Total %
statement 132 133 99.2
branch 15 22 68.1
condition 4 6 66.6
subroutine 31 31 100.0
pod 1 8 12.5
total 183 200 91.5


line stmt bran cond sub pod time code
1             package Test::VCR::LWP;
2              
3 2     2   114771 use strict;
  2         3  
  2         62  
4 2     2   7 use warnings;
  2         2  
  2         44  
5              
6 2     2   1240 use LWP::UserAgent;
  2         92659  
  2         60  
7 2     2   1309 use Data::Dumper;
  2         11909  
  2         183  
8 2     2   991 use FindBin;
  2         1985  
  2         76  
9 2     2   10 use File::Spec;
  2         2  
  2         33  
10              
11 2     2   7 use base 'Exporter';
  2         2  
  2         669  
12             our @EXPORT_OK = qw(withVCR);
13             our $VERSION = '0.3';
14              
15             =head1 NAME
16              
17             Test::VCR::LWP - Record and playback LWP interactions.
18              
19             =head1 VERSION
20              
21             version 0.1
22              
23             =head1 SYNOPSIS
24              
25             withVCR {
26             my $res = $useragent->get('http://metacpan.org/');
27             };
28              
29             =head1 DESCRIPTION
30              
31             Records HTTP transactions done thru LWP to a file and then replays them. Allows
32             your tests suite to be fast, dterministic and accurate.
33              
34             Inspired by (stolen from) L
35              
36             =head1 OO Interface
37            
38             You can use the object oriented interface, but the basic decorator style
39             function interface is recommended.
40              
41             Using the OO interface:
42              
43             my $vcr = Test::VCR::LWP->new(tape => 'mytape.tape');
44            
45             $vcr->run(sub {
46             my $ua = LWP::UserAgent->new;
47             my $res = $ua->get('http://www.perl.org/');
48            
49             if ($_->is_recording) {
50             do_something();
51             }
52             });
53            
54              
55             =cut
56              
57             sub new {
58 24     24 0 45519 my $class = shift;
59 24         262 return bless {@_}, $class;
60             }
61              
62             sub run {
63 20     20 0 8659 my ($self, $code) = @_;
64            
65            
66 20 100       68 if ($self->tape_is_blank) {
67 15         91 $self->record($code);
68             }
69             else {
70 5         32 $self->play($code);
71             }
72             }
73              
74             sub tape_is_blank {
75 20     20 0 29 my ($self) = @_;
76            
77 20         418 return not -s $self->{tape};
78             }
79              
80              
81             sub record {
82 16     16 0 27 my ($self, $code) = @_;
83            
84 16         51 local $self->{is_recording} = 1;
85 16         38 my $original_lwp_request = \&LWP::UserAgent::request;
86            
87 16         50 my $tape = $self->_load_tape;
88            
89 2     2   74 no warnings 'redefine';
  2         5  
  2         535  
90             local *LWP::UserAgent::request = sub {
91 12     12   11118 my ($ua, $req) = @_;
92 12         30 local *LWP::UserAgent::request = $original_lwp_request;
93            
94 12         32 diag("recording http response for " . $req->uri);
95            
96 12         40 my $res = $original_lwp_request->($ua, $req);
97            
98 12         3875162 push(@$tape, {request => $req, response => $res});
99            
100 12         80 return $res;
101 16         106 };
102            
103 16         28 local $_ = $self;
104 16         29 eval {
105 16         37 $code->();
106             };
107 16         1329 my $e = $@;
108            
109 16 50       1606 open(my $fh, '>', $self->{tape}) || die "Couldn't open $self->{tape}: $!\n";
110            
111 16         92 local $Data::Dumper::Purity = 1;
112 16         149 print $fh "use HTTP::Response;\n";
113 16         24 print $fh "use HTTP::Request;\n";
114 16         105 print $fh Data::Dumper::Dumper($tape), "\n";
115 16 50       5362 close($fh) || die "Couldn't close $self->{tape}: $!\n";
116              
117 16 100       570 die $e if $e;
118             }
119              
120             sub play {
121 5     5 0 13 my ($self, $code) = @_;
122            
123 5         25 $self->_load_tape;
124            
125 2     2   11 no warnings 'redefine';
  2         3  
  2         155  
126 5         22 my @match_fields = ('scheme', 'host', 'port', 'path', 'query');
127 5         16 my $original_lwp_request = \&LWP::UserAgent::request;
128            
129             local *LWP::UserAgent::request = sub {
130 5     5   1061 my ($ua, $incoming) = @_;
131            
132 2     2   21 no warnings 'uninitialized';
  2         2  
  2         1125  
133            
134 5         10 REQ: foreach my $episode (@{$self->{requests}}) {
  5         50  
135 6         69 my $recorded = $episode->{request};
136            
137 6 50       21 next REQ if $recorded->method ne $incoming->method;
138            
139 6         147 foreach my $field (@match_fields) {
140 24 100       1140 next REQ if $recorded->uri->$field ne $incoming->uri->$field;
141             }
142            
143 4         401 diag("returning recorded http response for " . $incoming->uri);
144 4         56 return $episode->{response};
145             }
146            
147 1         41 local *LWP::UserAgent::request = $original_lwp_request;
148            
149 1         1 my $res;
150             $self->record(sub {
151 1         2 $res = $ua->request($incoming);
152 1         7 });
153 1         19 return $res;
154 5         43 };
155            
156 5         10 local $_ = $self;
157 5         17 $code->();
158             }
159              
160              
161             sub is_recording {
162 2     2 0 41 return shift->{is_recording};
163             }
164              
165             sub _load_tape {
166 21     21   28 my ($self) = @_;
167            
168 21 100       182 return [] unless -e $self->{tape};
169            
170 6   66     32 return $self->{requests} ||= do {
171 5         29 local $/;
172 5 50       309 open(my $fh, "<", $self->{tape}) || die "Couldn't open $self->{tape}: $!\n";
173 5         136 my $perl = <$fh>;
174 5 50       45 close($fh) || die "Couldn't close $self->{tape}: $!\n";
175            
176 5         10 our $VAR1;
177 5     1   667 eval "$perl";
  1     1   6  
  1     1   2  
  1     1   21  
  1     1   3  
  1     1   1  
  1     1   227  
  1     1   11  
  1     1   4  
  1     1   41  
  1         6  
  1         3  
  1         405  
  1         7  
  1         2  
  1         22  
  1         4  
  1         1  
  1         208  
  1         10  
  1         2  
  1         41  
  1         7  
  1         3  
  1         380  
  1         11  
  1         1  
  1         45  
  1         7  
  1         2  
  1         37  
178            
179 5 50       64 die $@ if $@;
180            
181 5         56 $VAR1;
182             };
183             }
184              
185             sub diag {
186 16 50   16 0 2237 if ($ENV{VCR_DEBUG}) {
187 0         0 warn "# @_\n";
188             }
189             }
190              
191             =head2 withVCR
192              
193             Mocks out any calls to LWP::UserAgent with Test::VCR::LWP. Takes a
194             number of flags which are passed to the VCR constructor, and finally
195             a code ref. For example:
196              
197             withVCR {
198             my $req = $ua->post('http://oo.com/object');
199             isa_ok($req, 'HTTP::Response');
200            
201             if ($_->is_recording) {
202             sleep(5);
203             }
204            
205             my $second = $ua->get('http://oo.com/object/' . $res->id);
206             } tape => 'my_test.tape';
207              
208             Or to have the name of the calling sub define the tape name:
209              
210             withVCR {
211             my $req = $ua->post('http://oo.com/object');
212             isa_ok($req, 'HTTP::Response');
213             };
214              
215             The tape file we be placed in the same directory as the script if no tape
216             argument is given. If this function is called outside of a subroutine, the
217             filename of the current perl script will be used to derive a tape filename.
218              
219             Within the code block, $_ is the current vcr object. The C method
220             might be useful.
221              
222             =cut
223              
224             sub withVCR (&;@) {
225 4     4 1 1630 my $code = shift;
226 4         15 my %args = @_;
227            
228 4   66     22 $args{tape} ||= do {
229 1         7 my $caller = (caller(1))[3];
230 1         11 $caller =~ s/^.*:://;
231 1         78 File::Spec->catfile($FindBin::Bin, "$caller.tape");
232             };
233            
234 4         26 my $vcr = Test::VCR::LWP->new(%args);
235 4         18 $vcr->run($code);
236             }
237              
238             =head1 TODO
239              
240             =over 2
241              
242             =item *
243              
244             The docs are pretty middling at the moment.
245              
246             =back
247              
248             =head1 AUTHORS
249              
250             Chris Reinhardt
251             crein@cpan.org
252              
253             Mark Ng
254             cpan@markng.co.uk
255            
256             =head1 COPYRIGHT
257              
258             This program is free software; you can redistribute
259             it and/or modify it under the same terms as Perl itself.
260              
261             The full text of the license can be found in the
262             LICENSE file included with this module.
263              
264             =head1 SEE ALSO
265              
266             L, perl(1)
267              
268             =cut
269              
270              
271             1;
272             __END__