File Coverage

blib/lib/LWPx/Record/DataSection.pm

Criterion	Covered	Total	%
statement	68	113	60.1
branch	10	32	31.2
condition	4	14	28.5
subroutine	19	22	86.3
pod	1	5	20.0
total	102	186	54.8

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__