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>motemen@gmail.comE<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