File Coverage

inc/Test/LWP/Recorder.pm
Criterion Covered Total %
statement 68 90 75.5
branch 3 10 30.0
condition 2 4 50.0
subroutine 20 23 86.9
pod 2 2 100.0
total 95 129 73.6


line stmt bran cond sub pod time code
1             #
2             # This file is part of Test-LWP-Recorder
3             #
4             # This software is copyright (c) 2011 by Edward J. Allen III.
5             #
6             # This is free software; you can redistribute it and/or modify it under
7             # the same terms as the Perl 5 programming language system itself.
8             #
9 7     7   16237 use strict; use warnings;
  7     7   14  
  7         174  
  7         32  
  7         14  
  7         379  
10             package Test::LWP::Recorder;
11             {
12             $Test::LWP::Recorder::VERSION = '0.1.1';
13             }
14             BEGIN {
15 7     7   121 $Test::LWP::Recorder::AUTHORITY = 'cpan:EALLENIII';
16             }
17              
18             # ABSTRACT: Create an LWP UserAgent that records and plays back sessions
19              
20 7     7   33 use strict;
  7         11  
  7         125  
21 7     7   33 use warnings;
  7         12  
  7         216  
22 7     7   190 use 5.006;
  7         38  
23 7     7   33 use Carp;
  7         13  
  7         487  
24              
25 7     7   33 use base qw(LWP::UserAgent);
  7         11  
  7         771  
26 7     7   36 use Digest::MD5 qw(md5_hex);
  7         13  
  7         356  
27 7     7   6029 use File::Slurp;
  7         93942  
  7         524  
28 7     7   60 use File::Spec;
  7         13  
  7         201  
29 7     7   34 use List::Util qw(reduce);
  7         14  
  7         615  
30 7     7   36 use HTTP::Status qw(:constants);
  7         11  
  7         3951  
31 7     7   48 use HTTP::Response;
  7         17  
  7         5970  
32              
33             sub new {
34 7     7 1 766 my $class = shift;
35 7         40 my %defaults = (
36             record => 0,
37             cache_dir => 't/LWPCache',
38             filter_params => [],
39             filter_header => [qw(Client-Peer Expires Client-Date Cache-Control)],
40             );
41 7   50     58 my $params = shift || {};
42 7         70 my $self = $class->SUPER::new(@_);
43 7         21419 $self->{_test_options} = { %defaults, %{$params} };
  7         44  
44 7         30 return $self;
45             }
46              
47             sub _filter_param {
48 0     0   0 my ( $self, $key, $value ) = @_;
49 0         0 my %filter = map { $_ => 1 } @{ $self->{_test_options}->{filter_params} };
  0         0  
  0         0  
50 0 0       0 return join q{=}, $key, $filter{$key} ? q{} : $value;
51             }
52              
53             sub _filter_all_params {
54 53     53   3112 my $self = shift;
55 53         87 my $param_string = shift;
56             ## no critic (BuiltinFunctions::ProhibitStringySplit)
57 53         226 my %query = map { ( split q{=} )[ 0, 1 ] } split q{\&}, $param_string;
  344         987  
58             ## use critic;
59              
60             ## CHANGED HERE BY alex@lokku.com FOR NESTORIA
61 53         359 return join("&", map { "$_=$query{$_}" } sort keys %query);
  344         959  
62             ## END CHANGE
63             }
64              
65             sub _get_cache_key {
66 53     53   88 my ( $self, $request ) = @_;
67 53   50     155 my $params = $request->uri->query() || q{};
68              
69             # TODO : Test if it is URL Encoded before blindly assuming.
70 53 50       965 if ( $request->content ) {
71 0 0       0 $params .= ($params) ? q{&} : q{};
72 0         0 $params .= $request->content;
73             }
74              
75 53         695 my $key =
76             $request->method . q{ }
77             . lc( $request->uri->host )
78             . $request->uri->path . q{?}
79             . $self->_filter_all_params($params);
80              
81             #warn "Key is $key";
82             return File::Spec->catfile( $self->{_test_options}->{cache_dir},
83 53         1020 md5_hex($key) );
84             }
85              
86             sub _filter_headers {
87 0     0   0 my ( $self, $response ) = @_;
88 0         0 foreach ( @{ $self->{_test_options}->{filter_header} } ) {
  0         0  
89 0         0 $response->remove_header($_);
90             }
91 0         0 return;
92             }
93              
94             sub request {
95 53     53 1 35264 my ( $self, @original_args ) = @_;
96 53         84 my $request = $original_args[0];
97              
98 53         140 my $key = $self->_get_cache_key($request);
99              
100 53 50       193 if ( $self->{_test_options}->{record} ) {
101 0         0 my $response = $self->SUPER::request(@original_args);
102              
103 0         0 my $cache_response = $response->clone;
104 0         0 $self->_filter_headers($cache_response);
105 0         0 $self->_set_cache( $key, $cache_response );
106              
107 0         0 return $response;
108             }
109              
110 53 50       151 if ( $self->_has_cache($key) ) {
111 53         139 return $self->_get_cache($key);
112             }
113             else {
114 0         0 carp q{Page requested that wasn't recorded: }
115             . $request->uri->as_string;
116 0         0 return HTTP::Response->new(HTTP_NOT_FOUND);
117             }
118             }
119              
120             sub _set_cache {
121 0     0   0 my ( $self, $key, $response ) = @_;
122 0         0 write_file( $key, $response->as_string );
123 0         0 return;
124             }
125              
126             sub _has_cache {
127 53     53   90 my ( $self, $key ) = @_;
128 53         1263 return ( -f $key );
129             }
130              
131             sub _get_cache {
132 53     53   94 my ( $self, $key ) = @_;
133 53         177 my $file = read_file($key);
134 53         5722 return HTTP::Response->parse($file);
135             }
136              
137             1;
138              
139              
140              
141             =pod
142              
143             =for :stopwords Edward Allen J. III cpan testmatrix url annocpan anno bugtracker rt cpants
144             kwalitee diff irc mailto metadata placeholders metacpan motemen UserAgent
145             LWP GPL UA
146              
147             =encoding utf-8
148              
149             =head1 NAME
150              
151             Test::LWP::Recorder - Create an LWP UserAgent that records and plays back sessions
152              
153             =head1 VERSION
154              
155             This document describes v0.1.1 of Test::LWP::Recorder - released September 16, 2013 as part of Test-LWP-Recorder.
156              
157             =head1 SYNOPSIS
158              
159             use Test::LWP::Recorder;
160              
161             my $ua = Test::LWP::Recorder->new({
162             record => $ENV{LWP_RECORD},
163             cache_dir => 't/LWPCache',
164             filter_params => [qw(api_key api_secret password ssn)],
165             filter_header => [qw(Client-Peer Expires Client-Date Cache-Control)],
166             });
167              
168             =head1 DESCRIPTION
169              
170             This module creates a LWP UserAgent that records interactions to a test
171             drive. Setting the "record" parameter to true will cause it to record,
172             otherwise it plays back. It is designed for use in test suites.
173              
174             In the case that a page is requested while in playback mode that was not
175             recorded while in record mode, a 404 will be returned.
176              
177             There is another module that does basically the same thing called
178             L. Please check this out
179             before using this module. It doesn't require a special UA, and stores the
180             data in the DATA section of your file. I use this module (a copy in inc/) for
181             my test suite!
182              
183             =head1 METHODS
184              
185             =head2 new ($options_ref, @lwp_options)
186              
187             This creates a new object. Please see L for more
188             details on available options.
189              
190             The returned object can be used just like any other LWP UserAgent object.
191              
192             =head2 request
193              
194             This is overridden from L so we can do our magic.
195              
196             =head1 PARAMETERS
197              
198             =head2 record
199              
200             Setting this to true puts the agent in record mode. False, in playback. You
201             usually want to set this to an environment variable.
202              
203             =head2 cache_dir
204              
205             This is the location to store the recordings. Filenames are all MD5 digests.
206              
207             =head2 filter_params
208              
209             This is an ArrayRef of POST or GET parameters to remove when recording.
210              
211             The default for this is no filtering.
212              
213             For example (using the $ua created in the synopsis):
214              
215             # This is the request
216             my $resp = $ua->get('http://www.mybank.com?password=IAMSOCOOL&ssn=111-11-1111&method=transfer&destination=CH');
217              
218             # Because password and ssn are filtered, these parameters will be removed
219             # from the object stored. If a tester in the future makes the following
220             # call:
221             #
222              
223             my $resp = $ua->get('http://www.mybank.com?password=GUESSME&ssn=999-11-9999&method=transfer&destination=CH');
224              
225             The cache result from the first will be used.
226              
227             =head2 filter_header
228              
229             A list of response headers not stored.
230              
231             Default is [qw(Client-Peer Expires Client-Date Cache-Control)];
232              
233             =head1 DIAGNOSTICS
234              
235             =head2 Page requested that wasn't recorded
236              
237             A page was requested while in playback mode that was not recorded in record
238             mode. A 404 object will be returned.
239              
240             =head1 IMPORTANT NOTE
241              
242             Please note that you should always put this in an inc directory in your
243             module when using it as part of a test suite. This is critical because the
244             filenames in the cache may change as new features are added to the module.
245              
246             Feel free to just copy the module file over and include it in your inc
247             (provided that your module uses Perl5, GPL, or Artistic license). If
248             you make any changes to it, please change the version number (the last
249             number).
250              
251             =head1 ACKNOWLEDGMENTS
252              
253             Thanks to motemen for L which I use to test this
254             module (and bundle in the inc/ directory). It's a great module and a simple
255             approach.
256              
257             =head1 BUGS AND LIMITATIONS
258              
259             This works using a new UserAgent, which may not work for you.
260              
261             Currently Cookies are ignored.
262              
263             The filename scheme is pretty lame.
264              
265             The test suite needs to be extended to include a POST example
266              
267             =head1 SEE ALSO
268              
269             Please see those modules/websites for more information related to this module.
270              
271             =over 4
272              
273             =item *
274              
275             L
276              
277             =item *
278              
279             L
280              
281             =back
282              
283             =head1 SUPPORT
284              
285             =head2 Websites
286              
287             The following websites have more information about this module, and may be of help to you. As always,
288             in addition to those websites please use your favorite search engine to discover more resources.
289              
290             =over 4
291              
292             =item *
293              
294             Search CPAN
295              
296             The default CPAN search engine, useful to view POD in HTML format.
297              
298             L
299              
300             =item *
301              
302             CPAN Testers Dependencies
303              
304             The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution.
305              
306             L
307              
308             =item *
309              
310             CPANTS
311              
312             The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution.
313              
314             L
315              
316             =item *
317              
318             CPAN Testers
319              
320             The CPAN Testers is a network of smokers who run automated tests on uploaded CPAN distributions.
321              
322             L
323              
324             =item *
325              
326             CPAN Testers Matrix
327              
328             The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms.
329              
330             L
331              
332             =back
333              
334             =head2 Email
335              
336             You can email the author of this module at C asking for help with any problems you have.
337              
338             =head2 Bugs / Feature Requests
339              
340             Please report any bugs or feature requests by email to C, or through
341             the web interface at L. You will be automatically notified of any
342             progress on the request by the system.
343              
344             =head2 Source Code
345              
346             The code is open to the world, and available for you to hack on. Please feel free to browse it and play
347             with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull
348             from your repository :)
349              
350             L
351              
352             git clone git://github.com/riemann42/Test-LWP-Recorder.git
353              
354             =head1 AUTHOR
355              
356             Edward Allen
357              
358             =head1 COPYRIGHT AND LICENSE
359              
360             This software is copyright (c) 2011 by Edward J. Allen III.
361              
362             This is free software; you can redistribute it and/or modify it under
363             the same terms as the Perl 5 programming language system itself.
364              
365             =head1 DISCLAIMER OF WARRANTY
366              
367             BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
368             FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT
369             WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER
370             PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND,
371             EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
372             IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
373             PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
374             SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME
375             THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
376              
377             IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
378             WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
379             REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE
380             TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR
381             CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
382             SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
383             RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
384             FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
385             SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
386             DAMAGES.
387              
388             =cut
389              
390              
391             __END__