The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Test::More;
use HTTP::Proxy::BodyFilter::save;
use File::Temp qw( tempdir );
use File::Spec::Functions;

# a sandbox to play in
my $dir = tempdir( CLEANUP => 1 );

my @errors = (
    [   [ keep_old => 1, timestamp => 1 ] =>
            qr/^Can't timestamp and keep older files at the same time/
    ],
    [ [ status => 200 ] => qr/^status must be an array reference/ ],
    [   [ status => [qw(200 007 )] ] =>
            qr/status must contain only HTTP codes/
    ],
    [ [ filename => 'zlonk' ] => qr/^filename must be a code reference/ ],
);
my @data = (
    'recusandae veritatis illum quos tempor aut quidem',
    'necessitatibus lorem aperiam facere consequuntur incididunt similique'
);
my @d = ( prefix => $dir );    # defaults
my @templates = (

    # args, URL => filename
    [   [@d],
        'http://bam.fr/zok/awk.html' =>
            catfile( $dir, qw(bam.fr zok awk.html) )
    ],
    [   [ @d, multiple => 0 ],
        'http://bam.fr/zok/awk.html' =>
            catfile( $dir, qw(bam.fr zok awk.html) )
    ],
    [   [@d],
        'http://bam.fr/zok/awk.html' =>
            catfile( $dir, qw(bam.fr zok awk.html.1) )
    ],
    [   [ @d, no_host => 1 ],
        'http://bam.fr/zok/awk.html' => catfile( $dir, qw(zok awk.html ) )
    ],
    [   [ @d, no_dirs => 1 ],
        'http://bam.fr/zok/awk.html' => catfile( $dir, qw(bam.fr awk.html) )
    ],
    [   [ @d, no_host => 1, no_dirs => 1 ],
        'http://bam.fr/zok/awk.html' => catfile( $dir, 'awk.html' )
    ],
    [   [ @d, no_dirs => 1 ],
        'http://bam.fr/zok/' => catfile( $dir, qw(bam.fr index.html) )
    ],
    #[ [@d], 'http://bam.fr/zok/' => "$dir/bam.fr/index.html" ],
    [   [ template => "$dir/%p" ],
        'http://bam.fr/pow/zok.html' => catfile( $dir, qw(pow zok.html) )
    ],
    [   [ template => "$dir/%f" ],
        'http://bam.fr/pow/zok.html' => catfile( $dir, 'zok.html' )
    ],
    [   [ template => "$dir/%p" ],
        'http://bam.fr/zam.html?q=pow' => catfile( $dir, 'zam.html' )
    ],
    # Win32 does not accept '?' in file names
    (   [   [ template => "$dir/%P" ],
            'http://bam.fr/zam.html?q=pow' =>
                catfile( $dir, 'zam.html?q=pow' )
        ]
        ) x ( $^O ne 'MSWin32' ),
    [   [ @d, cut_dirs => 2 ],
        'http://bam.fr/a/b/c/d/e.html' =>
            catfile( $dir, qw(bam.fr c d e.html) )
    ],
    [   [ @d, cut_dirs => 2, no_host => 1 ],
        'http://bam.fr/a/b/c/d/e.html' => catfile( $dir, qw(c d e.html) )
    ],
    [   [ @d, cut_dirs => 5, no_host => 1 ],
        'http://bam.fr/a/b/c/d/e.html' => catfile( $dir, 'e.html' )
    ],

    # won't save
    [ [ @d, keep_old => 1 ], 'http://bam.fr/zok/awk.html' => undef ],
);
my @responses = (
    [   [@d],
        'http://bam.fr/a.html' => 200,
        catfile( $dir, qw(bam.fr a.html) )
    ],
    [ [@d], 'http://bam.fr/b.html' => 404, undef ],
    [   [ @d, status => [ 200, 404 ] ],
        'http://bam.fr/c.html' => 404,
        catfile( $dir, qw(bam.fr c.html) )
    ],
);

plan tests => 2 * @errors    # error checking
    + 1                      # simple test
    + 7 * 2                  # filename tests: 2 that save
    + 5 * 2                  # filename tests: 2 that don't
    + 2 * @templates         # all template tests
    + 2 * @responses         # all responses tests
    ;

# some variables
my $proxy = HTTP::Proxy->new( port => 0 );
my ( $filter, $data, $file, $buffer );

# test the save filter
# 1) errors in new
for my $t (@errors) {
    my ( $args, $regex ) = @$t;
    ok( !eval { HTTP::Proxy::BodyFilter::save->new(@$args); 1; },
        "new( @$args ) fails" );
    like( $@, $regex, "Error matches $regex" );
}

# 2) code for filenames
$filter = HTTP::Proxy::BodyFilter::save->new( filename => sub {$file} );
$filter->proxy($proxy);

# simple check
ok( !$filter->will_modify, 'Filter does not modify content' );

# loop on four requests
# two that save, and two that won't
for my $name ( qw( zlonk.pod kayo.html ), undef, '' ) {
    $file = $name ? catfile( $dir, $name ) : $name;

    my $req = HTTP::Request->new( GET => 'http://www.example.com/' );
    ok( my $ok = eval {
            $filter->begin($req);
            1;
        },
        'Initialized filter without error'
    );
    diag $@ if !$ok;

    if ($file) {
        is( $filter->{_hpbf_save_filename}, $file, "Got filename ($file)" );
    }
    else {
        ok( !$filter->{_hpbf_save_filename}, 'No filename' );
    }

    my $filter_fh;
    if ($name) {
        ok( $filter->{_hpbf_save_fh}->opened, 'Filehandle opened' );
        $filter_fh = $filter->{_hpbf_save_fh};
    }
    else {
        ok( !exists $filter->{_hpbf_save_fh}, 'No filehandle' );
    }

    # add some data
    $buffer = '';
    ok( eval {
            $filter->filter( \$data[0], $req, '', \$buffer );
            $filter->filter( \$data[1], $req, '', undef );
            $filter->end();
            1;
        },
        'Filtered data without error'
    );
    diag $@ if $@;

    # file closed now
    ok( !defined $filter->{_hpbf_save_fh}, 'No filehandle' );
    if ($filter_fh) {
        ok( !$filter_fh->opened, 'Filehandle closed' );

        # check the data
        open my $fh, $file or diag "Can't open $file: $!";
        is( join( '', <$fh> ), join( '', @data ), 'All data saved' );
        close $fh;
    }

}

# 3) the multiple templating cases
for my $t (@templates) {
    my ( $args, $url, $filename ) = @$t;
    my $filter = HTTP::Proxy::BodyFilter::save->new(@$args);
    $filter->proxy($proxy);
    my $req = HTTP::Request->new( GET => $url );

    # filter initialisation
    ok( my $ok = eval {
            $filter->begin($req);
            1;
        },
        'Initialized filter without error'
    );
    diag $@ if !$ok;
    my $mesg = defined $filename ? "$url => $filename" : "Won't save $url";
    is( $filter->{_hpbf_save_filename}, $filename, $mesg );
}

# 4) some cases that depend on the response
for my $t (@responses) {
    my ( $args, $url, $status, $filename ) = @$t;
    my $filter = HTTP::Proxy::BodyFilter::save->new(@$args);
    $filter->proxy($proxy);
    my $res = HTTP::Response->new($status);
    $res->request( HTTP::Request->new( GET => $url ) );

    ok( my $ok = eval {
            $filter->begin($res);
            1;
        },
        'Initialized filter without error'
    );
    diag $@ if !$ok;
    if ($filename) {
        is( $filter->{_hpbf_save_filename},
            $filename, "$url ($status) => $filename" );
    }
    else {
        ok( !$filter->{_hpbf_save_filename},
            "$url ($status) => No filename" );
    }
}