#!/usr/bin/perl -w
use strict;
use lib 'inc';
use FindBin;
use IO::Catch;
use File::Temp qw( tempfile );
use vars qw( %tests $_STDOUT_ $_STDERR_ );
use URI::URL;
use LWP::Simple;
# Catch output:
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!;
#tie *STDERR, 'IO::Catch', '_STDERR_' or die $!;
# Make HTML::Display do nothing:
BEGIN {
$ENV{PERL_HTML_DISPLAY_CLASS} = 'HTML::Display::Dump';
delete $ENV{PAGER};
};
use HTML::Display;
BEGIN {
%tests = (
autofill => { requests => 2, lines => [ 'get %s',
'autofill query Fixed foo',
'autofill cat Keep',
'fillout',
'submit' ], location => qr'^%s/formsubmit\?session=1&query=foo&cat=cat_foo&cat=cat_bar$'},
auth => { requests => 1, lines => [ 'auth user password', 'get %s' ], location => qr'^%s/$' },
back => { requests => 2, lines => [ 'get %s','open 0','back' ], location => qr'^%s/$' },
content_save => { requests => 1, lines => [ 'get %s','content tmp.content','eval unlink "tmp.content"'], location => qr'^%s/$' },
comment => { requests => 1, lines => [ '# a comment','get %s','# another comment' ], location => qr'^%s/$' },
eval => { requests => 1, lines => [ 'eval "Hello World"', 'get %s','eval "Goodbye World"' ], location => qr'^%s/$' },
eval_shell => { requests => 1, lines => [ 'get %s', 'eval $self->agent->ct' ], location => qr'^%s/$' },
eval_sub => { requests => 2, lines => [
'# Fill in the "date" field with the current date/time as string',
'eval sub ::custom_today { "20030511" };',
'autofill session Callback ::custom_today',
'autofill query Keep',
'autofill cat Keep',
'get %s',
'fillout',
'eval $self->agent->current_form->value("session")',
'submit',
'content',
], location => qr'^%s/formsubmit\?session=20030511&query=\(empty\)&cat=cat_foo&cat=cat_bar$' },
eval_multiline => { requests => 2,
lines => [ 'get %s',
'autofill query Keep',
'autofill cat Keep',
'fillout',
'submit',
'eval "Hello World ",
"from ",$self->agent->uri',
'content' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)&cat=cat_foo&cat=cat_bar$' },
form_name => { requests => 2, lines => [ 'get %s','form f','submit' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)&cat=cat_foo&cat=cat_bar$'
},
form_num => { requests => 2, lines => [ 'get %s','form 1','submit' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)&cat=cat_foo&cat=cat_bar$'
},
formfiller_chars => { requests => 2,
lines => [ 'eval srand 0',
'autofill cat Keep',
'autofill query Random::Chars size 5 set alpha', 'get %s', 'fillout','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=[a-zA-Z]{5}&cat=cat_foo&cat=cat_bar$' },
formfiller_date => { requests => 2,
lines => [ 'eval srand 0',
'autofill cat Keep',
'autofill query Random::Date string %%Y%%m%%d', 'get %s', 'fillout','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\d{8}&cat=cat_foo&cat=cat_bar$' },
formfiller_default => { requests => 2,
lines => [ 'autofill query Default foo',
'autofill cat Keep',
'get %s', 'fillout','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)&cat=cat_foo&cat=cat_bar$' },
formfiller_fixed => { requests => 2,
lines => [ 'autofill query Fixed foo',
'autofill cat Keep',
'get %s', 'fillout','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=foo&cat=cat_foo&cat=cat_bar$' },
formfiller_keep => { requests => 2,
lines => [ 'autofill query Keep',
'autofill cat Keep',
'get %s', 'fillout','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)&cat=cat_foo&cat=cat_bar' },
formfiller_random => { requests => 2,
lines => [ 'autofill query Random foo',
'autofill cat Keep',
'get %s', 'fillout','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=foo&cat=cat_foo&cat=cat_bar' },
formfiller_re => { requests => 2,
lines => [ 'eval srand 0',
'autofill cat Keep',
'autofill /qu/ Random::Date string %%Y%%m%%d', 'get %s', 'fillout','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\d{8}&cat=cat_foo&cat=cat_bar' },
formfiller_word => { requests => 2,
lines => [ 'eval srand 0',
'autofill cat Keep',
'autofill query Random::Word size 1', 'get %s', 'fillout','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\w+&cat=cat_foo&cat=cat_bar' },
get => { requests => 1, lines => [ 'get %s' ], location => qr'^%s/' },
get_content => { requests => 1, lines => [ 'get %s', 'content' ], location => qr'^%s/' },
get_redirect => { requests => 2, lines => [ 'get %sredirect/startpage' ], location => qr'^%s/startpage' },
get_save => { requests => 4, lines => [ 'get %s','save "/\.save_log_server_test\.tmp$/"' ], location => qr'^%s/' },
get_value_click => { requests => 2, lines => [ 'get %s','value query foo', 'click submit' ], location => qr'^%s/formsubmit\?session=1&query=foo&submit=Go&cat=cat_foo&cat=cat_bar' },
get_value_submit => { requests => 2, lines => [ 'get %s','value query foo', 'submit' ], location => qr'^%s/formsubmit\?session=1&query=foo&cat=cat_foo&cat=cat_bar' },
get_value2_submit => { requests => 2, lines => [
'get %s',
'value query foo',
'value session 2',
'submit'
], location => qr'^%s/formsubmit\?session=2&query=foo&cat=cat_foo&cat=cat_bar' },
interactive_script_creation => { requests => 2,
lines => [ 'eval @::list=qw(foo bar xxx)',
'eval no warnings qw"redefine once"; *WWW::Mechanize::FormFiller::Value::Ask::ask_value = sub { my $value=shift @::list; push @{$_[0]->{shell}->{answers}}, [ $_[1]->name, $value ]; $value }',
'autofill cat Keep',
'get %s',
'fillout',
'submit',
'content' ],
location => qr'^%s/formsubmit\?session=foo&query=bar&cat=cat_foo&cat=cat_bar$' },
open_parm => { requests => 2, lines => [ 'get %s','open 0','content' ], location => qr'^%s/test$' },
open_re => { requests => 2, lines => [ 'get %s','open "Link foo1.save_log_server_test.tmp"','content' ], location => qr'^%s/foo1.save_log_server_test.tmp$' },
open_re2 => { requests => 2, lines => [ 'get %s','open "/foo1/"','content' ], location => qr'^%s/foo1.save_log_server_test.tmp$' },
open_re3 => { requests => 2, lines => [ 'get %s','open "/Link /foo/"','content' ], location => qr'^%s/foo$' },
open_re4 => { requests => 2, lines => [ 'get %s','open "/Link \/foo/"','content' ], location => qr'^%s/foo$' },
open_re5 => { requests => 2, lines => [ 'get %s','open "/Link /$/"','content' ], location => qr'^%s/slash_end$' },
open_re6 => { requests => 2, lines => [ 'get %s','open "/^/Link$/"','content' ], location => qr'^%s/slash_front$' },
open_re7 => { requests => 2, lines => [ 'get %s','open "/^/Link in slashes//"','content' ], location => qr'^%s/slash_both$' },
reload => { requests => 2, lines => [ 'get %s','reload','content' ], location => qr'^%s/$' },
reload_2 => { requests => 3, lines => [ 'get %s','open "/Link \/foo/"','reload','content' ], location => qr'^%s/foo$' },
tick => { requests => 2,
lines => [ 'get %s','tick cat cat_foo','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)&cat=cat_foo&cat=cat_bar$' },
tick_all => { requests => 2,
lines => [ 'get %s','tick cat','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)&cat=cat_foo&cat=cat_bar&cat=cat_baz$' },
timeout => { requests => 1, lines => [ 'timeout 60', 'get %s', 'content' ], location => qr'^%s/' },
ua_get => { requests => 1, lines => [ 'ua foo/1.1', 'get %s' ], location => qr'^%s/$' },
ua_get_content => { requests => 1, lines => [ 'ua foo/1.1', 'get %s', 'content' ], location => qr'^%s/$' },
untick => { requests => 2,
lines => [ 'get %s','untick cat cat_foo','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)&cat=cat_bar$' },
untick_all => { requests => 2,
lines => [ 'get %s','untick cat','submit','content' ],
location => qr'^%s/formsubmit\?session=1&query=\(empty\)$' },
);
eval {
require HTML::TableExtract;
$tests{get_table} = { requests => 1, lines => [ 'get %s','table' ], location => qr'^%s/$' };
$tests{get_table_params} = { requests => 1, lines => [ 'get %s','table Col2 Col1' ], location => qr'^%s/$' };
};
# To ease zeroing in on tests
if (@ARGV) {
my $re = join "|", @ARGV;
for (sort keys %tests) {
delete $tests{$_} unless /$re/o;
};
};
};
use Test::More tests => 1 + (scalar keys %tests)*8;
BEGIN {
# Disable all ReadLine functionality
$ENV{PERL_RL} = 0;
require LWP::UserAgent;
#my $old = \&LWP::UserAgent::request;
#print STDERR $old;
#*LWP::UserAgent::request = sub {print STDERR "LWP::UserAgent::request\n"; goto &$old };
use_ok('WWW::Mechanize::Shell');
};
SKIP: {
diag "Loading HTTP::Daemon";
eval { require HTTP::Daemon; };
skip "HTTP::Daemon required to test script/code identity",(scalar keys %tests)*8
if ($@);
# require Test::HTTP::LocalServer; # from inc
use Test::HTTP::LocalServer; # from inc
# We want to be safe from non-resolving local host names
delete @ENV{qw(HTTP_PROXY http_proxy CGI_HTTP_PROXY)};
use vars qw( $actual_requests $dumped_requests );
{
no warnings qw'redefine once';
my $old_request = *WWW::Mechanize::_make_request{CODE};
*WWW::Mechanize::_make_request = sub {
$actual_requests++;
goto &$old_request;
};
*WWW::Mechanize::Shell::status = sub {};
*WWW::Mechanize::Shell::request_dumper = sub { $dumped_requests++; return 1 };
#*Hook::LexWrap::Cleanup::DESTROY = sub {
#print STDERR "Disabling hook.\n";
#$_[0]->();
#};
};
diag "Spawning local test server";
my $server = Test::HTTP::LocalServer->spawn();
diag sprintf "on port %s", $server->port;
require LWP::UserAgent;
my $lwp_useragent_request = *LWP::UserAgent::request{CODE};
for my $name (sort keys %tests) {
$_STDOUT_ = '';
undef $_STDERR_;
$actual_requests = 0;
$dumped_requests = 0;
my @lines = @{$tests{$name}->{lines}};
my $requests = $tests{$name}->{requests};
my $code_port = $server->port;
my $url = $server->url;
$url =~ s!/$!!;
my $result_location = sprintf $tests{$name}->{location}, $url;
$result_location = qr{$result_location};
{
no warnings 'redefine';
*LWP::UserAgent::request = $lwp_useragent_request;
};
my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef );
$s->option("dumprequests",1);
my @commands;
eval {
for my $line (@lines) {
$line = sprintf $line, $server->url;
push @commands, $line;
$s->cmd($line);
};
};
is $@, '', "Commands ran without dieing"
or do { diag for @commands };
$s->cmd('eval $self->agent->uri');
my $code_output = $_STDOUT_;
diag join( "\n", $s->history )
unless like($s->agent->uri,$result_location,"Shell moved to the specified url for $name");
is($_STDERR_,undef,"Shell produced no error output for $name");
is($actual_requests,$requests,"$requests requests were made for $name");
is($dumped_requests,$requests,"$requests requests were dumped for $name");
my $code_requests = $server->get_output;
# Get a clean start
my $script_port = $server->port;
# Modify the generated Perl script to match the new? port
my $script = join "\n", $s->script;
s!\b$code_port\b!$script_port!smg for ($script, $code_output);
#print STDERR "Releasing hook";
undef $s->{request_wrapper};
#{
# local *WWW::Mechanize::Shell::request_dumper = sub { die };
# use HTTP::Request::Common;
# $s->agent->request(GET 'http://google.de/');
#};
$s->release_agent;
undef $s;
# Write the generated Perl script
my ($fh,$tempname) = tempfile();
print $fh $script;
close $fh;
my ($compile) = `"$^X" -c "$tempname" 2>&1`;
chomp $compile;
SKIP: {
unless (is($compile,"$tempname syntax OK","$name compiles")) {
$server->get_output;
diag $script;
skip "Script $name didn't compile", 2;
};
my ($output);
my $command = qq("$^X" -Iblib/lib "$tempname" 2>&1);
$output = `$command`;
is( $output, $code_output, "Output of $name is identical" )
or diag "Script:\n$script";
my $script_requests = $server->get_output;
$code_requests =~ s!\b$code_port\b!$script_port!smg;
is($code_requests,$script_requests,"$name produces identical queries")
or diag $script;
};
unlink $tempname
or diag "Couldn't remove tempfile '$name' : $!";
};
# $server->stop;
unlink $_ for (<*.save_log_server_test.tmp>);
};