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 E<lt>[email protected]<gt>

=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

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.