package LWPx::Record::DataSection; use strict; use warnings; use LWP::Protocol; use Data::Section::Simple; use B::Hooks::EndOfScope; use HTTP::Response; use CGI::Simple; use CGI::Simple::Cookie; our $VERSION = '0.01'; our $Data; our ($Pkg, $File, $Fh); our $Option = { decode_content => 1, record_response_header => undef, record_request_cookie => undef, record_post_param => undef, append_data_section => !!$ENV{LWPX_RECORD_APPEND_DATA}, }; # From HTTP::Headers our @CommonHeaders = qw( Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade Via Warning Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server Vary WWW-Authenticate Allow Content-Encoding Content-Language Content-Length Content-Location Content-MD5 Content-Range Content-Type Expires Last-Modified ); sub import { my ($class, %args) = @_; while (my ($key, $value) = each %args) { $key =~ s/^-//; $Option->{$key} = $value; } for (my $level = 0; ; $level++) { my ($pkg, $file) = caller($level) or last; next unless $file eq $0; if (defined $Pkg && $pkg ne $Pkg) { require Carp; Carp::croak("only one class can use $class"); } ($Pkg, $File) = ($pkg, $file); on_scope_end { $class->load_data; # append __DATA__ section only when direct import if ($level == 0 && not defined $Data) { __PACKAGE__->append_to_file("\n__DATA__\n\n"); $Data = {}; } LWP::Protocol::Fake->fake; }; return; } require Carp; Carp::croak "Suitable file not found: $0"; } sub load_data { my $class = shift; $Data = Data::Section::Simple->new($Pkg)->get_data_section; return $Data; } sub append_to_file { my $class = shift; return unless $Option->{append_data_section}; unless ($Fh && fileno $Fh) { open $Fh, '>>', $File or die $!; } print $Fh @_; } sub request_to_key { my ($class, $req) = @_; my @keys = ( $req->method, $req->uri ); if (my $cookie_keys = $Option->{record_request_cookie}) { my $cookie = $req->header('Cookie'); my %cookies = CGI::Simple::Cookie->parse($cookie); push @keys, 'Cookie:' . join ',', map { "$_=" . $cookies{$_}->value } grep { $cookies{$_} } sort @$cookie_keys; } if (my $post_params = $Option->{record_post_param}) { my $q = CGI::Simple->new($req->content); push @keys, 'Post:' . join ',', map { my $key = $_; map { "$key=$_" } $q->param($_) } grep { $q->param($_) } sort @$post_params; } return join ' ', @keys; } sub restore_response { my ($class, $req) = @_; my $key = $class->request_to_key($req); if (my $string = $Data && $Data->{$key}) { $string =~ s/\n\z//; utf8::encode $string if utf8::is_utf8 $string; my $res = HTTP::Response->parse($string); $res->request($req); return $res; } } sub store_response { my ($class, $res, $req) = @_; my $key = $class->request_to_key($req); my $res_to_store = $res->clone; if ($Option->{decode_content}) { my $content = $res_to_store->decoded_content; utf8::encode $content if utf8::is_utf8 $content; $res_to_store->content($content); $res_to_store->content_length(length $content); $res_to_store->remove_header('Content-Encoding'); } my $record_response_header = $Option->{record_response_header} || []; unless ($record_response_header eq ':all') { my %header_to_keep = map { uc $_ => 1 } ( @CommonHeaders, @$record_response_header ); foreach ($res_to_store->header_field_names) { $res_to_store->remove_header($_) unless $header_to_keep{ uc $_ }; } } $class->append_to_file("@@ $key\n"); $class->append_to_file($res_to_store->as_string("\n"), "\n"); $Data->{$key} = $res_to_store->as_string; } package # LWP::Protocol::Fake; our $ORIGINAL_LWP_Protocol_create = \&LWP::Protocol::create; sub fake { my $class = shift; no warnings 'redefine'; *LWP::Protocol::create = sub { LWP::Protocol::Fake->new(@_) }; } sub unfake { my $class = shift; no warnings 'redefine'; *LWP::Protocol::create = $ORIGINAL_LWP_Protocol_create; } sub new { my ($class, $scheme, $ua) = @_; bless { scheme => $scheme, ua => $ua, real => &$ORIGINAL_LWP_Protocol_create($scheme, $ua) }, $class; } sub request { my ($self, $request, $proxy, $arg, $size, $timeout) = @_; if (my $res = LWPx::Record::DataSection->restore_response($request)) { return $res; } else { my $res = $self->{real}->request($request, $proxy, $arg, $size, $timeout); LWPx::Record::DataSection->store_response($res, $request); return $res; } } 1; __END__ =head1 NAME LWPx::Record::DataSection - Record/restore LWP response using __DATA__ section =head1 SYNOPSIS use Test::More; use LWPx::Record::DataSection; use LWP::Simple qw($ua); my $res = $ua->get('http://www.example.com/'); # does not access to the internet actually is $res->code, 200; __DATA__ @@ GET http://www.example.com/ HTTP/1.0 200 OK Content-Type: text/html ... # HTTP response =head1 DESCRIPTION LWPx::Record::DataSection overrides LWP::Protocol and creates response object from __DATA__ section. The response should be recorded as below: __DATA__ @@ [method] [url] [raw response] @@ [method] [url] [raw response] ... =head1 RECORDING RESPONSES When LWP try to send request without corresponding data section, LWPx::Record::DataSection allows actual connection and records the response to the test file's __DATA__ section. Example: # test.t use strict; use Test::More; use LWPx::Record::DataSection; use LWP::Simple qw($ua); my $res = $ua->get('http://www.example.com/'); is $res->code, 200; # No __END__ please, LWPx::Record::DataSection confuses __DATA__ Running this test with environment variable LWPX_RECORD_APPEND_DATA=1 appends the actual response to the test file itself, thus produces such: # test.t use strict; use Test::More; use LWPx::Record::DataSection; use LWP::Simple qw($ua); my $res = $ua->get('http://www.example.com/'); is $res->code, 200; # No __END__ please, LWPx::Record::DataSection confuses __DATA__ @@ GET http://www.example.com/ HTTP/1.0 302 Found Connection: Keep-Alive Location: http://www.iana.org/domains/example/ ... @@ GET http://www.iana.org/domains/example/ HTTP/1.1 200 OK ... After that running the test does not require internet connection. =head1 CLASS METHODS =over 4 =item LWPx::Record::DataSection->load_data Load __DATA__ section into $LWPx::Record::DataSection::Data. LWPx::Record::DataSection->import implies this, so if you do not C<< use >> this module, explicitly call this. Example: use Test::Requires 'LWPx::Record::DataSection'; LWPx::Record::DataSection->load_data; =back =head1 OPTIONS You can specify option when C<< use >> this module. use LWPx::Record::DataSection %option; =over 4 =item decode_content => 1 | 0 By default, responses are recorded as decoded so that you will not see unreadable bytes in your file. If this behavior is not desired, turn this option off. =item record_response_header => \@headers | ':all' By default, uncommon headers like "X-Framework" are dropped when recording. Specify this option to record extra headers. =item record_post_param => \@params Use POSTed parameters as extra key. Post keys are recorded as: @@ POST http://localhost/ Post:foo=1,foo=2 =item record_request_cookie => \@keys By default, only request method and request uri are used to identify request. Specify this option to use certain cookie as key. Cookie keys are recorded as: @@ GET http://localhost/ Cookie:foo=1,bar=2 =item append_data_section => $ENV{LWPX_RECORD_APPEND_DATA}; Automatically record responses to __DATA__ section if not recorded. You can specify this by LWPX_RECORD_APPEND_DATA environment variable. =back =head1 CAVEATS If the file contains __END__ section, storing response will not work. L<< LWPx::Record::DataSection >> appends __DATA__ section only files that directly C<< use >> this module. This is to avoid accidents. =head1 AUTHOR motemen Emotemen@gmail.comE =head1 SEE ALSO L<< Data::Section::Simple >>, L<< LWP::Protocol >> =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut