HTTP::WebTest::SelfTest - Helper package for HTTP::WebTest test suite

    use HTTP::WebTest::SelfTest;

# $Id: SelfTest.pm,v 1.8 2003/07/03 11:22:01 m_ilya Exp $

package HTTP::WebTest::SelfTest;

use strict;

use base qw(Exporter);

use vars qw(@EXPORT $HOSTNAME $PORT $URL);

@EXPORT = qw($HOSTNAME $PORT $URL
             abs_url
             check_webtest
             read_file write_file
             generate_testfile canonical_output compare_output
             parse_basic_credentials
             start_webserver stop_webserver);

use Algorithm::Diff qw(diff);
use MIME::Base64;
use URI;

use HTTP::WebTest::Utils qw(find_port start_webserver stop_webserver);

$HOSTNAME = $ENV{TEST_HOSTNAME} || '127.0.0.1';

$PORT = find_port();
die "Can't find free port" unless defined $PORT;

$URL = "http://$HOSTNAME:$PORT/";

sub abs_url {
    my $abs = shift;
    my $rel = shift;

    return URI->new_abs($rel, $abs);
}

sub read_file {
    my $filename = shift;
    my $ignore_errors = shift;

    local *FILE;
    if(open FILE, "< $filename") {
	my $data = join '', <FILE>;
	close FILE;

	return $data;
    } else {
	die "Can't open file '$filename': $!" unless $ignore_errors;
    }

    return '';
}

sub write_file {
    my $file = shift;
    my $data = shift;

    local *FILE;
    open FILE, "> $file" or die "Can't open file '$file': $!";
    print FILE $data;
    close FILE;
}

sub check_webtest {
    my %param = @_;

    my $webtest = $param{webtest};
    my $tests = $param{tests};
    my $opts = $param{opts} || {};

    my $output = '';

    $webtest->run_tests($tests, { %$opts, output_ref => \$output });
    canonical_output(%param, output_ref => \$output);
    compare_output(%param, output_ref => \$output);
}

sub generate_testfile {
    my %param = @_;

    my $file = $param{file};
    my $in_file = $file . '.in';

    # prepare wt script file
    my $data = read_file($in_file);
    $data =~ s/<<SERVER_URL>>/$param{server_url}/g;

    $data = <<WARNING . $data;
# Note: $file is autogenerated from $in_file. DO NOT EDIT $file.
# Your changes will be lost. Edit $in_file instead.

WARNING

    write_file($file, $data);
}

sub canonical_output {
    my %param = @_;

    my $output_ref = $param{output_ref};
    my $out_filter = $param{out_filter};
    my $server_url = $param{server_url};
    my $server_hostname = $param{server_hostname};

    # run test filter if defined
    if(defined $out_filter) {
	$out_filter->($$output_ref);
    }

    # change urls on some canonical in test output
    if(defined $server_url) {
	my $url = abs_url($server_url, '/')->as_string;
	$$output_ref =~ s|\Q$url\E
                                                  |http://http.web.test/|xg;
    }

    # change urls on some canonical in test output
    if(defined $server_hostname) {
	$$output_ref =~ s|http://\Q$server_hostname\E:\d+/
                                                  |http://http.web.test/|xg;
    }
}

sub compare_output {
    my %param = @_;

    my $check_file = $param{check_file};
    my $output2 = ${$param{output_ref}};

    my $output1 = read_file($check_file, 1);
    _print_diff($output1, $output2);
    _ok(($output1 eq $output2) or defined $ENV{TEST_FIX});

    if(defined $ENV{TEST_FIX} and $output1 ne $output2) {
	# special mode for writting test report output files

	write_file($check_file, $output2);
    }
}

# ok compatible with Test and Test::Builder
sub _ok {
    # if Test is already loaded use its ok
    if(Test->can('ok')) {
        @_ = $_[0];
        goto \&Test::ok;
    } else {
        require Test::Builder;
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        Test::Builder->new->ok(@_);
    }
}

# print diff of outputs
sub _print_diff {
    my $output1 = shift;
    my $output2 = shift;

    my @diff = diff([split /\n/, $output1], [split /\n/, $output2]);

    for my $hunk (@diff) {
	for my $diff_str (@$hunk) {
	    printf "%s %03d %s\n", @$diff_str;
	}
    }
}

sub parse_basic_credentials {
    my $credentials = shift;

    return () unless defined $credentials;
    $credentials =~ m|^ \s* Basic \s+ ([A-Za-z0-9+/=]+) \s* $|x;
    my $basic_credentials = $1;
    return () unless defined $basic_credentials;
    my $user_pass = decode_base64($basic_credentials);
    my($user, $password) = $user_pass =~ /^ (.*) : (.*) $/x;
    return () unless defined $password;

    return ($user, $password);
}

1;