WWW-Mechanize-Shell-0.56/0000755000175000017500000000000013077733716014460 5ustar corioncorionWWW-Mechanize-Shell-0.56/MANIFEST.SKIP0000755000175000017500000000035413077733715016362 0ustar corioncorion\.lwpcookies$ \.cvsignore$ \.releaserc$ \.travis.yml$ blib WWW-Mechanize-Shell-* WWW-Mechanize-Shell-*/ CVS/ .git/ MANIFEST.bak pm_to_blib pm_to_blib.ts cvstest Makefile$ cover_db/ blibdirs.ts perlbug.rep MYMETA t/hook* ^.*.old$ ^MYMETAWWW-Mechanize-Shell-0.56/Makefile.PL0000644000175000017500000001453513077733715016441 0ustar corioncorion# -*- mode: perl; c-basic-offset: 4; indent-tabs-mode: nil; -*- use strict; use ExtUtils::MakeMaker qw(WriteMakefile); # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. # Normalize version strings like 6.30_02 to 6.3002, # so that we can do numerical comparisons on it. my $eumm_version = $ExtUtils::MakeMaker::VERSION; $eumm_version =~ s/_//; my $module = 'WWW::Mechanize::Shell'; (my $main_file = "lib/$module.pm" ) =~ s!::!/!g; # I should maybe use something like Shipwright... regen_README($main_file); #regen_EXAMPLES(); my @tests = map { glob $_ } 't/*.t', 't/*/*.t'; my %module = ( NAME => $module, AUTHOR => q{Max Maischein }, VERSION_FROM => $main_file, ABSTRACT_FROM => $main_file, META_MERGE => { "meta-spec" => { version => 2 }, resources => { repository => { web => 'https://github.com/Corion/WWW-Mechanize-Shell', url => 'git://github.com/Corion/WWW-Mechanize-Shell.git', type => 'git', } }, dynamic_config => 0, # we promise to keep META.* up-to-date x_static_install => 1, # we are pure Perl and don't do anything fancy }, MIN_PERL_VERSION => '5.006', LICENSE => 'perl', PL_FILES => {}, BUILD_REQUIRES => { 'ExtUtils::MakeMaker' => 0, }, PREREQ_PM => { 'Term::Shell' => 0.02, 'parent' => 0, 'URI::URL' => 0.00, 'Test::Harness' => 2.30, 'LWP' => 5.69, 'WWW::Mechanize' => 1.20, 'WWW::Mechanize::FormFiller' => 0.05, 'Hook::LexWrap' => 0.20, 'HTML::Display' => 0, 'HTML::TokeParser::Simple' => 2.0, }, TEST_REQUIRES => { 'Test::More' => 0, 'CGI' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'WWW-Mechanize-Shell-*' }, test => { TESTS => join( ' ', @tests ) }, ); # This is so that we can do # require 'Makefile.PL' # and then call get_module_info sub get_module_info { %module } if( ! caller ) { # I should maybe use something like Shipwright... regen_README($main_file); #regen_EXAMPLES(); WriteMakefile1(get_module_info); }; 1; # Below here is boilerplate for making this work across various old versions # of ExtUtils::MakeMaker and for (re)generating README and README.mkdn sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. my %params=@_; my $eumm_version=$ExtUtils::MakeMaker::VERSION; $eumm_version=eval $eumm_version; die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; die "License not specified" if not exists $params{LICENSE}; if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) { #EUMM 6.5502 has problems with BUILD_REQUIRES $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} }; delete $params{BUILD_REQUIRES}; } if ($params{TEST_REQUIRES} and $eumm_version < 6.64) { $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{TEST_REQUIRES}} }; delete $params{TEST_REQUIRES}; } delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; delete $params{META_MERGE} if $eumm_version < 6.46; delete $params{META_ADD} if $eumm_version < 6.46; delete $params{LICENSE} if $eumm_version < 6.31; delete $params{AUTHOR} if $] < 5.005; delete $params{ABSTRACT_FROM} if $] < 5.005; delete $params{BINARY_LOCATION} if $] < 5.005; WriteMakefile(%params); } sub regen_README { # README is the short version that just tells people what this is # and how to install it eval { # Get description my $readme = join "\n", pod_section($_[0], 'NAME', 'no heading' ), pod_section($_[0], 'DESCRIPTION' ), <new(); # Read POD from Module.pm and write to README $parser->parse_from_file($_[0]); my $readme_mkdn = <as_markdown; [![Build Status](https://travis-ci.org/Corion/WWW-Mechanize-Shell.svg?branch=master)](https://github.com/Corion/WWW-Mechanize-Shell) STATUS update_file( 'README.mkdn', $readme_mkdn ); }; } sub pod_section { my( $filename, $section, $remove_heading ) = @_; open my $fh, '<', $filename or die "Couldn't read '$filename': $!"; my @section = grep { /^=head1\s+$section/.../^=/ } <$fh>; pop @section if $section[-1] =~ /^=/; unshift @section if $remove_heading; # Trim the section if( @section ) { pop @section while $section[-1] =~ /^\s*$/; shift @section while $section[0] =~ /^\s*$/; }; @section = map { $_ =~ s!^=\w+\s+!!; $_ } @section; return join "", @section; } sub update_file { my( $filename, $new_content ) = @_; my $content; if( -f $filename ) { open my $fh, '<', $filename or die "Couldn't read '$filename': $!"; binmode $fh; local $/; $content = <$fh>; }; if( $content ne $new_content ) { if( open my $fh, '>', $filename ) { binmode $fh; print $fh $new_content; } else { warn "Couldn't (re)write '$filename': $!"; }; }; }WWW-Mechanize-Shell-0.56/t/0000755000175000017500000000000013077733716014723 5ustar corioncorionWWW-Mechanize-Shell-0.56/t/27-form_number.t0000755000175000017500000000150213077733715017651 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use vars qw($_STDOUT_ $_STDERR_); tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; use Test::More tests => 4; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; delete $ENV{PAGER} if $ENV{PAGER}; $ENV{PERL_HTML_DISPLAY_CLASS}="HTML::Display::Dump"; my @warnings; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); my @status; { no warnings qw'once redefine'; *WWW::Mechanize::Shell::status = sub {}; }; $s->cmd('get file:t/27-index.html'); $s->option('warnings',1); eval { $s->cmd("form 2"); }; is($@, '', "Can execute 'form 2' for a page with two forms"); is($_STDOUT_,undef,"Nothing was printed"); is($_STDERR_,undef,"No warnings printed"); WWW-Mechanize-Shell-0.56/t/source.mech0000644000175000017500000000002613077733715017056 0ustar corioncorion# a test file content WWW-Mechanize-Shell-0.56/t/23-check-dumpresponses.t0000755000175000017500000000164013077733715021317 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use Test::HTTP::LocalServer; use vars qw($_STDOUT_ $_STDERR_); tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; use Test::More tests => 5; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; delete @ENV{qw(HTTP_PROXY http_proxy CGI_HTTP_PROXY)}; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); # Now test my $server = Test::HTTP::LocalServer->spawn(); { no warnings 'redefine','once'; local *WWW::Mechanize::Shell::status = sub {}; #$s->cmd("set dumprequests 1"); $s->cmd("set dumpresponses 1"); eval { $s->cmd( sprintf 'get "%s"', $server->url); }; is($@, "", "Get url worked"); isnt($_STDOUT_,undef,"Response was not undef"); isnt($_STDOUT_,"","Response was output"); isnt($s->agent->content,"","Retrieved content"); }; WWW-Mechanize-Shell-0.56/t/99-todo.t0000755000175000017500000000202713077733715016317 0ustar corioncorionuse Test::More; use File::Spec; use File::Find; use strict; # Check that all files do not contain any # lines with "XXX" - such markers should # either have been converted into Todo-stuff # or have been resolved. # The test was provided by Andy Lester. my @files; my $blib = File::Spec->catfile(qw(blib lib)); find(\&wanted, grep { -d } ($blib, 'bin')); plan tests => 2* @files; foreach my $file (@files) { source_file_ok($file); } sub wanted { push @files, $File::Find::name if /\.p(l|m|od)$/; } sub source_file_ok { my $file = shift; open( my $fh, "<$file" ) or die "Can't open $file: $!"; my @lines = <$fh>; close $fh; my $n = 0; for ( @lines ) { ++$n; s/^/$file ($n): /; } my @x = grep /XXX/, @lines; if ( !is( scalar @x, 0, "Looking for XXXes in $file" ) ) { diag( $_ ) for @x; } @x = grep /<<<|>>>/, @lines; if ( !is( scalar @x, 0, "Looking for <<<<|>>>> in $file" ) ) { diag( $_ ) for @x; } } WWW-Mechanize-Shell-0.56/t/00-load.t0000644000175000017500000000054613077733715016250 0ustar corioncorion#!perl -T use strict; use warnings; use Test::More tests => 1; my $module; BEGIN { $module = "WWW::Mechanize::Shell"; require_ok( $module ); } diag( sprintf "Testing %s %s, Perl %s", $module, $module->VERSION, $] ); for (sort grep /\.pm\z/, keys %INC) { s/\.pm\z//; s!/!::!g; eval { diag(join(' ', $_, $_->VERSION || '')) }; } WWW-Mechanize-Shell-0.56/t/25-save-file-nolink.t0000755000175000017500000000220313077733715020476 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use Test::HTTP::LocalServer; use vars qw($_STDOUT_ $_STDERR_); tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; use Test::More tests => 6; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; delete @ENV{qw(HTTP_PROXY http_proxy CGI_HTTP_PROXY)}; delete $ENV{PAGER} if $ENV{PAGER}; $ENV{PERL_HTML_DISPLAY_CLASS}="HTML::Display::Dump"; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); # Now test my $server = Test::HTTP::LocalServer->spawn(); { no warnings 'redefine', 'once'; local *WWW::Mechanize::Shell::status = sub {}; $s->cmd( sprintf 'get "%s"', $server->url); isnt($s->agent->content,"","Retrieved content"); $s->cmd("save"); is($_STDOUT_,"No link given to save\n","save error message"); is($_STDERR_,undef,"No warnings"); $_STDOUT_ = undef; $_STDERR_ = undef; $s->cmd("save /does-not-exist/"); like($_STDOUT_,'/No match for \/\(\?(-xism|\^):does-not-exist\)\/.\n/',"save RE error message"); is($_STDERR_,undef,"No warnings"); }; WWW-Mechanize-Shell-0.56/t/99-changes.t0000644000175000017500000000127513077733715016763 0ustar corioncorion#!perl -w use warnings; use strict; use File::Find; use Test::More tests => 2; =head1 PURPOSE This test ensures that the Changes file mentions the current version and that a release date is mentioned as well =cut my $module = 'WWW::Mechanize::Shell'; (my $file = $module) =~ s!::!/!g; require "$file.pm"; my $version = sprintf '%0.2f', $module->VERSION; diag "Checking for version " . $version; my $changes = do { local $/; open my $fh, 'Changes' or die $!; <$fh> }; ok $changes =~ /^(.*$version.*)$/m, "We find version $version"; my $changes_line = $1; ok $changes_line =~ /$version\s+20\d{6}/, "We find a release date on the same line" or diag $changes_line; WWW-Mechanize-Shell-0.56/t/24-source-file.t0000755000175000017500000000225113077733715017552 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use Test::HTTP::LocalServer; use vars qw($_STDOUT_ $_STDERR_); tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; use Test::More tests => 6; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; delete $ENV{PAGER} if $ENV{PAGER}; $ENV{PERL_HTML_DISPLAY_CLASS}="HTML::Display::Dump"; delete @ENV{qw(HTTP_PROXY http_proxy CGI_HTTP_PROXY)}; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); # Now test my $server = Test::HTTP::LocalServer->spawn(); { no warnings 'redefine','once'; local *WWW::Mechanize::Shell::status = sub {}; $s->cmd( sprintf 'get "%s"', $server->url); isnt($s->agent->content,"","Retrieved content"); $s->cmd("source t/source.mech"); isnt($_STDOUT_,"","Sourcing a file works"); is($_STDERR_,undef,"No warnings"); }; { no warnings 'redefine','once'; my $warned; local *WWW::Mechanize::Shell::display_user_warning = sub { $warned++ }; $s->cmd("source t/does-not-exist.mech"); is($warned,1,"Warning for nonexistent files works"); is($_STDERR_,undef,"No warnings"); }; WWW-Mechanize-Shell-0.56/t/08-unknown-command.t0000755000175000017500000000147513077733715020461 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use File::Temp qw( tempfile ); # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; use Test::More tests => 2; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; SKIP: { #skip "Can't load Term::ReadKey without a terminal", 2 # unless -t STDIN; #eval { require Term::ReadKey; Term::ReadKey::GetTerminalSize(); }; #if ($@) { # no warnings 'redefine'; # *Term::ReadKey::GetTerminalSize = sub {80,24}; # diag "Term::ReadKey seems to want a terminal"; #}; use_ok('WWW::Mechanize::Shell'); # Silence all warnings my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); eval { $s->cmd('this_command_does_not_exist'); }; is($@,"","An unknown command does not crash the shell"); }; WWW-Mechanize-Shell-0.56/t/401-server0000755000175000017500000000321113077733715016455 0ustar corioncorion# Thanks to merlyn for nudging me and giving me this snippet! use strict; use HTTP::Daemon; use LWP::UserAgent; $|++; my $host = 'localhost'; my $d = HTTP::Daemon->new( LocalAddr => $host, ) or die; # HTTP::Deamon doesn't return http://localhost:.../ # for LocalAddr => 'localhost'. This causes the # tests to fail of many machines. ( my $url = URI->new($d->url) )->host($host); print "$url\n"; # How many requests do we expect? my ($ex_user,$ex_pass) = @ARGV; my $verbose = $ENV{TEST_HTTP_VERBOSE}; my $done = 0; while (! $done and my $c = $d->accept) { while (my $req = $c->get_request) { if ($verbose) { warn "# Request URI: " . $req->url->path; my @lines = split "\n",$req->as_string; warn "# $_\n" for @lines; }; my $res; my ($user,$pass); if ($req->url->path eq '/exit') { $done = 1; $res = HTTP::Response->new(200, "OK", undef, "done"); } elsif ( ($user, $pass) = $req->authorization_basic and $user eq $ex_user and $pass eq $ex_pass) { $res = HTTP::Response->new(200, "OK", undef, "user = '$user' pass = '$pass'"); } else { warn "# User : '$user' Password : '$pass'\n" if $verbose; $res = HTTP::Response->new(401, "Auth Required", undef, "auth required ($user/$pass)"); $res->www_authenticate("Basic realm=\"testing realm\""); }; if ($verbose) { warn "---\n"; my @lines = split "\n",$res->as_string; warn "# $_\n" for @lines; }; $c->send_response($res); } $c->close; undef($c); }; WWW-Mechanize-Shell-0.56/t/28-html-tableextract.t0000755000175000017500000000367513077733715021000 0ustar corioncorion#!/usr/bin/perl -w use strict; use Test::More tests => 3; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; delete $ENV{PAGER} if $ENV{PAGER}; $ENV{PERL_HTML_DISPLAY_CLASS}="HTML::Display::Dump"; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); isa_ok $s, 'WWW::Mechanize::Shell'; my $have_tableextract = eval { require HTML::TableExtract; die "Need at least HTML::TableExtract v2, found '$HTML::TableExtract::VERSION'" unless $HTML::TableExtract::VERSION > 2; 1 }; SKIP: { if ($@) { skip "Error loading HTML::TableExtract: '$@'", 1; } elsif (! $have_tableextract) { skip "Unknown error loading HTML::TableExtract, skipping tests", 1; } else { no warnings qw'redefine once'; local *WWW::Mechanize::Shell::status = sub {}; my @output; local *WWW::Mechanize::Shell::print_paged = sub { shift @_; push @output, grep { /\S/ } @_; }; $s->agent->{base} = 'http://example.com'; $s->agent->update_html(<
IDagename
1John41
2Paul47
3George45
4Ringo47
HTML $s->cmd('table name age'); # TableExtract seems to be confused about the column order # hence we just check the number of rows: is(scalar @output, 5, "Five lines captured") or diag "@output"; } }; WWW-Mechanize-Shell-0.56/t/03-documentation.t0000644000175000017500000000165113077733715020203 0ustar corioncorionuse strict; use FindBin; use vars qw( @methods ); BEGIN { my $module = "$FindBin::Bin/../lib/WWW/Mechanize/Shell.pm"; open MODULE, "< $module" or die "Couldn't open module file '$module'"; @methods = map { /^\s*sub run_([a-z]+)\s*\{/ ? $1 : () } ; close MODULE; }; use Test::More tests => scalar @methods*3 +2; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; SKIP: { eval { require Pod::Constants;}; skip "Need Pod::Constants to test the documentation", 2 + scalar @methods*3 if $@; use_ok("WWW::Mechanize::Shell"); my $shell = WWW::Mechanize::Shell->new("shell", rcfile => undef, warnings => undef ); isa_ok($shell,"WWW::Mechanize::Shell"); for my $method (@methods) { my $helptext = $shell->catch_smry($method); is($@,'',"No error"); isnt( $helptext, undef, "Documentation for $method is there"); isnt( $helptext, '', "Documentation for $method is not empty"); }; }; WWW-Mechanize-Shell-0.56/t/04-history-invariant.t0000755000175000017500000000377113077733715021035 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; use vars qw( @history_invariant @history_add ); BEGIN { # Disable all ReadLine functionality $ENV{PERL_RL} = 0; # Also disable the paged output of Term::Shell @history_invariant = qw( browse cookies dump eval exit forms history links parse quit restart script set source tables versions ct response title headers ); push @history_invariant, "headers 1","headers 12","headers 2","headers 12345"; push @history_invariant, "#"," #", "# a comment", " # another comment"; @history_add = qw( autofill back click content fillout get open reload save submit table ua value tick untick referer referrer timeout ); }; # For testing the "versions" command sub WWW::Mechanize::Shell::print_pairs {}; use Test::More tests => scalar @history_invariant +1; SKIP: { use_ok('WWW::Mechanize::Shell'); # Silence all warnings #$SIG{__WARN__} = sub {}; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); $s->agent->{content} = ''; my @history; sub disable { my ($namespace,$subname) = @_; no strict 'refs'; no warnings 'redefine'; *{"$namespace\::$subname"} = sub { return }; }; { no warnings 'redefine','once'; *WWW::Mechanize::Shell::add_history = sub { shift; push @history, join "", @_; }; *WWW::Mechanize::links = sub {()}; }; disable( "WWW::Mechanize::Shell", $_ ) for (qw( restart_shell browser )); disable( "WWW::Mechanize",$_ ) for (qw( cookie_jar current_form forms )); disable( "Term::Shell",$_ ) for (qw( print_pairs )); for my $cmd (@history_invariant) { @history = (); $s->cmd($cmd); is_deeply( \@history, [], "$cmd is history invariant"); }; }; WWW-Mechanize-Shell-0.56/t/18-browser-autosync.t0000755000175000017500000000346413077733715020675 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; use vars qw( %tests ); BEGIN { %tests = ( back => { count => 3, commands => ['get %s','click submit','back']}, browse => { count => 2, commands => [ 'get %s', 'browse' ] }, get => { count => 1, commands => ['get %s']} , open => { count => 2, commands => ['get %s','open 1'] }, submit => { count => 2, commands => ['get %s','submit']}, click => { count => 2, commands => ['get %s','click submit']}, reload => { count => 2, commands => ['get %s','reload'] }, ) }; use Test::More tests => scalar (keys %tests) +1; SKIP: { BEGIN { # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); eval { require HTTP::Daemon; }; skip "HTTP::Daemon required to test browser synchronisation",(scalar keys %tests)*6 if ($@); use lib './inc'; require Test::HTTP::LocalServer; # from inc delete @ENV{qw(HTTP_PROXY http_proxy CGI_HTTP_PROXY)}; }; my $browser_synced; { no warnings 'redefine'; *WWW::Mechanize::Shell::sync_browser = sub { $browser_synced++; }; }; sub sync_ok { my %args = @_; my $name = $args{name}; my $count = $args{count}; my (@commands) = @{$args{commands}}; my $server = Test::HTTP::LocalServer->spawn(); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); $s->option('autosync', 1); $browser_synced = 0; for my $cmd (@commands) { no warnings; $cmd = sprintf $cmd, $server->url; $s->cmd($cmd); }; is($browser_synced,$count,"'$name' synchronizes $count times") or diag join "\n", @commands; $server->stop; }; for my $cmd (sort keys %tests) { sync_ok( name => $cmd, %{$tests{$cmd}} ); }; }; WWW-Mechanize-Shell-0.56/t/20-restart-without-script.t0000755000175000017500000000101313077733715022013 0ustar corioncorion#!/usr/bin/perl -w use strict; use Test::More tests => 4; BEGIN{ # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use_ok("WWW::Mechanize::Shell"); }; delete @ENV{qw(HTTP_PROXY http_proxy CGI_HTTP_PROXY)}; my $output= `$^X -I./lib -MWWW::Mechanize::Shell -e "WWW::Mechanize::Shell->new('t',rcfile=>undef,warnings=>undef)->cmd('restart');print'OK'" 2>&1`; chomp $output; is($@, "","'restart' on -e dosen't crash"); is($?, 0,"'restart' on -e dosen't crash"); is($output,"OK","'restart' on -e dosen't crash"); WWW-Mechanize-Shell-0.56/t/00-use.t0000644000175000017500000000521413077733715016122 0ustar corioncorionuse strict; use Test::More tests => 22; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; $ENV{COLUMNS} = 80; $ENV{LINES} = 24; use_ok("WWW::Mechanize::Shell") or BAIL_OUT('Does not compile correctly'); diag "Running under $]"; for (qw(WWW::Mechanize LWP::UserAgent)) { diag "Using '$_' version " . $_->VERSION; }; my $s = do { WWW::Mechanize::Shell->new("shell",rcfile => undef, warnings => undef); }; isa_ok($s,"WWW::Mechanize::Shell"); # Now check our published API : for my $meth (qw( source_file cmdloop agent option restart_shell option cmd )) { can_ok($s,$meth); }; # Check that we can set known options # See also t/05-options.t my $oldvalue = $s->option('autosync'); $s->option('autosync',"foo"); is($s->option('autosync'),"foo","Setting an option works"); $s->option('autosync',$oldvalue); is($s->option('autosync'),$oldvalue,"Setting an option still works"); # Check that trying to set an unknown option gives an error { no warnings 'redefine'; my $called; local *Carp::carp = sub { $called++; }; $s->option('nonexistingoption',"foo"); is($called,1,"Setting an nonexisting option calls Carp::carp"); } { no warnings 'redefine'; my $called; my $filename; local *WWW::Mechanize::Shell::source_file = sub { $filename = $_[1]; $called++; }; my $test_filename = '/does/not/need/to/exist'; my $s = do { WWW::Mechanize::Shell->new("shell",rcfile => $test_filename, warnings => undef); }; isa_ok($s,"WWW::Mechanize::Shell"); ok($called,"Passing an .rc file tries to load it"); is($filename,$test_filename,"Passing an .rc file tries to load the right file"); }; { no warnings 'redefine'; my $called = 0; my $filename; local *WWW::Mechanize::Shell::source_file = sub { $filename = $_[1]; $called++; }; my $s = do { WWW::Mechanize::Shell->new("shell",rcfile => undef, warnings => undef); }; isa_ok($s,"WWW::Mechanize::Shell"); diag "Tried to load '$filename'" unless is($called,0,"Passing in no .rc file tries not to load it"); }; $s = WWW::Mechanize::Shell->new("shell",rcfile => undef, cookiefile => 'test.cookiefile', warnings => undef); isa_ok($s,"WWW::Mechanize::Shell"); is($s->option('cookiefile'),'test.cookiefile',"Passing in a cookiefile filename works"); # Also check what gets exported: ok(defined *main::shell{CODE},"'shell' gets exported"); { no warnings 'once'; is(*main::shell{CODE},*WWW::Mechanize::Shell::shell{CODE},"'shell' is the right sub"); }; { no warnings 'redefine','once'; my $called; local *WWW::Mechanize::Shell::cmdloop = sub { $called++ }; # Need to suppress status warnings here shell(warnings => undef); is($called,1,"Shell function works"); }; WWW-Mechanize-Shell-0.56/t/14-command-identity.t0000755000175000017500000003322313077733715020604 0ustar corioncorion#!/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 1','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; 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}; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); $s->option("dumprequests",1); my @commands; eval { for my $line (@lines) { no warnings; $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_log; # 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_log; diag $script; skip "Script $name didn't compile", 2; }; my ($output); my $command = qq("$^X" -Iblib/lib "$tempname" 2>&1); $output = `$command`; $output =~ s!^Cookie:.*$!Cookie: !smg; # cookies get re-ordered, sometimes $code_output =~ s!^Cookie:.*$!Cookie: !smg; # cookies get re-ordered, sometimes is( $output, $code_output, "Output of $name is identical" ) or diag "Script:\n$script"; my $script_requests = $server->get_log; $code_requests =~ s!\b$code_port\b!$script_port!smg; $code_requests =~ s!^Cookie:.*$!Cookie: !smg; # cookies get re-ordered, sometimes $script_requests =~ s!^Cookie:.*$!Cookie: !smg; # cookies get re-ordered, sometimes 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>); }; WWW-Mechanize-Shell-0.56/t/12-comments.t0000755000175000017500000000215013077733715017155 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use vars qw( @comments $_STDOUT_ $_STDERR_ ); # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; BEGIN { @comments = ( "#", "# a test", "#eval 1", "# eval 1", "## eval 1" )}; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use Test::More tests => 1 + scalar @comments * 3; SKIP: { #skip "Can't load Term::ReadKey without a terminal", 1 + scalar @comments * 3 # unless -t STDIN; #eval { require Term::ReadKey; Term::ReadKey::GetTerminalSize(); }; #if ($@) { # no warnings 'redefine'; # *Term::ReadKey::GetTerminalSize = sub {80,24}; # diag "Term::ReadKey seems to want a terminal"; #}; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); for (@comments) { $_STDOUT_ = ""; $_STDERR_ = ""; eval { $s->cmd($_); }; is($@,"","Comment '$_' produces no error"); is($_STDOUT_,"","Comment '$_' produces no output"); is($_STDERR_,"","Comment '$_' produces no error output"); }; }; WWW-Mechanize-Shell-0.56/t/00a-Term-Shell-catch-smry.t0000755000175000017500000000264313077733715021521 0ustar corioncorionuse strict; use Test::More tests => 1; use lib 'inc'; use IO::Catch; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; $ENV{COLUMNS} = 80; $ENV{LINES} = 24; TODO: { #local $TODO = "Term::Shell::catch_smry is buggy"; # Now check that the Term::Shell summary calls catch_smry require Term::Shell; use vars qw( $called ); { package Term::Shell::Test; use base 'Term::Shell'; sub summary { $::called++ }; sub print_pairs {}; }; my $s = { handlers => { foo => { run => sub {}}} }; bless $s, 'Term::Shell::Test'; { local *STDOUT; tie *STDOUT, 'IO::Catch', '_STDOUT_'; $s->run_help(); }; if (not is($called,1,"Term::Shell::Test::catch_smry gets called for unknown methods")) { diag "Term::Shell did not call a custom catch_smry handler"; diag "This is most likely because your version of Term::Shell"; diag "has a bug. Please upgrade to v0.02 or higher, which"; diag "should close this bug."; diag "If that is no option, patch sub help() in Term/Shell.pm, line 641ff."; diag "to:"; diag ' #my $smry = exists $o->{handlers}{$h}{smry};'; diag ' #? $o->summary($h);'; diag ' #: "undocumented";'; diag ' my $smry = $o->summary($h);'; diag 'Fixing this is not necessary - you will get no online help'; diag 'but the shell will otherwise work fine. Help is still'; diag 'available through ``perldoc WWW::Mechanize::Shell``'; }; }; WWW-Mechanize-Shell-0.56/t/15-history-save.t0000755000175000017500000000320213077733715017767 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use File::Temp qw( tempfile ); # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; use Test::More tests => 7; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); my ($fh,$name) = tempfile(); close $fh; $s->cmd('autofill foo Fixed bar'); $s->cmd(sprintf 'history "%s"', $name); my $script = join("\n", $s->history)."\n"; ok(-f $name, "History file exists"); open F, "< $name" or die "Couldn't open tempfile $name : $!"; my $file = do { local $/; }; close F; is($file, $script, "Written history is the same as history()"); unlink $name or warn "Couldn't remove tempfile $name : $!"; ($fh,$name) = tempfile(); close $fh; $s->cmd(sprintf 'script "%s"', $name); $script = join("\n", $s->script(" "))."\n"; ok(-f $name, "Script file exists"); open F, "< $name" or die "Couldn't open tempfile $name : $!"; $file = do { local $/; }; close F; is($file, $script, "Written script is the same as script()"); unlink $name or warn "Couldn't remove tempfile $name : $!"; ($fh,$name) = tempfile(); close $fh; $s->agent->{content} = "test"; $s->cmd(sprintf 'content "%s"', $name); my $content = $s->agent->content . "\n"; ok(-f $name, "Script file exists"); open F, "< $name" or die "Couldn't open tempfile $name : $!"; $file = do { local $/; }; close F; is($file, $content, 'Written content is the same as $agent->content'); unlink $name or warn "Couldn't remove tempfile $name : $!"; WWW-Mechanize-Shell-0.56/t/99-manifest.t0000755000175000017500000000154613077733715017165 0ustar corioncorionuse strict; use Test::More; # Check that MANIFEST and MANIFEST.skip are sane : use File::Find; use File::Spec; my @files = qw( MANIFEST MANIFEST.SKIP ); plan tests => scalar @files * 4 +1 # MANIFEST existence check ; for my $file (@files) { ok(-f $file, "$file exists"); open F, "<$file" or die "Couldn't open $file : $!"; my @lines = ; is_deeply([grep(/^$/, @lines)],[], "No empty lines in $file"); is_deeply([grep(/^\s+$/, @lines)],[], "No whitespace-only lines in $file"); is_deeply([grep(/^\s*\S\s+$/, @lines)],[],"No trailing whitespace on lines in $file"); if ($file eq 'MANIFEST') { chomp @lines; is_deeply([grep { s/\s.*//; ! -f } @lines], [], "All files in $file exist") or do { diag "$_ is mentioned in $file but doesn't exist on disk" for grep { ! -f } @lines }; }; close F; }; WWW-Mechanize-Shell-0.56/t/02-fallback-HTML-TableExtract.t0000755000175000017500000000236113077733715022214 0ustar corioncorionuse strict; use Test::More tests => 4; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; SKIP: { #skip "Can't load Term::ReadKey without a terminal", 4 # unless -t STDIN; eval { require Test::Without::Module; Test::Without::Module->import('HTML::TableExtract') }; skip "Need Test::Without::Module to test the fallback", 4 if $@; #eval { require Term::ReadKey; Term::ReadKey::GetTerminalSize(); }; #if ($@) { # no warnings 'redefine'; # *Term::ReadKey::GetTerminalSize = sub {80,24}; # diag "Term::ReadKey seems to want a terminal"; #}; use_ok("WWW::Mechanize::Shell"); my $shell = do { WWW::Mechanize::Shell->new("shell", rcfile => undef, warnings => undef ); }; isa_ok($shell,"WWW::Mechanize::Shell"); my $text; my $warned; { local $SIG{__WARN__} = sub { $warned = $_[0]; }; $shell->option('warnings',1); eval { $shell->cmd("tables"); }; }; is( $@, '', "No error without HTML::TableExtract"); my $pass = ($warned =~ qr'^HTML\W+TableExtract\.pm did not return a true value') || ($warned =~ qr!^Can't locate HTML/TableExtract.pm in \@INC!); ok $pass, "Missing HTML::TableExtract raises warning" or diag "Caught warning '$warned'"; }; WWW-Mechanize-Shell-0.56/t/09-invalid-filename.t0000755000175000017500000000150113077733715020541 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use File::Temp qw( tempfile ); # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; use Test::More tests => 2; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; SKIP: { #skip "Can't load Term::ReadKey without a terminal", 2 # unless -t STDIN; #eval { require Term::ReadKey; Term::ReadKey::GetTerminalSize(); }; #if ($@) { # no warnings 'redefine'; # *Term::ReadKey::GetTerminalSize = sub {80,24}; # diag "Term::ReadKey seems to want a terminal"; #}; use_ok('WWW::Mechanize::Shell'); # Silence all warnings my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); eval { $s->cmd('source this_file_does_not_exist'); }; is($@,"","A nonexisting file does not crash the shell"); }; WWW-Mechanize-Shell-0.56/t/99-unix-text.t0000755000175000017500000000140413077733715017315 0ustar corioncorionuse Test::More; # Check that all released module files are in # UNIX text format use File::Spec; use File::Find; use strict; my @files; my $blib = File::Spec->catfile(qw(blib lib)); find(\&wanted, grep { -d } ($blib, 'bin')); plan tests => scalar @files; foreach my $file (@files) { unix_file_ok($file); } sub wanted { push @files, $File::Find::name if /\.p(l|m|od)$/; } sub unix_file_ok { my ($filename) = @_; local $/; open F, "< $filename" or die "Couldn't open '$filename' : $!\n"; binmode F; my $content = ; my $i; my @lines = grep { /\x0D\x0A$/sm } map { sprintf "%s: %s\x0A", $i++, $_ } split /\x0A/, $content; unless (is(scalar @lines, 0,"'$filename' contains no windows newlines")) { diag $_ for @lines; }; close F; }; WWW-Mechanize-Shell-0.56/t/28-cmd-title.t0000755000175000017500000000346613077733715017234 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use vars qw($_STDOUT_ ); tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; delete $ENV{PAGER} if $ENV{PAGER}; $ENV{PERL_HTML_DISPLAY_CLASS}="HTML::Display::Dump"; use Test::More tests => 6; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); isa_ok $s, 'WWW::Mechanize::Shell'; SKIP: { $s->agent->{base} = 'http://example.com'; $s->agent->update_html(< An HTML page Some body HTML $s->cmd('title'); chomp $_STDOUT_; is($_STDOUT_,"An HTML page", "Title gets output correctly"); undef $_STDOUT_; $s->agent->update_html(< Some body HTML $s->cmd('title'); chomp $_STDOUT_; is($_STDOUT_,"", "Empty title gets output correctly"); undef $_STDOUT_; $s->agent->update_html(< 0 Some body HTML $s->cmd('title'); chomp $_STDOUT_; is($_STDOUT_,"0", "False title gets output correctly"); undef $_STDOUT_; $s->agent->update_html(< Some body HTML $s->cmd('title'); chomp $_STDOUT_; is($_STDOUT_,"", "A missing title gets output correctly"); }; WWW-Mechanize-Shell-0.56/t/05-options.t0000755000175000017500000000256513077733715017037 0ustar corioncorion#!/usr/bin/perl -w use strict; use vars qw( @options ); BEGIN { @options = qw( autosync autorestart watchfiles cookiefile dumprequests dumpresponses verbose warnings ); }; use Test::More tests => scalar @options*4 +1+4; SKIP: { BEGIN { $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); }; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); for my $option (@options) { my $oldval = $s->option($option); my $oldval2 = $s->option($option,"newvalue"); is( $s->option($option), "newvalue", "Setting option '$option' via ->option()" ); is( $oldval, $oldval2, "->option('$option','newvalue') returns the previous value"); is( $s->option($option,$oldval2), "newvalue", "->option('$option','newvalue') returns the previous value (2)"); is( $s->option($option), $oldval, "Setting option '$option' via ->option() (2)"); }; my $warned; no warnings 'redefine'; local *Carp::carp = sub { $warned = $_[0] }; my $res = $s->option('doesnotexist'); is( $res, undef, "Nonexisting option returns undef"); is( $warned, "Unknown option 'doesnotexist'", "Nonexisting option raises a warning"); $res = $s->option('doesnotexist','newvalue'); is( $res, undef, "Nonexisting option returns undef" ); is( $warned, "Unknown option 'doesnotexist'","Nonexisting option raises a warning" ); }; WWW-Mechanize-Shell-0.56/t/29-launch-shell.t0000755000175000017500000000121213077733715017715 0ustar corioncorion#!/usr/bin/perl -w use strict; use Test::More tests => 4; use File::Spec; use File::Temp qw(tempfile); my $perl = $^X; if ($perl =~ /\s/) { $perl = qq{"$perl"}; }; my ($fh,$temp) = tempfile(); print {$fh} "quit\n"; close $fh; my $res = system($perl, "-I./blib/lib", "-MWWW::Mechanize::Shell", "-eshell(warnings=>undef)", $temp); is $res,0,"Shell launch works"; is $?, 0, "No error on exit"; unlink $temp or diag "Couldn't remove '$temp': $!"; use_ok "WWW::Mechanize::Shell"; my $s = WWW::Mechanize::Shell->new("shell",warnings=>undef); my $prompt = eval { $s->prompt_str }; is $@, '', "prompt_str() doesn't die for empty WWW::Mechanize"; WWW-Mechanize-Shell-0.56/t/11-browse-without-request.t0000755000175000017500000000072213077733715022022 0ustar corioncorion#!/usr/bin/perl -w use strict; use Test::More tests => 2; BEGIN { # Choose a nonannoying HTML displayer: $ENV{PERL_HTML_DISPLAY_CLASS} = 'HTML::Display::Dump'; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); }; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); # Now test eval { $s->cmd('browse'); }; is($@, "", "Browsing without requesting anything does not crash the shell"); WWW-Mechanize-Shell-0.56/t/01-fallback-Win32-OLE.t0000644000175000017500000000106713077733715020405 0ustar corioncorionuse strict; use Test::More tests => 3; # Disable all ReadLine functionality SKIP: { $ENV{PERL_RL} = 0; eval { require Test::Without::Module; Test::Without::Module->import('Win32::OLE') }; skip "Need Test::Without::Module to test the fallback", 3 if $@; use_ok("WWW::Mechanize::Shell"); my $shell = do { WWW::Mechanize::Shell->new("shell", rcfile => undef, warnings => undef ); }; isa_ok($shell,"WWW::Mechanize::Shell"); my $browser; eval { $browser = $shell->browser; }; is( $@, '', "No error without Win32::OLE"); }; WWW-Mechanize-Shell-0.56/t/99-pod.t0000644000175000017500000000123213077733715016126 0ustar corioncorionuse Test::More; # Check our Pod # The test was provided by Andy Lester, # who stole it from Brian D. Foy # Thanks to both ! use File::Spec; use File::Find; use strict; eval { require Test::Pod; Test::Pod->import; }; my @files; if ($@) { plan skip_all => "Test::Pod required for testing POD"; } elsif ($Test::Pod::VERSION < 0.95) { plan skip_all => "Test::Pod 0.95 required for testing POD"; } else { my $blib = File::Spec->catfile(qw(blib lib)); find(\&wanted, grep { -d } ($blib, 'bin')); plan tests => scalar @files; foreach my $file (@files) { pod_file_ok($file); } } sub wanted { push @files, $File::Find::name if /\.p(l|m|od)$/; } WWW-Mechanize-Shell-0.56/t/06-valid-output.t0000755000175000017500000000747113077733715020003 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use Test::More (); use File::Temp qw( tempfile ); use WWW::Mechanize::Link; # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; BEGIN { # Choose a nonannoying HTML displayer: $ENV{PERL_HTML_DISPLAY_CLASS} = 'HTML::Display::Dump'; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; }; use vars qw( %tests ); BEGIN { %tests = ( 'autofill' => 'autofill test Fixed value', 'back' => 'back', 'click' => 'click', 'content' => 'content', 'eval' => 'eval 1', 'fillout' => 'fillout', 'get @' => 'get http://admin@www.google.com/', 'get plain' => 'get http://www.google.com/', 'open' => 'open "foo link"', 'reload' => 'reload', 'referrer' => 'referrer ""', 'referrer val' => 'referrer "foo"', 'referer' => 'referer ""', 'save' => 'save 0', 'save re' => 'save /.../', 'submit' => 'submit', 'tick' => 'tick key value', 'tick_all' => 'tick key', 'timeout' => 'timeout 60', 'value' => 'value key value', 'ua' => 'ua foo/1.1', 'untick' => 'untick key value', 'untick_all' => 'untick key', ); eval { require HTML::TableExtract; $HTML::TableExtract::VERSION >= 2 or die "Need HTML::TableExtract version >= 2"; $tests{table} = 'table'; $tests{'table params'} = 'table foo bar'; }; }; use Test::More tests => scalar (keys %tests)*2 +1; BEGIN { use_ok('WWW::Mechanize::Shell'); }; SKIP: { eval { require Test::MockObject; Test::MockObject->import(); }; skip "Test::MockObject not installed", scalar (keys %tests)*2 if $@; my $mock_result = Test::MockObject->new; $mock_result->set_always( code => 200 ); my $mock_form = Test::MockObject->new; $mock_form->mock( value => sub {} ) ->set_list( inputs => ()) ->set_list( find_input => ()); my $mock_agent = Test::MockObject->new; $mock_agent->set_true($_) for qw( back content get open ); $mock_agent->set_false($_) for qw( form forms ); my $mock_uri = Test::MockObject->new; $mock_uri->set_always( abs => 'http://example.com/' ) ->set_always( path => '/' ); $mock_uri->fake_module( 'URI::URL', new => sub {$mock_uri} ); $mock_agent->set_always( res => $mock_result ) ->set_always( add_header => 1 ) ->set_always( submit => $mock_result ) ->set_always( click => $mock_result ) ->set_always( reload => $mock_result ) ->set_always( current_form => $mock_form ) ->set_always( follow_link => 1 ) ->set_list( links => WWW::Mechanize::Link->new('foo','foo link','foo_link',""), WWW::Mechanize::Link->new('foo2','foo2 link','foo2_link',"")) ->set_always( agent => 'foo/1.0' ) ->set_always( tick => 1 ) ->set_always( timeout => 1 ) ->set_always( untick => 1 ) ->set_always( uri => $mock_uri ); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef, watchfiles => undef ); $s->{agent} = $mock_agent; my @history; { no warnings 'redefine'; *WWW::Mechanize::Shell::add_history = sub { shift; # warn $_ for @_; push @history, join "", @_; }; }; sub compiles_ok { my ($command,$testname) = @_; $testname ||= $command; @history = (); $s->cmd($command); local $, = "\n"; my ($fh,$name) = tempfile(); print $fh ( "@history" ); close $fh; ok( scalar @history != 0, "$testname is history relevant"); my $output = `$^X -Ilib -c $name 2>&1`; chomp $output; is( $output, "$name syntax OK", "$testname compiles") or diag "Created file was :\n@history"; unlink $name or diag "Couldn't remove tempfile '$name' : $!"; }; foreach my $name (sort keys %tests) { compiles_ok( $tests{$name},$name ); }; }; WWW-Mechanize-Shell-0.56/t/07-history-items.t0000755000175000017500000000675413077733715020172 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use File::Temp qw( tempfile ); use WWW::Mechanize::Link; # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; use vars qw( %tests ); BEGIN { # Disable all ReadLine functionality $ENV{PERL_RL} = 0; %tests = ( 'autofill' => 'autofill test Fixed value', 'back' => 'back', 'click' => 'click', 'content' => 'content', 'eval' => 'eval 1', 'fillout' => 'fillout', 'form' => 'form 1', 'form' => 'form test', 'get @' => 'get http://admin@www.google.com/', 'get plain' => 'get http://www.google.com/', 'open' => 'open "foo link"', 'reload' => 'reload', 'referer' => 'referer ""', 'referrer' => 'referrer ""', 'save' => 'save /.../', 'submit' => 'submit', 'value' => 'value key value', 'ua' => 'ua foo/1.0', 'tick' => 'tick key value', 'tick_all' => 'tick key', 'timeout' => 'timeout 60', 'untick' => 'untick key value', 'untick_all' => 'untick key', ); eval { require HTML::TableExtract; $tests{table} = 'table'; $tests{table params} = 'table foo bar'; ; }; }; use Test::More tests => scalar (keys %tests) +1; SKIP: { eval { require Test::MockObject; Test::MockObject->import(); }; skip "Test::MockObject not installed", scalar keys(%tests) +1 if $@; my $mock_result = Test::MockObject->new; $mock_result->set_always( code => 200 ); my $mock_form = Test::MockObject->new; $mock_form->mock( value => sub {} ) ->set_list( inputs => ()) ->set_list( find_input => ()) ->mock( dump => sub {} ) ->set_always( form_name => 'foo' ); my $mock_uri = Test::MockObject->new; $mock_uri->set_always( abs => 'http://example.com/' ) ->set_always( path => '/' ); $mock_uri->fake_module( 'URI::URL', new => sub {$mock_uri} ); my $mock_agent = Test::MockObject->new; $mock_agent->set_true($_) for qw( back content get mirror open follow ); $mock_agent->set_false($_) for qw( form forms ); $mock_agent->set_always( res => $mock_result ) ->set_always( add_header => 1 ) ->set_always( submit => $mock_result ) ->set_always( click => $mock_result ) ->set_always( reload => $mock_result ) ->set_always( current_form => $mock_form ) ->set_always( form_name => 'test form name' ) ->set_always( follow_link => 1 ) ->set_list( links => WWW::Mechanize::Link->new('foo','foo link','foo_link',""), WWW::Mechanize::Link->new('foo2','foo2 link','foo2_link',"")) ->set_always( agent => 'mocked/1.0') ->set_always( uri => $mock_uri ) ->set_always( request => $mock_result ) ->set_always( tick => 1 ) ->set_always( timeout => 1 ) ->set_always( untick => 1 ) ; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef, watchfiles => undef ); $s->{agent} = $mock_agent; my @history; { no warnings 'redefine','once'; *WWW::Mechanize::Shell::add_history = sub { my $shell = shift; push @history, $shell->line; }; }; sub exactly_one_line { my ($command,$testname) = @_; $testname ||= $command; @history = (); $s->cmd($command); is_deeply([@history],[$command],"$testname adds one line to history"); }; foreach my $name (sort keys %tests) { exactly_one_line( $tests{$name},$name ); }; }; WWW-Mechanize-Shell-0.56/t/17-eval-multiline.t0000755000175000017500000000207613077733715020273 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use File::Temp qw( tempfile ); use vars qw($_STDOUT_ $_STDERR_); # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; use Test::More tests => 7; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); sub command_ok { my ($command,$expected,$name) = @_; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); $s->agent->get("file:t/17-eval-multiline.t"); eval { $s->cmd($command) }; is($@,"","$name does not crash") or diag "Crash on '$command'"; is($_STDERR_,undef,"$name produces no warnings"); is($_STDOUT_,$expected,"$name produces the desired output") or diag "Command: '$command'"; undef $_STDOUT_; undef $_STDERR_; }; command_ok('eval "Hello", " World"', "Hello World\n","Multiline eval"); command_ok('eval "Hello from ", $self->agent->uri || ""', "Hello from file:t/17-eval-multiline.t\n","Multiline eval substitution"); WWW-Mechanize-Shell-0.56/t/27-index.html0000644000175000017500000000264213077733715017151 0ustar corioncorion

Mui.


Nothing happens.
#KursnameBeschreibungmax. Teiln.Teilnehmermaxim. zus. EntgeltKarte erforderl.Info
1001Aerobic - AnfängerAnfänger7005.00?nein
1002Aerobic - FortgeschritteneFortgeschrittene7005.00?nein
WWW-Mechanize-Shell-0.56/t/21-autofill-re.t0000755000175000017500000000162113077733715017555 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use File::Temp qw( tempfile ); use IO::Catch; use vars qw($_STDOUT_ $_STDERR_); # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; use Test::More tests => 2; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); $s->agent->{content} = q{
}; $s->agent->{forms} = [ HTML::Form->parse($s->agent->{content}, "http://www.example.com/" )]; $s->agent->{form} = $s->agent->{forms}->[0]; $s->cmd( 'autofill /qu/i Fixed "filled"' ); $s->cmd( 'fillout' ); is($s->agent->current_form->find_input("query")->value,"filled", "autofill via RE works"); WWW-Mechanize-Shell-0.56/t/13-command-au.t0000755000175000017500000000661413077733715017363 0ustar corioncorion#!/usr/bin/perl -w use strict; use FindBin; use lib './inc'; use IO::Catch; use vars qw( $_STDOUT_ $_STDERR_ ); # pre-5.8.0's warns aren't caught by a tied STDERR. tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use Test::More tests => 6; SKIP: { use_ok('WWW::Mechanize::Shell'); eval { require HTTP::Daemon; }; skip "HTTP::Daemon required to test basic authentication",7 if ($@); # We want to be safe from non-resolving local host names delete @ENV{qw(HTTP_PROXY http_proxy CGI_HTTP_PROXY)}; my $user = 'foo'; my $pass = 'bar'; # Now start a fake webserver, fork, and connect to ourselves open SERVER, qq{"$^X" "$FindBin::Bin/401-server" $user $pass |} or die "Couldn't spawn fake server : $!"; sleep 1; # give the child some time my $url = ; chomp $url; die "Couldn't decipher host/port from '$url'" unless $url =~ m!^http://([^/]+)/!; my $host = $1; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); # First try with an inline username/password my $pwd_url = $url; $pwd_url =~ s!^http://!http://$user:$pass\@!; $pwd_url .= 'thisshouldpass'; diag "get $pwd_url"; $s->cmd( "get $pwd_url" ); diag $s->agent->res->message unless is($s->agent->res->code, 200, "Request with inline credentials gives 200"); is($s->agent->content, "user = 'foo' pass = 'bar'", "Credentials are good"); # Now try without credentials my $bare_url = $url . "thisshouldfail"; diag "get $bare_url"; $s->cmd( "get $bare_url" ); my $code = $s->agent->response->code; my $got_url = $s->agent->uri; if (! ok $code == 401 || $got_url ne $bare_url, "Request without credentials gives 401 (or is hidden by a WWW::Mechanize bug)") { diag "Page location : " . $s->agent->uri; diag $s->agent->res->as_string; }; SKIP: { if ($got_url ne $url) { skip "WWW::Mechanize 1.50 has a bug that doesn't give you a 401 page", 1; } else { like($s->agent->content, '/^auth required /', "Content requests authentication") or diag $s->agent->res->as_string; }; }; # Now try the shell command for authentication $s->cmd( "auth foo bar" ); # WWW::Mechanize breaks the LWP::UserAgent API in a bad, bad way # it even monkeypatches LWP::UserAgent so we have no better way # than to hope for the best :-((( # If it didn't return our expected credentials, we're a victim of # WWW::Mechanize's monkeypatch :-( my @credentials = $s->agent->get_basic_credentials(); if ($credentials[0] ne 'foo') { SKIP: { skip "WWW::Mechanize $WWW::Mechanize::VERSION has buggy implementation/override of ->credentials", 1; }; } else { diag "Credentials are @credentials"; use Data::Dumper; my $a = $s->agent; @credentials = $a->get_basic_credentials(); diag "Credentials are @credentials"; my @real_credentials = LWP::UserAgent::credentials($a,$host,'testing realm'); SKIP: { if ($real_credentials[0] ne $credentials[0]) { skip "WWW::Mechanize credentials() patch breaks LWP::UserAgent credentials()", 1; } else { $s->cmd( "get $url" ); diag $s->agent->res->message unless is($s->agent->res->code, 200, "Request with credentials gives 200"); is($s->agent->content, "user = 'foo' pass = 'bar'", "Credentials are good"); }; }; }; diag "Shutting down test server at $url"; $s->agent->get("${url}exit"); # shut down server }; END { close SERVER; # boom }; WWW-Mechanize-Shell-0.56/t/99-versions.t0000644000175000017500000000232213077733715017215 0ustar corioncorion#!perl -w # Stolen from ChrisDolan on use.perl.org # http://use.perl.org/comments.pl?sid=29264&cid=44309 use warnings; use strict; use File::Find; use Test::More; BEGIN { eval 'use File::Slurp; 1'; if ($@) { plan skip_all => "File::Slurp needed for testing"; exit 0; }; }; plan 'no_plan'; my $last_version = undef; sub check { return if (! m{blib/script/}xms && ! m{\.pm \z}xms); my $content = read_file($_); # only look at perl scripts, not sh scripts return if (m{blib/script/}xms && $content !~ m/\A \#![^\r\n]+?perl/xms); my @version_lines = $content =~ m/ ( [^\n]* \$VERSION \s* = [^=] [^\n]* ) /gxms; if (@version_lines == 0) { fail($_); } for my $line (@version_lines) { if (!defined $last_version) { $last_version = shift @version_lines; diag "Checking for $last_version"; pass($_); } else { is($line, $last_version, $_); } } } find({wanted => \&check, no_chdir => 1}, 'blib'); if (! defined $last_version) { fail('Failed to find any files with $VERSION'); } WWW-Mechanize-Shell-0.56/t/19-value-multi.t0000755000175000017500000000444613077733715017615 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; # pre-5.8.0's warns aren't caught by a tied STDERR. $SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; }; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; use Test::More tests => 1 +3; BEGIN { # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); }; TODO: { local $TODO = "Implement passing of multiple values"; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); $s->agent->{content} = join "", ; $s->agent->{forms} = [ HTML::Form->parse($s->agent->{content}, 'http://localhost/test/') ]; $s->agent->{form} = @{$s->agent->{forms}} ? $s->agent->{forms}->[0] : undef; $s->cmd('value cat cat_foo cat_bar cat_baz'); is_deeply([$s->agent->current_form->find_input('cat')->form_name_value],[qw[cat cat_foo cat cat_bar cat cat_baz]]) or diag $s->agent->current_form->find_input('cat')->form_name_value; $s->cmd('value cat ""'); is_deeply([$s->agent->current_form->find_input('cat')],[]); $s->cmd('value cat "cat_bar"'); is_deeply([$s->agent->current_form->find_input('cat')],[qw[cat_bar]]); }; __DATA__ WWW::Mechanize::Shell test page

Location: %s

Link /test Link /foo Link / /Link /Link in slashes/ Link foo1.save_log_server_test.tmp Link foo2.save_log_server_test.tmp Link foo3.save_log_server_test.tmp
Col1Col2Col3
A1A2A3
B1B2B3
C1C2C3

WWW-Mechanize-Shell-0.56/t/28-cmd-headers.t0000755000175000017500000000452113077733715017517 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use vars qw($_STDOUT_); tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; delete $ENV{PAGER} if $ENV{PAGER}; $ENV{PERL_HTML_DISPLAY_CLASS}="HTML::Display::Dump"; use Test::More tests => 8; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); isa_ok $s, 'WWW::Mechanize::Shell'; sub cleanup() { # clean up $_STDOUT_ so it fits on one line #diag $_STDOUT_; $_STDOUT_ =~ s/[\r\n]+/|/g; $_STDOUT_ =~ s!(?<=:)(\s+)!(">" x (length($1)/2))!eg; }; SKIP: { $s->agent->{base} = 'http://example.com'; $s->agent->update_html(< An HTML page

(H1.1)

(H2)

(H3.1)

(H3.2)

(H4)

(H1.2)

(H5)

Some spaces before this

A newline in this

HTML $s->cmd('headers'); cleanup; is($_STDOUT_,"h1:(H1.1)|h2:>(H2)|h3:>>(H3.1)|h3:>>(H3.2)|h4:>>>(H4)|h1:(H1.2)|h5:>>>>(H5)|h1:|h1:Some spaces before this|h1:A newline in this|h2:>|h3:>>|", "The default works"); undef $_STDOUT_; $s->cmd('headers 12345'); cleanup; is($_STDOUT_,"h1:(H1.1)|h2:>(H2)|h3:>>(H3.1)|h3:>>(H3.2)|h4:>>>(H4)|h1:(H1.2)|h5:>>>>(H5)|h1:|h1:Some spaces before this|h1:A newline in this|h2:>|h3:>>|", "Explicitly specifying the default works as well"); undef $_STDOUT_; $s->cmd('headers 1'); cleanup; is($_STDOUT_,"h1:(H1.1)|h1:(H1.2)|h1:|h1:Some spaces before this|h1:A newline in this|", "H1 headers works as well"); undef $_STDOUT_; $s->cmd('headers 23'); cleanup; is($_STDOUT_,"h2:>(H2)|h3:>>(H3.1)|h3:>>(H3.2)|h2:>|h3:>>|", "Restricting to a subset works too"); undef $_STDOUT_; $s->cmd('headers 25'); cleanup; is($_STDOUT_,"h2:>(H2)|h5:>>>>(H5)|h2:>|", "A noncontingous subset as well"); undef $_STDOUT_; $s->cmd('headers 52'); cleanup; is($_STDOUT_,"h2:>(H2)|h5:>>>>(H5)|h2:>|", "Even in a weirdo order"); undef $_STDOUT_; }; WWW-Mechanize-Shell-0.56/t/22-complete-command.t0000755000175000017500000000121413077733715020555 0ustar corioncorion#!/usr/bin/perl -w use strict; use Test::More tests => 2; use WWW::Mechanize::Link; BEGIN { # Choose a nonannoying HTML displayer: $ENV{PERL_HTML_DISPLAY_CLASS} = 'HTML::Display::Dump'; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); }; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); # Now test { no warnings 'redefine'; local *WWW::Mechanize::find_all_links = sub { return (WWW::Mechanize::Link->new("","foo","",""),WWW::Mechanize::Link->new("","bar","","")) }; my @comps = $s->comp_open("fo","fo",0); is_deeply(\@comps,["foo"],"Completion works"); }; WWW-Mechanize-Shell-0.56/t/98-bin.t0000755000175000017500000000144413077733715016123 0ustar corioncorionuse strict; use Test::More; # Check that all programs below bin/ compile : use File::Find; use File::Spec; my $blib = File::Spec->catfile(qw(blib lib)); my @files; my @skip; opendir DIST,'.'; my @manifest = grep { /^manifest.skip$/i } (readdir DIST); closedir DIST; if (-f $manifest[0]) { open F, "<$manifest[0]" or die "Couldn't open $manifest[0] : $!"; @skip = map { s/\s*$//; $_ } ; close F; }; find(\&wanted, "bin"); plan tests => scalar @files; foreach my $file (@files) { my $result = `$^X "-I$blib" -c "$file" 2>&1`; chomp $result; is( $result, "$file syntax OK", "Script '$file' compiles"); } sub wanted { my $name = $File::Find::name; push @files, $name if -f $_ and /\.pl$/ and not grep { $name =~ /$_/ } @skip; $File::Find::prune = 1 if -d $_ and $_ ne '.'; } WWW-Mechanize-Shell-0.56/t/26-form-no-form.t0000755000175000017500000000212613077733715017656 0ustar corioncorion#!/usr/bin/perl -w use strict; use lib './inc'; use IO::Catch; use vars qw($_STDOUT_ $_STDERR_); tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; use Test::More tests => 4; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; delete $ENV{PAGER} if $ENV{PAGER}; $ENV{PERL_HTML_DISPLAY_CLASS}="HTML::Display::Dump"; my @warnings; use_ok('WWW::Mechanize::Shell'); my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); { no warnings qw'redefine once'; *WWW::Mechanize::Shell::status = sub {}; }; $s->agent->{base} = 'http://www.google.com/'; $s->agent->update_html("No form here\n"); eval { $s->cmd("form foo"); }; is($@, '', "Can execute 'form' for a page without forms"); is($_STDOUT_,"There is no form on this page.\n","Message was printed"); is($_STDERR_,undef,"No warnings printed"); #$_STDOUT_ = undef; #$_STDERR_ = undef; #$s->cmd("save /does-not-exist/"); #is($_STDOUT_,"No match for /(?-xism:does-not-exist)/.\n","save RE error message"); #is($_STDERR_,undef,"No warnings"); WWW-Mechanize-Shell-0.56/t/02-fallback-Pod-Constant.t0000644000175000017500000000165013077733715021376 0ustar corioncorionuse strict; use Test::More tests => 4; # Disable all ReadLine functionality $ENV{PERL_RL} = 0; SKIP: { #skip "Can't load Term::ReadKey without a terminal", 4 # unless -t STDIN; eval { require Test::Without::Module; Test::Without::Module->import('Pod::Constants') }; skip "Need Test::Without::Module to test the fallback", 4 if $@; #eval { require Term::ReadKey; Term::ReadKey::GetTerminalSize(); }; #if ($@) { # no warnings 'redefine'; # *Term::ReadKey::GetTerminalSize = sub {80,24}; # diag "Term::ReadKey seems to want a terminal"; #}; use_ok("WWW::Mechanize::Shell"); my $shell = do { WWW::Mechanize::Shell->new("shell", rcfile => undef, warnings => undef ); }; isa_ok($shell,"WWW::Mechanize::Shell"); my $text; eval { $text = $shell->catch_smry('quit'); }; is( $@, '', "No error without Pod::Constants"); is( $text, undef, "No help without Pod::Constants"); }; WWW-Mechanize-Shell-0.56/t/16-form-fillout.t0000755000175000017500000010241213077733715017755 0ustar corioncorion#!/usr/bin/perl -w use strict; use FindBin; use lib './inc'; use IO::Catch; use File::Temp qw( tempfile ); use vars qw( %tests $_STDOUT_ $_STDERR_ ); use URI::URL; use LWP::Simple; # pre-5.8.0's warns aren't caught by a tied STDERR. $SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; }; tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; BEGIN { %tests = ( interactive_script_creation => { requests => 2, lines => [ 'eval @::list=qw(1 2 3 4 5 6 7 8 9 10 foo NY 11 DE 13 V 15 16 2038-01-01)', 'eval no warnings qw"once redefine"; *WWW::Mechanize::FormFiller::Value::Ask::ask_value = sub { #warn "Filled out ",$_[1]->name; my $value=shift @::list || "empty"; push @{$_[0]->{shell}->{answers}}, [ $_[1]->name, $value ]; $value }', 'get %s', 'fillout', 'submit', 'content' ], location => '%sgift_card/alphasite/www/cgi-bin/giftcard.cgi/checkout_process' }, ); }; use Test::More tests => 1 + (scalar keys %tests)*6; BEGIN { delete $ENV{PAGER}; $ENV{PERL_RL} = 0; use_ok('WWW::Mechanize::Shell'); }; SKIP: { # Disable all ReadLine functionality my $HTML = do { local $/; }; eval { require HTTP::Daemon; }; skip "HTTP::Daemon required to test script/code identity",(scalar keys %tests)*6 if ($@); require 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)}; my $actual_requests; { no warnings 'redefine'; my $old_request = *WWW::Mechanize::request{CODE}; *WWW::Mechanize::request = sub { $actual_requests++; goto &$old_request; }; *WWW::Mechanize::Shell::status = sub {}; }; for my $name (sort keys %tests) { $_STDOUT_ = ''; undef $_STDERR_; $actual_requests = 0; my @lines = @{$tests{$name}->{lines}}; my $requests = $tests{$name}->{requests}; my $server = Test::HTTP::LocalServer->spawn( html => $HTML ); my $code_port = $server->port; my $result_location = sprintf $tests{$name}->{location}, $server->url; my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); for my $line (@lines) { no warnings; $line = sprintf $line, $server->url; $s->cmd($line); }; $s->cmd('eval $self->agent->uri'); my $code_output = $_STDOUT_; diag join( "\n", $s->history ) unless is($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"); my $code_requests = $server->get_log; my $script_server = Test::HTTP::LocalServer->spawn(html => $HTML); my $script_port = $script_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); 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; unless (is($compile,"$tempname syntax OK","$name compiles")) { $script_server->stop; diag $script; ok(0, "Script $name didn't compile" ); ok(0, "Script $name didn't compile" ); } else { my ($output); my $command = qq($^X -Ilib "$tempname" 2>&1); $output = `$command`; $output =~ s!^Cookie:.*$!Cookie: !smg; # cookies get re-ordered, sometimes $code_output =~ s!^Cookie:.*$!Cookie: !smg; # cookies get re-ordered, sometimes is( $output, $code_output, "Output of $name is identical" ) or diag "Script:\n$script"; my $script_requests = $script_server->get_log; $code_requests =~ s!\b$code_port\b!$script_port!smg; $code_requests =~ s!^Cookie:.*$!Cookie: !smg; # cookies get re-ordered, sometimes $script_requests =~ s!^Cookie:.*$!Cookie: !smg; # cookies get re-ordered, sometimes is($code_requests,$script_requests,"$name produces identical queries") or diag $script; }; unlink $tempname or diag "Couldn't remove tempfile '$name' : $!"; }; unlink $_ for (<*.save_log_server_test.tmp>); }; __DATA__ - Gift Cards

 

Gift Card

Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat. Duis autem vel eum iriure dolor in hendrerit in vulputate velit esse molestie consequat, vel illum dolore eu feugiat nulla facilisis at vero eros et accumsan et iusto odio dignissim qui blandit praesent luptatum zzril delenit augue duis dolore te feugait nulla facilisi. Lorem ipsum dolor sit amet, consectetuer adipiscing elit, sed diam nonummy nibh euismod tincidunt ut laoreet dolore magna aliquam erat volutpat. Ut wisi enim ad minim veniam, quis nostrud exerci tation ullamcorper suscipit lobortis nisl ut aliquip ex ea commodo consequat.

Delivery Information
recipient Name:
First: *
Middle:
Last: *
Nickname:
Room Number:
Card Amount:
* (i.e. $20.00)
Billing Information
First Name: *
Last Name: *
Email Address : *#
Address: *
City: *
State: *
Zip: *
Country: *
Daytime Phone: *
(i.e. (123)555-1212)
Card Type: *
Name on Card: *
Credit Card Number : *
(no spaces or dashes) i.e.1234567890121234 (use Visa and 4111111111111111 for testing)
Expiration Date: (in format: MM/YY)  *

Your credit information will be sent through a secure and encrypted channel. After submit has been selected, order cannot be changed or cancelled.

 

# Your e-mail address will be used only for receipt purposes and to contact you if there is a problem with your order and we cannot reach you by phone.

WWW-Mechanize-Shell-0.56/README.mkdn0000644000175000017500000004424513077733715016300 0ustar corioncorion [![Build Status](https://travis-ci.org/Corion/WWW-Mechanize-Shell.svg?branch=master)](https://github.com/Corion/WWW-Mechanize-Shell) # NAME WWW::Mechanize::Shell - An interactive shell for WWW::Mechanize # SYNOPSIS From the command line as perl -MWWW::Mechanize::Shell -eshell or alternatively as a custom shell program via : #!/usr/bin/perl -w use strict; use WWW::Mechanize::Shell; my $shell = WWW::Mechanize::Shell->new("shell"); if (@ARGV) { $shell->source_file( @ARGV ); } else { $shell->cmdloop; }; # DESCRIPTION This module implements a www-like shell above WWW::Mechanize and also has the capability to output crude Perl code that recreates the recorded session. Its main use is as an interactive starting point for automating a session through WWW::Mechanize. The cookie support is there, but no cookies are read from your existing browser sessions. See [HTTP::Cookies](https://metacpan.org/pod/HTTP::Cookies) on how to implement reading/writing your current browsers cookies. ## `WWW::Mechanize::Shell->new %ARGS` This is the constructor for a new shell instance. Some of the options can be passed to the constructor as parameters. By default, a file `.mechanizerc` (respectively `mechanizerc` under Windows) in the users home directory is executed before the interactive shell loop is entered. This can be used to set some defaults. If you want to supply a different filename for the rcfile, the `rcfile` parameter can be passed to the constructor : rcfile => '.myapprc', ## `$shell->release_agent` Since the shell stores a reference back to itself within the WWW::Mechanize instance, it is necessary to break this circular reference. This method does this. ## `$shell->source_file FILENAME` The `source_file` method executes the lines of FILENAME as if they were typed in. $shell->source_file( $filename ); ## `$shell->display_user_warning` All user warnings are routed through this routine so they can be rerouted / disabled easily. ## `$shell->print_paged LIST` Prints the text in LIST using `$ENV{PAGER}`. If `$ENV{PAGER}` is empty, prints directly to `STDOUT`. Most of this routine comes from the `perldoc` utility. ## `$shell->link_text LINK` Returns a meaningful text from a WWW::Mechanize::Link object. This is (in order of precedence) : $link->text $link->name $link->url ## `$shell->history` Returns the (relevant) shell history, that is, all commands that were not solely for the information of the user. The lines are returned as a list. print join "\n", $shell->history; ## `$shell->script` Returns the shell history as a Perl program. The lines are returned as a list. The lines do not have a one-by-one correspondence to the lines in the history. print join "\n", $shell->script; ## `$shell->status` `status` is called for status updates. ## `$shell->display FILENAME LINES` `display` is called to output listings, currently from the `history` and `script` commands. If the second parameter is defined, it is the name of the file to be written, otherwise the lines are displayed to the user. # COMMANDS The shell implements various commands : ## exit Leaves the shell. ## restart Restart the shell. This is mostly useful when you are modifying the shell itself. It dosen't work if you use the shell in oneliner mode with `-e`. ## get Download a specific URL. This is used as the entry point in all sessions Syntax: get URL ## save Download a link into a file. If more than one link matches the RE, all matching links are saved. The filename is taken from the last part of the URL. Alternatively, the number of a link may also be given. Syntax: save RE ## content Display the content for the current page. Syntax: content \[FILENAME\] If the FILENAME argument is provided, save the content to the file. A trailing "\\n" is added to the end of the content when using the shell, so this might not be ideally suited to save binary files without manual editing of the produced script. ## title Display the current page title as found in the `` tag. ## headers Prints all `<H1>` through `<H5>` strings found in the content, indented accordingly. With an argument, prints only those levels; e.g., `headers 145` prints H1,H4,H5 strings only. ## ua Get/set the current user agent Syntax: # fake Internet Explorer ua "Mozilla/4.0 (compatible; MSIE 4.01; Windows 98)" # fake QuickTime v5 ua "QuickTime (qtver=5.0.2;os=Windows NT 5.0Service Pack 2)" # fake Mozilla/Gecko based ua "Mozilla/5.001 (windows; U; NT4.0; en-us) Gecko/25250101" # set empty user agent : ua "" ## links Display all links on a page The links numbers displayed can used by `open` to directly select a link to follow. ## parse Dump the output of HTML::TokeParser of the current content ## forms Display all forms on the current page. ## form Select the form named NAME If NAME matches `/^\d+$/`, it is assumed to be the (1-based) index of the form to select. There is no way of selecting a numerically named form by its name. ## dump Dump the values of the current form ## value Set a form value Syntax: value NAME [VALUE] ## tick Set checkbox marks Syntax: tick NAME VALUE(s) If no value is given, all boxes are checked. ## untick Remove checkbox marks Syntax: untick NAME VALUE(s) If no value is given, all marks are removed. ## submit submits the form without clicking on any button ## click Clicks on the button named NAME. No regular expression expansion is done on NAME. Syntax: click NAME If you have a button that has no name (displayed as NONAME), use click "" to click on it. ## open <open> accepts one argument, which can be a regular expression or the number of a link on the page, starting at zero. These numbers are displayed by the `links` function. It goes directly to the page if a number is used or if the RE has one match. Otherwise, a list of links matching the regular expression is displayed. The regular expression should start and end with "/". Syntax: open [ RE | # ] ## back Go back one page in the browser page history. ## reload Repeat the last request, thus reloading the current page. Note that also POST requests are blindly repeated, as this command is mostly intended to be used when testing server side code. ## browse Open the web browser with the current page Displays the current page in the browser. ## set Set a shell option Syntax: set OPTION [value] The command lists all valid options. Here is a short overview over the different options available : autosync - automatically synchronize the browser window autorestart - restart the shell when any required module changes This does not work with C<-e> oneliners. watchfiles - watch all required modules for changes cookiefile - the file where to store all cookies dumprequests - dump all requests to STDOUT dumpresponses - dump the headers of the responses to STDOUT verbose - print commands to STDERR as they are run, when sourcing from a file ## history Display your current session history as the relevant commands. Syntax: history [FILENAME] Commands that have no influence on the browser state are not added to the history. If a parameter is given to the `history` command, the history is saved to that file instead of displayed onscreen. ## script Display your current session history as a Perl script using WWW::Mechanize. Syntax: script [FILENAME] If a parameter is given to the `script` command, the script is saved to that file instead of displayed on the console. This command was formerly known as `history`. ## comment Adds a comment to the script and the history. The comment is prepended with a \\n to increase readability. ## fillout Fill out the current form Interactively asks the values hat have no preset value via the autofill command. ## auth Set basic authentication credentials. Syntax: auth user password If you know the authority and the realm in advance, you can presupply the credentials, for example at the start of the script : >auth corion secret >get http://www.example.com Retrieving http://www.example.com(200) http://www.example.com> ## table Display a table described by the columns COLUMNS. Syntax: table COLUMNS Example: table Product Price Description If there is a table on the current page that has in its first row the three columns `Product`, `Price` and `Description` (not necessarily in that order), the script will display these columns of the whole table. The `HTML::TableExtract` module is needed for this feature. ## tables Display a list of tables. Syntax: tables This command will display the top row for every table on the current page. This is convenient if you want to find out what the exact spellings for each column are. The command does not always work nice, for example if a site uses tables for layout, it will be harder to guess what tables are irrelevant and what tables are relevant. [HTML::TableExtract](https://metacpan.org/pod/HTML::TableExtract) is needed for this feature. ## cookies Set the cookie file name Syntax: cookies FILENAME ## autofill Define an automatic value Sets a form value to be filled automatically. The NAME parameter is the WWW::Mechanize::FormFiller::Value subclass you want to use. For session fields, `Keep` is a good candidate, for interactive stuff, `Ask` is a value implemented by the shell. A field name starting and ending with a slash (`/`) is taken to be a regular expression and will be applied to all fields with their name matching the expression. A field with a matching name still takes precedence over the regular expression. Syntax: autofill NAME [PARAMETERS] Examples: autofill login Fixed corion autofill password Ask autofill selection Random red green orange autofill session Keep autofill "/date$/" Random::Date string "%m/%d/%Y" ## eval Evaluate Perl code and print the result Syntax: eval CODE For the generated scripts, anything matching the regular expression `/\$self->agent\b/` is automatically replaced by `$agent` in your eval code, to do the Right Thing. Examples: # Say hello eval "Hello World" # And take a look at the current content type eval $self->agent->ct ## source Execute a batch of commands from a file Syntax: source FILENAME ## versions Print the version numbers of important modules Syntax: versions ## timeout Set new timeout value for the agent. Effects all subsequent requests. VALUE is in seconds. Syntax: timeout VALUE ## ct prints the content type of the most current response. Syntax: ct ## referrer set the value of the Referer: header Syntax: referer URL referrer URL ## referer Alias for referrer ## response display the last server response ## `$shell->munge_code( CODE )` Munges a coderef to become code fit for output independent of WWW::Mechanize::Shell. ## `shell` This subroutine is exported by default as a convenience method so that the following oneliner invocation works: perl -MWWW::Mechanize::Shell -eshell You can pass constructor arguments to this routine as well. Any scripts given in `@ARGV` will be run. If `@ARGV` is empty, an interactive loop will be started. # SAMPLE SESSIONS ## Entering values # Search for a term on Google get http://www.google.com value q "Corions Homepage" click btnG script # (yes, this is a bad example of automating, as Google # already has a Perl API. But other sites don't) ## Retrieving a table get http://www.perlmonks.org open "/Saints in/" table User Experience Level script # now you have a program that gives you a csv file of # that table. ## Uploading a file get http://aliens:xxxxx/ value f path/to/file click "upload" ## Batch download # download prerelease versions of my modules get http://www.corion.net/perl-dev save /.tar.gz$/ # REGULAR EXPRESSION SYNTAX Some commands take regular expressions as parameters. A regular expression **must** be a single parameter matching `^/.*/([isxm]+)?$`, so you have to use quotes around it if the expression contains spaces : /link_foo/ # will match as (?-xims:link_foo) "/link foo/" # will match as (?-xims:link foo) Slashes do not need to be escaped, as the shell knows that a RE starts and ends with a slash : /link/foo/ # will match as (?-xims:link/foo) "/link/ /foo/" # will match as (?-xims:link/\s/foo) The `/i` modifier works as expected. If you desire more power over the regular expressions, consider dropping to Perl or recommend me a good parser module for regular expressions. # DISPLAYING HTML WWW::Mechanize::Shell now uses the module HTML::Display to display the HTML of the current page in your browser. Have a look at the documentation of HTML::Display how to make it use your browser of choice in the case it does not already guess it correctly. # FILLING FORMS VIA CUSTOM CODE If you want to stay within the confines of the shell, but still want to fill out forms using custom Perl code, here is a recipe how to achieve this : Code passed to the `eval` command gets evalutated in the WWW::Mechanize::Shell namespace. You can inject new subroutines there and these get picked up by the Callback class of WWW::Mechanize::FormFiller : # Fill in the "date" field with the current date/time as string eval sub &::custom_today { scalar localtime }; autofill date Callback WWW::Mechanize::Shell::custom_today fillout This method can also be used to retrieve data from shell scripts : # Fill in the "date" field with the current date/time as string # works only if there is a program "date" eval sub &::custom_today { chomp `date` }; autofill date Callback WWW::Mechanize::Shell::custom_today fillout As the namespace is different between the shell and the generated script, make sure you always fully qualify your subroutine names, either in your own namespace or in the main namespace. # GENERATED SCRIPTS The `script` command outputs a skeleton script that reproduces your actions as done in the current session. It pulls in `WWW::Mechanize::FormFiller`, which is possibly not needed. You should add some error and connection checking afterwards. # ADDING FIELDS TO HTML If you are automating a JavaScript dependent site, you will encounter JavaScript like this : <script> document.write( "<input type=submit name=submit>" ); </script> HTML::Form will not know about this and will not have provided a submit button for you (understandably). If you want to create such a submit button from within your automation script, use the following code : $agent->current_form->push_input( submit => { name => "submit", value =>"submit" } ); This also works for other dynamically generated input fields. To fake an input field from within a shell session, use the `eval` command : eval $self->agent->current_form->push_input(submit=>{name=>"submit",value=>"submit"}); And yes, the generated script should do the Right Thing for this eval as well. # LOCAL FILES If you want to use the shell on a local file without setting up a `http` server to serve the file, you can use the `file:` URI scheme to load it into the "browser": get file:local.html forms # PROXY SUPPORT Currently, the proxy support is realized via a call to the `env_proxy` method of the WWW::Mechanize object, which loads the proxies from the environment. There is no provision made to prevent using proxies (yet). The generated scripts also load their proxies from the environment. # ONLINE HELP The online help feature is currently a bit broken in `Term::Shell`, but a fix is in the works. Until then, you can re-enable the dynamic online help by patching `Term::Shell` : Remove the three lines my $smry = exists $o->{handlers}{$h}{smry} ? $o->summary($h) : "undocumented"; in `sub run_help` and replace them by my $smry = $o->summary($h); The shell works without this patch and the online help is still available through `perldoc WWW::Mechanize::Shell` # BUGS Bug reports are very welcome - please use the RT interface at https://rt.cpan.org/NoAuth/Bugs.html?Dist=WWW-Mechanize-Shell or send a descriptive mail to bug-WWW-Mechanize-Shell@rt.cpan.org . Please try to include as much (relevant) information as possible - a test script that replicates the undesired behaviour is welcome every time! - The two parameter version of the `auth` command guesses the realm from the last received response. Currently a RE is used to extract the realm, but this fails with some servers resp. in some cases. Use the four parameter version of `auth`, or if not possible, code the extraction in Perl, either in the final script or through `eval` commands. - The shell currently detects when you want to follow a JavaScript link and tells you that this is not supported. It would be nicer if there was some callback mechanism to (automatically?) extract URLs from JavaScript-infected links. # TODO - Add XPath expressions (by moving `WWW::Mechanize` from HTML::Parser to XML::XMLlib or maybe easier, by tacking Class::XPath onto an HTML tree) - Add `head` as a command ? - Optionally silence the HTML::Parser / HTML::Forms warnings about invalid HTML. # EXPORT The routine `shell` is exported into the importing namespace. This is mainly for convenience so you can use the following commandline invocation of the shell like with CPAN : perl -MWWW::Mechanize::Shell -e"shell" # REPOSITORY The public repository of this module is [https://github.com/Corion/WWW-Mechanize-Shell](https://github.com/Corion/WWW-Mechanize-Shell). # SUPPORT The public support forum of this module is [http://perlmonks.org/](http://perlmonks.org/). # COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (C) 2002-2017 Max Maischein # AUTHOR Max Maischein, <corion@cpan.org> Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome ! # SEE ALSO [WWW::Mechanize](https://metacpan.org/pod/WWW::Mechanize),[WWW::Mechanize::FormFiller](https://metacpan.org/pod/WWW::Mechanize::FormFiller),[WWW::Mechanize::Firefox](https://metacpan.org/pod/WWW::Mechanize::Firefox) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/.gitignore�����������������������������������������������������������������0000644�0001750�0001750�00000000223�13077733715�016444� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Makefile Makefile.old *.tar.gz *.bak pm_to_blib blib/ WWW-Mechanize-Shell-* WWW-Mechanize-Shell-*/ .releaserc .lwpcookies CVS MYMETA.* �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/META.yml�������������������������������������������������������������������0000644�0001750�0001750�00000001067�13077733716�015735� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������--- abstract: 'An interactive shell for WWW::Mechanize' author: - 'Max Maischein <corion@cpan.org>' build_requires: {} dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: WWW-Mechanize-Shell no_index: directory: - t - inc resources: repository: git://github.com/Corion/WWW-Mechanize-Shell.git version: '0.56' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' x_static_install: 1 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/lib/�����������������������������������������������������������������������0000755�0001750�0001750�00000000000�13077733716�015226� 5����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/lib/WWW/�������������������������������������������������������������������0000755�0001750�0001750�00000000000�13077733716�015712� 5����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/lib/WWW/Mechanize/���������������������������������������������������������0000755�0001750�0001750�00000000000�13077733716�017615� 5����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/lib/WWW/Mechanize/Shell.pm�������������������������������������������������0000644�0001750�0001750�00000140547�13077733715�021234� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package WWW::Mechanize::Shell; use strict; use Carp; use WWW::Mechanize; use WWW::Mechanize::FormFiller; use HTTP::Cookies; use parent qw( Term::Shell ); use Exporter 'import'; use FindBin; use File::Temp qw(tempfile); use URI::URL; use Hook::LexWrap; use HTML::Display qw(); use HTML::TokeParser::Simple; use B::Deparse; use vars qw( $VERSION @EXPORT %munge_map ); $VERSION = '0.56'; @EXPORT = qw( &shell ); =head1 NAME WWW::Mechanize::Shell - An interactive shell for WWW::Mechanize =head1 SYNOPSIS From the command line as perl -MWWW::Mechanize::Shell -eshell or alternatively as a custom shell program via : =for example begin #!/usr/bin/perl -w use strict; use WWW::Mechanize::Shell; my $shell = WWW::Mechanize::Shell->new("shell"); if (@ARGV) { $shell->source_file( @ARGV ); } else { $shell->cmdloop; }; =for example end =for example_testing BEGIN { require WWW::Mechanize::Shell; $ENV{PERL_RL} = 0; $ENV{COLUMNS} = '80'; $ENV{LINES} = '24'; }; BEGIN { no warnings 'once'; no warnings 'redefine'; *WWW::Mechanize::Shell::cmdloop = sub {}; *WWW::Mechanize::Shell::display_user_warning = sub {}; *WWW::Mechanize::Shell::source_file = sub {}; }; isa_ok( $shell, "WWW::Mechanize::Shell" ); =head1 DESCRIPTION This module implements a www-like shell above WWW::Mechanize and also has the capability to output crude Perl code that recreates the recorded session. Its main use is as an interactive starting point for automating a session through WWW::Mechanize. The cookie support is there, but no cookies are read from your existing browser sessions. See L<HTTP::Cookies> on how to implement reading/writing your current browsers cookies. =head2 C<WWW::Mechanize::Shell-E<gt>new %ARGS> This is the constructor for a new shell instance. Some of the options can be passed to the constructor as parameters. By default, a file C<.mechanizerc> (respectively C<mechanizerc> under Windows) in the users home directory is executed before the interactive shell loop is entered. This can be used to set some defaults. If you want to supply a different filename for the rcfile, the C<rcfile> parameter can be passed to the constructor : rcfile => '.myapprc', =cut sub init { my ($self) = @_; my ($name,%args) = @{$self->{API}{args}}; $self->{agent} = WWW::Mechanize->new(); $self->{formfiller} = WWW::Mechanize::FormFiller->new(default => [ Ask => $self ]); $self->{history} = []; $self->{options} = { autosync => 0, warnings => (exists $args{warnings} ? $args{warnings} : 1), autorestart => 0, watchfiles => (exists $args{watchfiles} ? $args{watchfiles} : 1), cookiefile => 'cookies.txt', dumprequests => 0, dumpresponses => 0, verbose => 0, }; # Install the request dumper : $self->{request_wrapper} = wrap 'LWP::UserAgent::request', #pre => sub { printf STDERR "Dumping? %s\n",$self->option("dumprequests"); $self->request_dumper($_[1]) if $self->option("dumprequests"); }, pre => sub { $self->request_dumper($_[1]) if $self->option("dumprequests"); }, post => sub { $self->response_dumper($_[-1]) if $self->option("dumpresponses"); }; $self->{redirect_ok_wrapper} = wrap 'WWW::Mechanize::redirect_ok', post => sub { return unless $_[1]; $self->status( "\nRedirecting to ".$_[1]->uri."\n" ); $_[-1] }; # Load the proxy settings from the environment $self->agent->env_proxy(); # Read our .rc file : # I could use File::Homedir, but the docs claim it dosen't work on Win32. Maybe # I should just release a patch for File::Homedir then... Not now. my $sourcefile; if (exists $args{rcfile}) { $sourcefile = delete $args{rcfile}; } else { my $userhome = $^O =~ /win32/i ? $ENV{'USERPROFILE'} || $ENV{'HOME'} : ((getpwuid($<))[7]); $sourcefile = "$userhome/.mechanizerc" if -f "$userhome/.mechanizerc"; }; $self->option('cookiefile', $args{cookiefile}) if (exists $args{cookiefile}); $self->source_file($sourcefile) if defined $sourcefile; $self->{browser} = undef; # Keep track of the files we consist of, to enable automatic reloading $self->{files} = undef; if ($self->option('watchfiles')) { eval { my @files = grep { -f && -r && $_ ne '-e' } values %INC; local $, = ","; require File::Modified; $self->{files} = File::Modified->new(files=>[@files]); }; $self->display_user_warning( "Module File::Modified not found. Automatic reloading disabled.\n" ) if ($@); }; }; =head2 C<$shell-E<gt>release_agent> Since the shell stores a reference back to itself within the WWW::Mechanize instance, it is necessary to break this circular reference. This method does this. =cut sub release_agent { my ($self) = @_; use Data::Dumper; warn Dumper $self; undef $self->{request_wrapper}; undef $self->{redirect_ok_wrapper}; $self->{agent} = undef; }; =head2 C<$shell-E<gt>source_file FILENAME> The C<source_file> method executes the lines of FILENAME as if they were typed in. $shell->source_file( $filename ); =cut sub source_file { my ($self,$filename) = @_; local $_; # just to be on the safe side that we don't clobber outside users of $_ local *F; open F, "< $filename" or die "Couldn't open '$filename' : $!\n"; while (<F>) { $self->cmd($_); warn "cmd: $_" if $self->{options}->{verbose}; }; close F; }; sub add_history { my ($self,@code) = @_; push @{$self->{history}},[$self->line,join "",@code]; }; =head2 C<$shell-E<gt>display_user_warning> All user warnings are routed through this routine so they can be rerouted / disabled easily. =cut sub display_user_warning { my ($self,@message) = @_; warn @message if $self->option('warnings'); }; =head2 C<$shell-E<gt>print_paged LIST> Prints the text in LIST using C<$ENV{PAGER}>. If C<$ENV{PAGER}> is empty, prints directly to C<STDOUT>. Most of this routine comes from the C<perldoc> utility. =cut sub print_paged { my $self = shift; if ($ENV{PAGER} and -t STDOUT) { my ($fh,$filename) = tempfile(); print $fh $_ for @_; close $fh; my @pagers = ($ENV{PAGER},qq{"$^X" -p}); foreach my $pager (@pagers) { if ($^O eq 'VMS') { last if system("$pager $filename") == 0; # quoting prevents logical expansion } else { last if system(qq{$pager "$filename"}) == 0; } }; unlink $filename or $self->display_user_warning("Couldn't unlink tempfile $filename : $!\n"); } else { print $_ for @_; }; }; sub agent { $_[0]->{agent}; }; sub option { my ($self,$option,$value) = @_; if (exists $self->{options}->{$option}) { my $result = $self->{options}->{$option}; if (scalar @_ == 3) { $self->{options}->{$option} = $value; }; $result; } else { Carp::carp "Unknown option '$option'"; undef; }; }; sub restart_shell { if ($0 ne '-e') { print "Restarting $0\n"; exec $^X, $0, @ARGV; }; }; sub precmd { my $self = shift @_; # We want to restart when any module was changed if ($self->{files} and $self->{files}->changed()) { print "One or more of the base files were changed\n"; $self->restart_shell if ($self->option('autorestart')); }; $self->SUPER::precmd(@_); }; sub browser { my ($self) = @_; $self->{browser} ||= HTML::Display->new(); $self->{browser}; }; sub sync_browser { my ($self) = @_; # We only can display html if we have any : return unless $self->agent->res; # Prepare the HTML for local display : my $unclean = $self->agent->content; my $html = ''; # ugly fix: # strip all target='_blank' attributes from the HTML: my $p = HTML::TokeParser::Simple->new(\$unclean); while (my $token = $p->get_token) { $token->delete_attr('target') if $token->is_start_tag; $html .= $token->as_is; }; my $location = $self->agent->{uri}; my $browser = $self->browser; $browser->display( html => $html, location => $location ); }; sub prompt_str { my $self = shift; if ($self->agent->response) { return ($self->agent->uri || "") . ">" } else { return "(no url)>" }; }; sub request_dumper { print $_[1]->as_string }; sub response_dumper { if (ref $_[1] eq 'ARRAY') { print $_[1]->[0]->as_string; } else { print $_[1]->as_string; } }; sub re_or_string { my ($self,$arg) = @_; if ($arg =~ m!^/(.*)/([imsx]*)$!) { my ($re,$mode) = ($1,$2); $re =~ s!([^\\])/!$1\\/!g; $arg = eval "qr/$re/$mode"; }; $arg; }; =head2 C<< $shell->link_text LINK >> Returns a meaningful text from a WWW::Mechanize::Link object. This is (in order of precedence) : $link->text $link->name $link->url =cut sub link_text { my ($self,$link) = @_; my $result; for (qw( text name url )) { $result = $link->$_ and last; }; $result; }; =head2 C<$shell-E<gt>history> Returns the (relevant) shell history, that is, all commands that were not solely for the information of the user. The lines are returned as a list. print join "\n", $shell->history; =cut sub history { my ($self) = @_; map { $_->[0] } @{$self->{history}} }; =head2 C<$shell-E<gt>script> Returns the shell history as a Perl program. The lines are returned as a list. The lines do not have a one-by-one correspondence to the lines in the history. print join "\n", $shell->script; =cut sub script { my ($self,$prefix) = @_; $prefix ||= ""; my @result = sprintf <<'HEADER', $^X; #!%s -w use strict; use WWW::Mechanize; use WWW::Mechanize::FormFiller; use URI::URL; my $agent = WWW::Mechanize->new( autocheck => 1 ); my $formfiller = WWW::Mechanize::FormFiller->new(); $agent->env_proxy(); HEADER push @result, map { my $x = $_->[1]; $x =~ s/^/$prefix/mg; $x } @{$self->{history}}; @result; }; =head2 C<$shell-E<gt>status> C<status> is called for status updates. =cut sub status { my $self = shift; print join "", @_; }; =head2 C<$shell-E<gt>display FILENAME LINES> C<display> is called to output listings, currently from the C<history> and C<script> commands. If the second parameter is defined, it is the name of the file to be written, otherwise the lines are displayed to the user. =cut sub display { my ($self,$filename,@lines) = @_; if (defined $filename) { eval { open my $f, ">", $filename or die "Couldn't create $filename : $!"; binmode $f; print $f join( "", map { "$_\n" } (@lines) ); close $f; }; warn $@ if $@; } else { $self->print_paged( join( "", map { "$_\n" } (@lines) )); }; }; # sub-classed from Term::Shell to handle all run_ requests that have no corresponding sub # This is used for comments sub catch_run { my ($self) = shift; my ($command) = @_; if ($command =~ /^\s*#/) { # Hey, it's a comment. } else { print $self->msg_unknown_cmd($command); }; }; # sub-classed from Term::Shell to handle all smry requests sub catch_smry { my ($self,$command) = @_; my $result = eval { require Pod::Constants; my @summary; my $module = (ref $self ).".pm"; $module =~ s!::!/!g; $module = $INC{$module}; Pod::Constants::import_from_file( $module, $command => \@summary ); $summary[0]; }; if ($@) { return undef; }; return $result; }; # sub-classed from Term::Shell to handle all help requests sub catch_help { my ($self,$command) = @_; my @result = eval { require Pod::Constants; my @summary; my $module = (ref $self ).".pm"; $module =~ s!::!/!g; $module = $INC{$module}; Pod::Constants::import_from_file( $module, $command => \@summary ); @summary; }; if ($@) { my $module = ref $self; $self->display_user_warning( "Pod::Constants not available. Use perldoc $module for help.\n" ); return undef; }; return join( "\n", @result) . "\n"; }; =head1 COMMANDS The shell implements various commands : =head2 exit Leaves the shell. =cut sub alias_exit { qw(quit) }; =head2 restart Restart the shell. This is mostly useful when you are modifying the shell itself. It dosen't work if you use the shell in oneliner mode with C<-e>. =cut sub run_restart { my ($self) = @_; $self->restart_shell; }; sub activate_first_form { $_[0]->agent->form_number(1) if $_[0]->agent->forms and scalar @{$_[0]->agent->forms}; }; =head2 get Download a specific URL. This is used as the entry point in all sessions Syntax: get URL =cut sub run_get { my ($self,$url) = @_; $self->status( "Retrieving $url" ); my $code; eval { $self->agent->get($url) }; if ($@) { print "\n$@\n" if $@; $self->agent->back; } else { $code = $self->agent->res->code; $self->status( "($code)\n" ); }; $self->activate_first_form; $self->sync_browser if $self->option('autosync'); $self->add_history( sprintf q{$agent->get('%s');}."\n".q{ $agent->form_number(1) if $agent->forms and scalar @{$agent->forms};}, $url); }; =head2 save Download a link into a file. If more than one link matches the RE, all matching links are saved. The filename is taken from the last part of the URL. Alternatively, the number of a link may also be given. Syntax: save RE =cut sub run_save { my ($self,$user_link) = @_; unless (defined $user_link) { print "No link given to save\n"; return }; my @history; my @links = (); my @all_links = $self->agent->links; push @history, q{my @links;} . "\n"; push @history, q{my @all_links = $agent->links();} . "\n"; $user_link = $self->re_or_string($user_link); if (ref $user_link) { my $count = -1; my $re = $user_link; @links = map { $count++; ((defined $_->text && $_->text =~ /$re/)||(defined $_->url && $_->url =~ /$re/)) ? $count : () } @all_links; if (@links == 0) { print "No match for /$re/.\n"; }; push @history, q{my $count = -1;} . "\n"; push @history, sprintf q{@links = map { $count++; ((defined $_->text && $_->text =~ qr(%s))||(defined $_->url && $_->url =~ qr(%s))) ? $count : () } @all_links;} . "\n", $re, $re; } else { @links = $user_link; push @history, sprintf q{@links = '%s';} . "\n", $user_link; }; if (@links) { $self->add_history( @history,<<'CODE' ); my $base = $agent->uri; for my $link (@links) { my $target = $all_links[$link]->url; my $url = URI::URL->new($target,$base); $target = $url->path; $target =~ s!^(.*/)?([^/]+)$!$2!; $url = $url->abs; # use this line instead of the next in case you want to use smart mirroring #$agent->mirror($url,$target); $agent->get( $url, ':content_file' => $target ); }; CODE my $base = $self->agent->uri; for my $link (@links) { my $target = $all_links[$link]->url; my $url = URI::URL->new($target,$base); $target = $url->path; $target =~ s!^(.*/)?([^/]+)$!$2!; $url = $url->abs; eval { $self->status( "$url => $target" ); $self->agent->get( $url, ':content_file' => $target ); }; warn $@ if $@; }; } }; =head2 content Display the content for the current page. Syntax: content [FILENAME] If the FILENAME argument is provided, save the content to the file. A trailing "\n" is added to the end of the content when using the shell, so this might not be ideally suited to save binary files without manual editing of the produced script. =cut sub run_content { my ($self, $filename) = @_; $self->display($filename, $self->agent->content); if ($filename) { $self->add_history( sprintf '{ my $filename = q{%s}; local *F; open F, "> $filename" or die "$filename: $!"; binmode F; print F $agent->content,"\n"; close F };', $filename ); } else { $self->add_history('print $agent->content,"\n";'); }; }; =head2 title Display the current page title as found in the C<< <TITLE> >> tag. =cut sub run_title { my ($self) = @_; my $title = $self->agent->title; if (! defined $title) { $title = "<missing title>" } elsif ($title eq '') { $title = "<empty title>" }; print "$title\n"; }; =head2 headers Prints all C<< <H1> >> through C<< <H5> >> strings found in the content, indented accordingly. With an argument, prints only those levels; e.g., C<headers 145> prints H1,H4,H5 strings only. =cut sub run_headers { my ($self,$headers) = @_; $headers ||= "12345"; my $content = $self->agent->content; # Convert the $headers argument to a RE matching # the header tags: my $wanted = join "|", map { "H$_" } split //, $headers; $wanted = qr/^$wanted$/i; #warn $wanted; my $p = HTML::TokeParser::Simple->new( \$content ); while ( my $token = $p->get_token ) { # This prints all text in an HTML doc (i.e., it strips the HTML) if ($token->is_start_tag($wanted)) { my $tag = $token->get_tag; # Indent with two spaces per level my $indent; $indent = $1 if ($tag =~ /(\d)/); $indent ||= 1; $indent--; $indent *= 2; # advance and print the first text tag we encounter while ($token and not $token->is_text and not $token->is_end_tag($wanted)) { $token = $p->get_token }; my $text = "<no text>"; if ($token and $token->is_text) { $text = $token->as_is; if ($text !~ /\S/) { $text = "<empty tag>"; }; }; # Clean up whitespace $text =~ s/^\s+//g; $text =~ s/\s+$//g; $text =~ s/\s+/ /g; printf "%s:%${indent}s%s\n", $tag, "", $text; }; } }; =head2 ua Get/set the current user agent Syntax: # fake Internet Explorer ua "Mozilla/4.0 (compatible; MSIE 4.01; Windows 98)" # fake QuickTime v5 ua "QuickTime (qtver=5.0.2;os=Windows NT 5.0Service Pack 2)" # fake Mozilla/Gecko based ua "Mozilla/5.001 (windows; U; NT4.0; en-us) Gecko/25250101" # set empty user agent : ua "" =cut sub run_ua { my ($self,$ua) = @_; my ($result) = $self->agent->agent; if (scalar @_ == 2) { $self->agent->agent($ua); $self->add_history( sprintf q{$agent->agent('%s');}, $ua); } else { print "Current user agent: $result\n"; }; }; =head2 links Display all links on a page The links numbers displayed can used by C<open> to directly select a link to follow. =cut sub run_links { my ($self) = @_; my @links = $self->agent->links; my $count = 0; for my $link (@links) { # print "[", $count++, "] ", $link->[1],"\n"; print sprintf "[%s] %s\n", $count++, $self->link_text($link); }; }; =head2 parse Dump the output of HTML::TokeParser of the current content =cut sub run_parse { my ($self) = @_; my $content = $self->agent->content; my $p = HTML::TokeParser->new(\$content); #$p->report_tags(qw(form input textarea select optgroup option)); while (my $token = $p->get_token()) { #while (my $token = $p->get_tag("frame")) { # print "<",$token->[0],":",ref $token->[1] ? $token->[1]->{src} : "",">"; print "<",$token->[0],":",$token->[1],">"; } }; =head2 forms Display all forms on the current page. =cut sub run_forms { my ($self,$number) = @_; my $count = 1; my $agent = $self->agent; my @forms = $agent->forms; if (@forms) { for (@forms) { print "Form [",$count++,"]\n"; $_->dump; }; } else { print "No forms on current page.\n"; }; }; =head2 form Select the form named NAME If NAME matches C</^\d+$/>, it is assumed to be the (1-based) index of the form to select. There is no way of selecting a numerically named form by its name. =cut sub run_form { my ($self,$name) = @_; my $number; unless ($self->agent->current_form) { print "There is no form on this page.\n"; return; }; if ($name) { my ($method,$val); $val = $name; if ($name =~ /^\d+$/) { $method = 'form_number'; } else { $method = 'form_name'; $val = qq{'$name'}; }; eval { $self->agent->$method($name); $self->add_history(sprintf q{$agent->%s(%s);}, $method, $val); $self->status($self->agent->current_form->dump); }; $self->display_user_warning( $@ ) if ($@); } else { my $count = 1; my @forms = $self->agent->forms; if (@forms) { for my $form (@forms) { print sprintf "Form [%s] (%s)\n", $count++, ($form->attr('name') || "<no name>"); $form->dump; }; } else { print "No forms found on the current page.\n"; }; }; }; =head2 dump Dump the values of the current form =cut sub run_dump { my ($self) = @_; my $form = $self->agent->current_form; if ($form) { $form->dump } else { warn "There is no form on the current page\n" if $self->option('warnings'); }; }; =head2 value Set a form value Syntax: value NAME [VALUE] =cut sub run_value { my ($self,$key,@values) = @_; # dwim on @values my $value = join " ", @values; # Look if we are filling a checkbox set: #my $field = $self->agent->current_form->find_input($key); #if ($field and ($field->type eq 'checkbox')) { # # We want to explicitly multiple checkboxes. This means we # # have to clear all checkboxes and then set them explicitly. # # for my $value (@values) { # # Blatantly stolen from WWW::Mechanize::Ticky by # # Mark Fowler E<lt>mark@twoshortplanks.comE<gt> # my $input; # my $index = 0; # INPUT: while($input = $self->agent->current_form->find_input($name,"checkbox",$index)) { # # can't guarentee that the first element will be undef and the second # # element will be the right name # foreach my $val ($input->possible_values()) { # next unless defined $val; # if ($val eq $value) { # $input->value($set ? $value : undef); # last INPUT; # } # } # # # move onto the next input # $index++; # } # }; #}; eval { local $^W; $self->agent->current_form->value($key,$value); # Hmm - neither $key nor $value may contain backslashes nor single quotes ... $self->add_history( sprintf q{{ local $^W; $agent->current_form->value('%s', '%s'); };}, $key, $value); }; warn $@ if $@; }; =head2 tick Set checkbox marks Syntax: tick NAME VALUE(s) If no value is given, all boxes are checked. =cut sub tick { my ($self,$tick,$key,@values) = @_; eval { local $^W; for my $value (@values) { $self->agent->$tick($key,$value); }; # Hmm - neither $key nor $value may contain backslashes nor single quotes ... my $value_str = join ", ", map {qq{'$_'}} @values; $self->add_history( sprintf q{{ local $^W; for (%s) { $agent->%s('%s', $_); };}}, $value_str, $tick, $key); }; warn $@ if $@; }; sub tick_all { my ($self,$tick,$name) = @_; eval { local $^W; my $index = 0; while(my $input = $self->agent->current_form->find_input($name,'checkbox',$index)) { my $value = (grep { defined $_ } ($input->possible_values()))[0]; $self->agent->$tick($name,$value); $index++; }; $self->add_history( sprintf q{ { local $^W; my $index = 0; while(my $input = $agent->current_form->find_input('%s','checkbox',$index)) { my $value = (grep { defined $_ } ($input->possible_values()))[0]; $agent->%s('%s',$value); $index++; }; }}, $name, $tick, $name); }; warn $@ if $@; }; sub run_tick { my ($self,$key,@values) = @_; if (scalar @values) { $self->tick( "tick", $key, @values ) } else { $self->tick_all( "tick", $key ) }; }; =head2 untick Remove checkbox marks Syntax: untick NAME VALUE(s) If no value is given, all marks are removed. =cut sub run_untick { my ($self,$key,@values) = @_; if (scalar @values) { $self->tick( "untick", $key, @values ) } else { $self->tick_all( "untick", $key ) }; }; =head2 submit submits the form without clicking on any button =cut sub run_submit { my ($self) = @_; eval { my $res = $self->agent->submit; $self->status( $res->code."\n" ); $self->add_history('$agent->submit();'); $self->sync_browser if $self->option('autosync'); }; warn $@ if $@; }; =head2 click Clicks on the button named NAME. No regular expression expansion is done on NAME. Syntax: click NAME If you have a button that has no name (displayed as NONAME), use click "" to click on it. =cut sub run_click { my ($self,$button) = @_; $button ||= ""; eval { my $res = $self->agent->click($button); $self->status( "(".$res->code.")\n"); $self->activate_first_form; $self->sync_browser if ($self->option('autosync')); $self->add_history( sprintf qq{\$agent->click('%s');}, $button ); }; warn $@ if $@; }; =head2 open <open> accepts one argument, which can be a regular expression or the number of a link on the page, starting at zero. These numbers are displayed by the C<links> function. It goes directly to the page if a number is used or if the RE has one match. Otherwise, a list of links matching the regular expression is displayed. The regular expression should start and end with "/". Syntax: open [ RE | # ] =cut sub run_open { my ($self,$user_link) = @_; $user_link = $self->re_or_string($user_link); my $link = $user_link; my $user_link_expr = ref $link ? qq{qr($link)} : qq{'$link'}; unless (defined $link) { print "No link given\n"; return }; if ($link =~ /\D/) { # looks like a name/re my $re = $link if ref $link; my $count = -1; my @possible_links = $self->agent->links(); my @links = defined $re ? map { $count++; my $t = $_->text; defined $t && $t =~ /$re/ ? $count : () } @possible_links : map { $count++; my $t = $_->text; defined $t && $t eq $link ? $count : () } @possible_links; if (@links > 1) { $self->print_pairs([ @links ],[ map {$possible_links[$_]->[1]} @links ]); undef $link; } elsif (@links == 0) { print "No match.\n"; undef $link; } else { $self->status( "Found $links[0]\n" ); $link = $links[0]; if ($possible_links[$count]->url =~ /^javascript:(.*)/i) { print "Can't follow javascript link $1\n"; undef $link; }; }; }; if (defined $link) { eval { $self->agent->follow_link('n' => $link +1); my ( $hist_option, $hist_value ) = $user_link =~ /^\d+$/ ? ('n', $user_link + 1 ) : ref $user_link ? ( 'text_regex', $user_link_expr ) : ( 'text' , $user_link_expr ); $self->add_history( sprintf qq{\$agent->follow_link('%s' => %s);}, $hist_option, $hist_value ); $self->activate_first_form; if ($self->option('autosync')) { $self->sync_browser; }; $self->status( "(".$self->agent->res->code.")\n" ); }; warn $@ if $@; }; }; # Complete partially typed links : sub comp_open { my ($self,$word,$line,$start) = @_; my @completions = eval { grep {/^$word/} map { $self->link_text( $_ )} ($self->agent->find_all_links()) }; $self->display_user_warning($@) if $@; return @completions; }; =head2 back Go back one page in the browser page history. =cut sub run_back { my ($self) = @_; eval { $self->agent->back(); $self->add_history('$agent->back();'); $self->sync_browser if ($self->option('autosync')); }; warn $@ if $@; }; =head2 reload Repeat the last request, thus reloading the current page. Note that also POST requests are blindly repeated, as this command is mostly intended to be used when testing server side code. =cut sub run_reload { my ($self) = @_; eval { $self->agent->reload(); $self->add_history('$agent->reload;'); $self->sync_browser if ($self->option('autosync')); }; $self->display_user_warning($@) if $@; }; =head2 browse Open the web browser with the current page Displays the current page in the browser. =cut sub run_browse { my ($self) = @_; $self->sync_browser; }; =head2 set Set a shell option Syntax: set OPTION [value] The command lists all valid options. Here is a short overview over the different options available : autosync - automatically synchronize the browser window autorestart - restart the shell when any required module changes This does not work with C<-e> oneliners. watchfiles - watch all required modules for changes cookiefile - the file where to store all cookies dumprequests - dump all requests to STDOUT dumpresponses - dump the headers of the responses to STDOUT verbose - print commands to STDERR as they are run, when sourcing from a file =cut sub run_set { my ($self,$option,$value) = @_; $option ||= ""; if ($option && exists $self->{options}->{$option}) { if ($option and defined $value) { $self->option($option,$value); } else { $self->print_pairs( [$option], [$self->option($option)] ); }; } else { print "Unknown option '$option'\n" if $option; print "Valid options are :\n"; $self->print_pairs( [keys %{$self->{options}}], [ map {$self->option($_)} (keys %{$self->{options}}) ] ); }; }; =head2 history Display your current session history as the relevant commands. Syntax: history [FILENAME] Commands that have no influence on the browser state are not added to the history. If a parameter is given to the C<history> command, the history is saved to that file instead of displayed onscreen. =cut sub run_history { my ($self,$filename) = @_; $self->display($filename,$self->history); }; =head2 script Display your current session history as a Perl script using WWW::Mechanize. Syntax: script [FILENAME] If a parameter is given to the C<script> command, the script is saved to that file instead of displayed on the console. This command was formerly known as C<history>. =cut sub run_script { my ($self,$filename) = @_; $self->display($filename,$self->script(" ")); }; =head2 comment Adds a comment to the script and the history. The comment is prepended with a \n to increase readability. =cut sub run_comment { my $self = shift; if (@_) { $self->add_history("\n# @_ "); } } =head2 fillout Fill out the current form Interactively asks the values hat have no preset value via the autofill command. =cut sub run_fillout { my ($self) = @_; my @interactive_values; eval { $self->{answers} = []; my $form = $self->agent->current_form; if ($form) { $self->{formfiller}->fill_form($self->agent->current_form); @interactive_values = @{$self->{answers}}; } else { $self->display_user_warning( "No form found on the current page." ) }; }; warn $@ if $@; $self->add_history( join( "\n", map { sprintf( q[$formfiller->add_filler( '%s' => Fixed => '%s' );], @$_ ) } @interactive_values) . '$formfiller->fill_form($agent->current_form);'); }; =head2 auth Set basic authentication credentials. Syntax: auth user password If you know the authority and the realm in advance, you can presupply the credentials, for example at the start of the script : >auth corion secret >get http://www.example.com Retrieving http://www.example.com(200) http://www.example.com> =cut sub run_auth { my ($self) = shift; my ($user, $password); if (scalar @_ == 2) { ($user,$password) = @_; $password = "" if not defined $password; my $code = sub { $self->agent->credentials($user => $password); }; $code->(); my $body = $self->munge_code($code); $self->add_history( sprintf( q{my ($user,$password) = ('%s','%s');}, $user, $password), $body, ); } else { $self->display_user_warning("Authentication only supports the two-argument form"); }; }; =head2 table Display a table described by the columns COLUMNS. Syntax: table COLUMNS Example: table Product Price Description If there is a table on the current page that has in its first row the three columns C<Product>, C<Price> and C<Description> (not necessarily in that order), the script will display these columns of the whole table. The C<HTML::TableExtract> module is needed for this feature. =cut sub run_table { my ($self,@columns) = @_; eval { require HTML::TableExtract; die "I need a HTML::TableExtract version of 2 or greater. I found '$HTML::TableExtract::VERSION'" if $HTML::TableExtract::VERSION < 2; my $code = sub { my $table = HTML::TableExtract->new( headers => [ @columns ] ); (my $content = $self->agent->content) =~ s/\ ?//g; $table->parse($content); my @lines; push @lines, join(", ", @columns),"\n"; for my $ts ($table->table_states) { for my $row ($ts->rows) { push @lines, ">".join(", ", @$row)."<\n"; }; }; $self->print_paged(@lines); }; $code->(); my $body = $self->munge_code($code); $self->add_history( "require HTML::TableExtract;\n", sprintf( 'my @columns = ( %s );'."\n", join( ",", map( { s/(['\\])/\\$1/g; qq('$_') } @columns ))), $body ); }; $self->display_user_warning( "Couldn't load HTML::TableExtract: $@" ) if ($@); }; =head2 tables Display a list of tables. Syntax: tables This command will display the top row for every table on the current page. This is convenient if you want to find out what the exact spellings for each column are. The command does not always work nice, for example if a site uses tables for layout, it will be harder to guess what tables are irrelevant and what tables are relevant. L<HTML::TableExtract> is needed for this feature. =cut sub run_tables { my ($self,@columns) = @_; eval { require HTML::TableExtract; die "I need a HTML::TableExtract version of 2 or greater. I found '$HTML::TableExtract::VERSION'" if $HTML::TableExtract::VERSION < 2; my $table = HTML::TableExtract->new( subtables => 1 ); (my $content = $self->agent->content) =~ s/\ ?//g; $table->parse($content); my @lines; for my $ts ($table->table_states) { my ($row) = $ts->rows; if (grep { /\S/ } (@$row)) { push @lines, join( "", "Table ", join( ",",$ts->coords ), " : ", join(",", @$row),"\n" ); }; }; $self->print_paged(@lines); }; $self->display_user_warning( $@ ) if $@; }; =head2 cookies Set the cookie file name Syntax: cookies FILENAME =cut sub run_cookies { my ($self,$filename) = @_; $self->agent->cookie_jar(HTTP::Cookies->new( file => $filename, autosave => 1, ignore_discard => 1, )); }; sub run_ { # ignore empty lines }; =head2 autofill Define an automatic value Sets a form value to be filled automatically. The NAME parameter is the WWW::Mechanize::FormFiller::Value subclass you want to use. For session fields, C<Keep> is a good candidate, for interactive stuff, C<Ask> is a value implemented by the shell. A field name starting and ending with a slash (C</>) is taken to be a regular expression and will be applied to all fields with their name matching the expression. A field with a matching name still takes precedence over the regular expression. Syntax: autofill NAME [PARAMETERS] Examples: autofill login Fixed corion autofill password Ask autofill selection Random red green orange autofill session Keep autofill "/date$/" Random::Date string "%m/%d/%Y" =cut sub run_autofill { my ($self,$name,$class,@args) = @_; @args = ($self) if ($class eq 'Ask'); if ($class) { my $name_vis; $name = $self->re_or_string($name); if (ref $name) { $name_vis = qq{qr($name)}; #warn "autofill RE detected $name"; } else { $name_vis = qq{"$name"}; }; eval { $self->{formfiller}->add_filler($name,$class,@args); $self->add_history( sprintf qq{\$formfiller->add_filler( %s => "%s" => %s ); }, $name_vis, $class, join( ",", map {qq{'$_'}} @args)); }; warn $@ if $@; } else { warn "No class for the autofiller given\n"; }; }; =head2 eval Evaluate Perl code and print the result Syntax: eval CODE For the generated scripts, anything matching the regular expression C</\$self-E<gt>agent\b/> is automatically replaced by C<$agent> in your eval code, to do the Right Thing. Examples: # Say hello eval "Hello World" # And take a look at the current content type eval $self->agent->ct =cut sub run_eval { my ($self,@rest) = @_; my $code = $self->line; if ($code !~ /^eval\s+(.*)$/sm) { #warn "Don't know what to do with '$code'"; $self->display_user_warning("Don't know what to make of '$code'"); } else { my $str = $1; my $code = qq{ do { $str } }; my @res = eval $code; if (my $err = $@) { #warn "Don't know what to do with '$str' ($err)"; $self->display_user_warning($err); return }; print join "", @res,"\n"; my $script_code = $self->munge_code(qq{print $code, "\\n";}); #warn "Script: $script_code<<"; $self->add_history( $script_code ); }; }; =head2 source Execute a batch of commands from a file Syntax: source FILENAME =cut sub run_source { my ($self,$file) = @_; if ($file) { eval { $self->source_file($file); }; if ($@) { $self->display_user_warning( "Could not source file '$file' : $@" ); }; } else { print "Syntax: source FILENAME\n"; }; }; =head2 versions Print the version numbers of important modules Syntax: versions =cut sub run_versions { my ($self) = @_; no strict 'refs'; my @modules = qw( WWW::Mechanize::Shell WWW::Mechanize::FormFiller WWW::Mechanize Term::Shell HTML::Parser HTML::TableExtract HTML::Parser HTML::Display Pod::Constants File::Modified ); eval "require $_" foreach @modules; $self->print_pairs( [@modules], [map { defined ${"${_}::VERSION"} ? ${"${_}::VERSION"} : "<undef>" } @modules]); }; =head2 timeout Set new timeout value for the agent. Effects all subsequent requests. VALUE is in seconds. Syntax: timeout VALUE =cut sub run_timeout { my ($self, $timeout) = @_; if ($timeout) { eval { $self->agent->timeout($timeout); }; if ($@) { print "Could not set new timeout value : $@"; }; $self->add_history( sprintf q{$agent->timeout(%s);}, $timeout); } else { print "Syntax: timeout VALUE\n"; }; }; =head2 ct prints the content type of the most current response. Syntax: ct =cut sub run_ct { my ($self) = @_; if ($self->agent->content) { eval { print $self->agent->ct, "\n"; }; if ($@) { print "Could not get content-type : $@"; }; $self->add_history('print $agent->ct, "\n";'); } else { print "No content available yet!\n"; } }; =head2 referrer set the value of the Referer: header Syntax: referer URL referrer URL =cut sub run_referrer { my ($self, $referrer) = @_; if (defined $referrer) { eval { $self->agent->add_header(Referer => $referrer); }; if ($@) { print "Could not set referrer : $@"; }; # warn "Added $referrer"; $self->add_history( sprintf q{$agent->add_header('Referer', '%s');}, $referrer); } else { # print "syntax: referer|referrer URL\n"; eval { print "Referer: ", $self->agent->{req}->header('Referer'),"\n"; }; } }; =head2 referer Alias for referrer =cut sub run_referer { goto &WWW::Mechanize::Shell::run_referrer }; # sub alias_referrer { qw(referer) }; =head2 response display the last server response =cut sub run_response { my ($self) = @_; eval { $self->print_paged( $self->agent->res->as_string )}; }; =head2 C<< $shell->munge_code( CODE ) >> Munges a coderef to become code fit for output independent of WWW::Mechanize::Shell. =cut %munge_map = ( '^{' => '', '}$' => '', '\$self->print_paged' => 'print ', '\$self->agent' => '$agent', '\s*package ' . __PACKAGE__ . ';' => '', ); sub munge_code { my ($self, $code) = @_; my $body; if (ref $code) { # Munge code my $d = B::Deparse->new('-sC'); if ($d->can('ambient_pragmas')) { $d->ambient_pragmas(strict => 'all', warnings => 'all'); }; $body = $d->coderef2text($code); } else { $body = $code } while (my ($key,$val) = each %munge_map) { $body =~ s/$key/$val/gs; }; $body }; =head2 C<< shell >> This subroutine is exported by default as a convenience method so that the following oneliner invocation works: perl -MWWW::Mechanize::Shell -eshell You can pass constructor arguments to this routine as well. Any scripts given in C<< @ARGV >> will be run. If C<< @ARGV >> is empty, an interactive loop will be started. =cut sub shell { my @args = ("shell",@_); my $shell = WWW::Mechanize::Shell->new(@args); if (@ARGV) { $shell->source_file( @ARGV ); } else { $shell->cmdloop; }; }; { package WWW::Mechanize::FormFiller::Value::Ask; use WWW::Mechanize::FormFiller; use base 'WWW::Mechanize::FormFiller::Value::Callback'; use vars qw( $VERSION ); $VERSION = '0.21'; sub new { my ($class,$name,$shell) = @_; # Using the name here to allow for late binding and overriding via eval() # from the shell command line #warn __PACKAGE__ . "::ask_value"; my $self = $class->SUPER::new($name, __PACKAGE__ . '::ask_value'); $self->{shell} = $shell; Carp::carp "WWW::Mechanize::FormFiller::Value::Ask->new called without a value for the shell" unless $self->{shell}; $self; }; sub ask_value { my ($self,$input) = @_; my @values; if ($input->possible_values) { @values = $input->possible_values; print join( "|", @values ), "\n"; }; my $value; $value = $input->value; #warn $value if $value; if ($input->type !~ /^(submit|hidden)$/) { $value = $self->{shell}->prompt("(" . $input->type . ")" . $input->name . "> [" . ($input->value || "") . "] ", ($input->value||''), @values ); undef $value if ($value eq "" and $input->type eq "checkbox"); push @{$self->{shell}->{answers}}, [ $input->name, $value ]; }; $value; }; }; __END__ =head1 SAMPLE SESSIONS =head2 Entering values # Search for a term on Google get http://www.google.com value q "Corions Homepage" click btnG script # (yes, this is a bad example of automating, as Google # already has a Perl API. But other sites don't) =head2 Retrieving a table get http://www.perlmonks.org open "/Saints in/" table User Experience Level script # now you have a program that gives you a csv file of # that table. =head2 Uploading a file get http://aliens:xxxxx/ value f path/to/file click "upload" =head2 Batch download # download prerelease versions of my modules get http://www.corion.net/perl-dev save /.tar.gz$/ =head1 REGULAR EXPRESSION SYNTAX Some commands take regular expressions as parameters. A regular expression B<must> be a single parameter matching C<^/.*/([isxm]+)?$>, so you have to use quotes around it if the expression contains spaces : /link_foo/ # will match as (?-xims:link_foo) "/link foo/" # will match as (?-xims:link foo) Slashes do not need to be escaped, as the shell knows that a RE starts and ends with a slash : /link/foo/ # will match as (?-xims:link/foo) "/link/ /foo/" # will match as (?-xims:link/\s/foo) The C</i> modifier works as expected. If you desire more power over the regular expressions, consider dropping to Perl or recommend me a good parser module for regular expressions. =head1 DISPLAYING HTML WWW::Mechanize::Shell now uses the module HTML::Display to display the HTML of the current page in your browser. Have a look at the documentation of HTML::Display how to make it use your browser of choice in the case it does not already guess it correctly. =head1 FILLING FORMS VIA CUSTOM CODE If you want to stay within the confines of the shell, but still want to fill out forms using custom Perl code, here is a recipe how to achieve this : Code passed to the C<eval> command gets evalutated in the WWW::Mechanize::Shell namespace. You can inject new subroutines there and these get picked up by the Callback class of WWW::Mechanize::FormFiller : # Fill in the "date" field with the current date/time as string eval sub &::custom_today { scalar localtime }; autofill date Callback WWW::Mechanize::Shell::custom_today fillout This method can also be used to retrieve data from shell scripts : # Fill in the "date" field with the current date/time as string # works only if there is a program "date" eval sub &::custom_today { chomp `date` }; autofill date Callback WWW::Mechanize::Shell::custom_today fillout As the namespace is different between the shell and the generated script, make sure you always fully qualify your subroutine names, either in your own namespace or in the main namespace. =head1 GENERATED SCRIPTS The C<script> command outputs a skeleton script that reproduces your actions as done in the current session. It pulls in C<WWW::Mechanize::FormFiller>, which is possibly not needed. You should add some error and connection checking afterwards. =head1 ADDING FIELDS TO HTML If you are automating a JavaScript dependent site, you will encounter JavaScript like this : <script> document.write( "<input type=submit name=submit>" ); </script> HTML::Form will not know about this and will not have provided a submit button for you (understandably). If you want to create such a submit button from within your automation script, use the following code : $agent->current_form->push_input( submit => { name => "submit", value =>"submit" } ); This also works for other dynamically generated input fields. To fake an input field from within a shell session, use the C<eval> command : eval $self->agent->current_form->push_input(submit=>{name=>"submit",value=>"submit"}); And yes, the generated script should do the Right Thing for this eval as well. =head1 LOCAL FILES If you want to use the shell on a local file without setting up a C<http> server to serve the file, you can use the C<file:> URI scheme to load it into the "browser": get file:local.html forms =head1 PROXY SUPPORT Currently, the proxy support is realized via a call to the C<env_proxy> method of the WWW::Mechanize object, which loads the proxies from the environment. There is no provision made to prevent using proxies (yet). The generated scripts also load their proxies from the environment. =head1 ONLINE HELP The online help feature is currently a bit broken in C<Term::Shell>, but a fix is in the works. Until then, you can re-enable the dynamic online help by patching C<Term::Shell> : Remove the three lines my $smry = exists $o->{handlers}{$h}{smry} ? $o->summary($h) : "undocumented"; in C<sub run_help> and replace them by my $smry = $o->summary($h); The shell works without this patch and the online help is still available through C<perldoc WWW::Mechanize::Shell> =head1 BUGS Bug reports are very welcome - please use the RT interface at https://rt.cpan.org/NoAuth/Bugs.html?Dist=WWW-Mechanize-Shell or send a descriptive mail to bug-WWW-Mechanize-Shell@rt.cpan.org . Please try to include as much (relevant) information as possible - a test script that replicates the undesired behaviour is welcome every time! =over 4 =item * The two parameter version of the C<auth> command guesses the realm from the last received response. Currently a RE is used to extract the realm, but this fails with some servers resp. in some cases. Use the four parameter version of C<auth>, or if not possible, code the extraction in Perl, either in the final script or through C<eval> commands. =item * The shell currently detects when you want to follow a JavaScript link and tells you that this is not supported. It would be nicer if there was some callback mechanism to (automatically?) extract URLs from JavaScript-infected links. =back =head1 TODO =over 4 =item * Add XPath expressions (by moving C<WWW::Mechanize> from HTML::Parser to XML::XMLlib or maybe easier, by tacking Class::XPath onto an HTML tree) =item * Add C<head> as a command ? =item * Optionally silence the HTML::Parser / HTML::Forms warnings about invalid HTML. =back =head1 EXPORT The routine C<shell> is exported into the importing namespace. This is mainly for convenience so you can use the following commandline invocation of the shell like with CPAN : perl -MWWW::Mechanize::Shell -e"shell" =head1 REPOSITORY The public repository of this module is L<https://github.com/Corion/WWW-Mechanize-Shell>. =head1 SUPPORT The public support forum of this module is L<http://perlmonks.org/>. =head1 COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (C) 2002-2017 Max Maischein =head1 AUTHOR Max Maischein, E<lt>corion@cpan.orgE<gt> Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome ! =head1 SEE ALSO L<WWW::Mechanize>,L<WWW::Mechanize::FormFiller>,L<WWW::Mechanize::Firefox> =cut ���������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/META.json������������������������������������������������������������������0000644�0001750�0001750�00000001544�13077733716�016105� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������{ "abstract" : "An interactive shell for WWW::Mechanize", "author" : [ "Max Maischein <corion@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "WWW-Mechanize-Shell", "no_index" : { "directory" : [ "t", "inc" ] }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/Corion/WWW-Mechanize-Shell.git", "web" : "https://github.com/Corion/WWW-Mechanize-Shell" } }, "version" : "0.56", "x_serialization_backend" : "JSON::PP version 2.27202", "x_static_install" : 1 } ������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/Changes��������������������������������������������������������������������0000644�0001750�0001750�00000040554�13077733715�015762� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Revision history for Perl extension WWW::Mechanize::Shell. Todo: + Think about HTML::FillInForm for displaying changed form values interactively + Check how the new WWW::Mechanize JavaScript handling interacts with the shells own JS blocking (badly, I guess) + Use Scalar::Util::weaken if available + Think how to add other (Xpath) extractions to conveniently display stuff via CSS selectors or XPath selectors. Steal from Web::Scraper. + There is a memory leak between ::FormFiller and ::Shell + Ditch Hook::LexWrap now that LWP::UserAgent has progress callbacks + Add set-cookie and delete-cookie commands + Add (optional) HTTP::Cookies::Find support 0.56 20170425 + Send uncompressed output to the browser (contributed by weltonrodrigo) + Fix some warnings caused by links without a text . Fix test suite due to newer version of Test::Without::Module . Upgrade the test HTTP server to work in absence of CGI.pm 0.55 20150426 . Fix one more test against new sprintf() warnings in 5.21+ 0.54 20150426 . Fix test suite against new sprintf() warnings in 5.21+ . Fix test suite against calling CGI::param in list context Both analyzed and contributed by Slaven Rezic 0.53 20130810 . Add links to repository, contributed by D. Steinbrunner 0.52 20110106 . Fix stupid thinko in test (only affects tests on 5.13+) 0.51 20110105 . Make a test more robust against 5.14 . Streamlined Exporter.pm usage . Rely on parent.pm instead of base.pm . No need to upgrade 0.50 20100821 . Remove test file that was just testing LWP functionality and that failed for some weird setups where nonexistent hosts still result in a successful HTTP request. . Added links to repositories 0.49 20100817 + Apply [rt.cpan.org #59246] , thanks to Ansgar Burchardt This fixes another case where API changes in LWP weren't mirrored by this module. + Fix t/14-command-identity.t to not make an external request anymore Addresses [rt.cpan.org #59883] 0.48 20081109 + More test fixes for incompatibilities between LWP and Mechanize 1.34+ + Removed way to set up authentication for more than one site . WWW::Mechanize monkeypatches LWP::UserAgent and thus you can only ever have one set of user/password in your script. 0.47 20081102 + Fix tests to work with libwww 5.815+ which automatically retries with empty user/password + WWW::Mechanize 1.34+ breaks Basic authentication with LWP 5.815+ so all auth tests are skipped until Andy Lester and Gisle Aas work out who has to fix their stuff. . Hook::LexWrap is subject to bug [perl #46217], this might cause problems if you're running Perl 5.10.0. All tests pass. 0.46 20071003 + Bump version because of borked CPAN upload, retrying * No need to upgrade 0.45 20071003 * No library code changes, no need to upgrade - Removed HTML::Display from the distribution as that now lives its own life on CPAN - Fix failing tests if HTTP_PROXY was set. This fixes Debian bug #444634, http://bugs.debian.org/444634 and CPAN RT #29455, thanks to Niko Tyni 0.44 20070707 + Added C<title> and C<headers> commands that print out the title and headers of the page. Suggested by Ed Halley. + Added and documented arguments to the C<< shell >> subroutine + Quieted up some test warnings + IO::Catch now understands C<printf> + Upgrade to Term::Shell v0.02 which now displays the help summary better. 0.43 20070511 - fix failures on 5.6.2 with a B::Deparse version that doesn't support ->ambient_pragmas() - they get ignored there now. 0.42 200704.. - Test fixes only, no need to upgrade - Patches submitted by MAREKR (RT #26397) and somebody else whose name I cannot find, sorry. - Delete some more proxy settings for the test runs 0.41 20070414 - Codeacrobat release - Restore compatibility with WWW::Mechanize 1.22 Thanks to Jörg Meltzer who sent in the patch 0.40 20070117 - Fixed showstopper bug in prompt method that was hidden by all tests disabling interactive prompts Thanks to all reporters 0.39 - Bumped module version - Fix for RT 22121 - shell does not start 0.38 20061214 - Bumped module version - Added a test for HTML::TableExtract functionality which went untested so far - Fixed HTML::TableExtract functionality This functionality now requires HTML::TableExtract 2.0 or higher, sorry - This release now needs WWW::Mechanize 1.20, for the update_html method which is used in the tests. Sorry. - Reworked code generation and code execution - ! Think about plugins for other extractions: * Template::Extract * XML::XPath extractions - Think about using a different shell framework provider 0.37 - Fixed bug that created invalid code for the C<auth> command 0.36 - Fixed the actual bug too. 0.35 - Fixed documentation in HTML::Display::Debian about C<x-www-browser>. 0.34 - Fixed a bug where C<form 2> resulted in an error. Now selecting a form by number actually works. Thanks for the report via RT. 0.33 - The C<form> command now got a life of its own instead of being a lazy abbreviation of the C<forms> command. It takes a form name or form number. 0.32 - now WWW::Mechanize::Shell directly uses HTML::TokeParser::Simple. Previously, it was only needed for special cases of HTML::Display. - WWW::Mechanize::Shell now strips all "target" attributes from your HTML. 0.31 - test t/13* didn't work when the CPAN build directory contains a space - Added patch by Philippe "BooK" Bruhat to allow downloading big files directly to disk. Changed behaviour: - The referrer header now always points to the original page you save from when using the C<save> command. 0.30 - Now needs the latest? Test::Harness because otherwise some tests failed from time to time for no apparent reason. - using Devel::Cover. Code coverage of WWW/Mechanize/Shell.pm is now at 75.00% through the test suite - Provide better text for all links (for example when the content is an image) - Now moved to use WWW::Mechanize::Link instead of direct array access - This means it requires WWW::Mechanize 0.57 or higher - added "comment" command, which allows to add comments to both, the shell script and the generated script. (Donated by Alexander Goller) - accomodated for most recent version of LWP, which dosen't die on failing host lookups but returns error 500. 0.29 - Fixed bug when autocompletion did crash the shell (S. Rezic) - HTML::Display::Opera does not open a new window anymore (S. Rezic) - Moved private package "Catch" to IO::Catch and made all tests use that package 0.28 - Add $PAGER support for multiline output - "referer" command now prints the old referer if no new value is given - added RT bug email address to documentation 0.27 - now needs WWW::Mechanize 0.47 - added "tick" and "untick" commands (plus tests) - fixed t/14*.t so that now the correct locations are used - removed ::Unwrap class that was not used anywhere - If more than one value is passed to the "value" command, the parameters are concatenated with spaces - added test that all released files are in Unix text format - added "dumpresponses" option - added "verbose" option that prints the commands while sourcing a file (Prakash Kailasa) - "content" now can save the content to a file (Prakash Kailasa) - added "ct" command to print the Context-Type header (Prakash Kailasa) - added "referer" and "referrer" command to change the Referer header (Prakash Kailasa) - added "timeout" command to set the LWP::UserAgent timeout (Prakash Kailasa) - added "response" command to display the complete response (request by Mark Stosberg) - updated tests to accomodate for the new commands 0.26 - added RE support to autofill - fixed broken HTML display as the filename was passed doubled - POD fixes - HTML::Display now checks for @ISA before loading a file - Displaying shared files is now tested against - Updated POD to reflect the new RE parsing 0.25 - The "versions" command also lists HTML::Display now - hunted down and fixed error in skipping too many tests in t/01-Win32-OLE-fallback.t - fixed redefinition warning in t/00-use.t - updated local server tests 0.24 - fixup release for 0.23 - Added $VERSION to all HTML::Display modules - patched handing of BASE tags, so that more cases are caught. This adds HTML::TokeParser::Simple as a prerequisite. Thanks to Mark Stosberg for the initial patch! - fixed loading of classes in HTML::Display. Classes are only required if there is no method "display_html" in that namespace already. - fixed embarassing Linux compatibility bugs - HTML::Display::TempFile now also works under Windows where sharing did not allow another process to read the file while it was being written 0.23 - "submit" didn't reload the browser HTML. Thanks to Slaven Rezic. - t/14* now skips instead of fails tests that can't succeed. - fixed test failing if Term::ReadKey was not available - fixed synopsis code not reading the .mechanizerc - made WWW::Mechanize::Shell use the "reload" method of WWW::Mechanize (after all, I asked for that method ...) - Test for multivalues added, but it's not testing the right stuff yet (see https://rt.cpan.org/Ticket/Display.html?id=2700 ). Not in MANIFEST and/or distribution, but the Changes file is also for me :-) - clarified documentation about "watchfiles" and "autoreload" (thanks to Mark Stosberg) - Documentation fixes for "open" and "links" (also courtesy of Mark Stosberg) - The dumprequests feature needs Hook::LexWrap - it didn't work properly before. The feature is tested in t/14 - "restart" in a -e oneliner dosen't crash the shell (it also dosen't restart though) - factored out the HTML display into a module of its own (HTML::Display), distributed with this. This breaks existing setups, as the "browsercmd" and "useole" option disappeared. You can configure the used browser class by setting the environment variable PERL_HTML_DISPLAY_CLASS or PERL_HTML_DISPLAY_COMMAND, either in your environment or in your mechanizerc. If this feature causes too much grief, I will reimplement the browsercmd stuff again in a later release (but possibly different). Please also tell me whether HTML::Display would be worth a release on its own! 0.22 - The module now requires WWW::Mechanize v0.43, as the internal API of WWW::Mechanize changed. Mixing W::M::S 0.21 or below with W::M v0.43+ will not work as will mixing W::M::S 0.22+ with W::M v0.41- - Added new command "reload", which repeats the last request (intended for testing/modifying server side code) - Altered fillout command - now _all_ fields that aren't predefined via an "autofill" command get asked interactively. Previously fields that already had a value weren't asked. This means that you maybe have to rewrite parts of your scripts if you are using the shell as a testing tool. See t/14* and t/16* for scripts that redefine the interactive asking method to something noninteractive. Field types that do not get asked are : hidden,submit - The "eval" command now takes multiline strings. This is not interesting if you're using the plain shell, as the readline shell dosen't know about about multiline strings, but if you're using the $shell->cmd() feature, it's handy to split your evals over more than one line. 0.21 - Fixed error in one-liner usage - Fixed embarassing errors in 'forms' and 'save' commands - other documentation fixes - The history can now be saved directly to a file - The script can now be saved directly to a file - The generated scripts now have a correct shebang line - Fixed redirect behaviour in generated scripts - Manually filled values (via 'fillout') now get created as 'value' commands 0.20 - made t/00a*.t a TODO test so that CPAN install (silently) works - updated documentation on how to specify custom callbacks from within the shell (having an interpreter with eval rules!) - various documentation fixes - fixed behaviour of "open" with regard to regular expressions - extensive testing of shell behaviour regarding the navigation added - Fixed t/06* when Test::MockObject is not installed 0.19 - Added t/00a*.t to check for a Term::Shell bug to the MANIFEST - renamed the "history" command to "script" - the new "history" command now outputs the "relevant" shell commands - added "versions" command to print out the versions of the installed modules - added "ua" command to easily change the user agent string - added documentation for some more methods - added understanding of "#" as a comment - added a "save" command to save links into files - added "auth" command for basic authentication (suggested by merlyn) - added live test of the auth command against HTTP::Daemon (code provided by merlyn) - added test that 'url' basic authentication also works (http://login:password@example.com) - added convenience "shell" module method : perl -MWWW::Mechanize::Shell -e "shell" - added full end-to-end testing for many commands and their generated scripts - fixed many bugs in the generated scripts - many documentation fixes - Term::ReadLine now gets disabled for the tests - silenced HTML::Form warning for readonly fields 0.18 - No functional changes to v0.17 - Discovered that and documented how file uploads work - Added BUGS section to documentation 0.17 - Fixed a doc bug where "exit" referred to the (nonexistent) "quit" topic (thanks Mark) - Made a test checking the version of Term::Shell and the help summary bug - Fixed t/06*.t - it crashed when Test::MockObject wasn't installed 0.16 20030429 - Changed double quotes around parameters to single quotes to allow for urls like http://mark@foo.com (thanks Mark) - Added tests to check that created scripts at least compile - Made the form fillout more robust by wrapping it in an eval block 0.14 20030414 - Fixed a bad list bug introduced with my unix-browser patch to the options system. Slaven Rezics submitted patch had nothing to do with this, I only grabbed the idea from him but did botch the implementation myself. - Added a test that all options can be set and reset - Reenabled all warnings in the tests - Removed one warning for an unavailable module - Added first part of JavaScript handling : The shell detects when you want to follow a javascript: link, and says that you can't do that. 0.13 20030404 - Slaven Rezic submitted a patch to enable synchronous HTML display under Unix ! Thanks go to Slaven !! All bugs/errors are my fault ! - fixed a crash if the url to the get command was invalid - fixed a crash if a browser was launched without a previous request - added tests for those two crashes - moved example shell from examples/shell.pl to bin/wwwshell.pl 0.12 20030320 - Added a test to check for the behaviour if HTML::TableExtract is not present - silenced warnings in the tests - No changes to the main module except for the version number 0.11 20030318 - Updated the tests so they skip when there is no terminal available (as is the case when the tests are run from cron) - Fixed the inline tests so the synopsis shows again 0.10 20030312 - Added the "table" command to display/dump HTML tables using HTML::TableExtract - Added "table" history - Added tests for history - Brought README file up to date with the suggested support modules - Added example showing off tables - Added proxy support to the shell and the produced scripts - Added documentation on proxy - Added table lister 0.09 20030308 - I should go back and use the web interface. It was made for people like me. 0.08 20030308 - third time's the charm 0.07 20030308 - And again, because I am stupid 0.06 20030308 - bumped version because I uploaded a partial file to CPAN ... 0.05 20030307 - Fixed the dependency on Win32::OLE - the module now handles other environments gracefully - Added some tests for the module fallbacks (these tests need Test::Without::Module) - moved handling over to cvs 0.04 20030301 - reupload as the 0.02 and 0.03 upload was broken 0.02 20030228 - Made the shell much more robust against wrong parameters and internal failures. - Open /foo/ now goes into the Perl code as "follow(/foo/)", as it should be 0.01 Thu Nov 7 23:04:20 2002 - original version; created by h2xs 1.21 with options -X WWW::Mechanize::Shell ����������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/README���������������������������������������������������������������������0000644�0001750�0001750�00000002576�13077733715�015351� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������NAME WWW::Mechanize::Shell - An interactive shell for WWW::Mechanize DESCRIPTION This module implements a www-like shell above WWW::Mechanize and also has the capability to output crude Perl code that recreates the recorded session. Its main use is as an interactive starting point for automating a session through WWW::Mechanize. The cookie support is there, but no cookies are read from your existing browser sessions. See L<HTTP::Cookies> on how to implement reading/writing your current browsers cookies. INSTALLATION This is a Perl module distribution. It should be installed with whichever tool you use to manage your installation of Perl, e.g. any of cpanm . cpan . cpanp -i . Consult http://www.cpan.org/modules/INSTALL.html for further instruction. Should you wish to install this module manually, the procedure is perl Makefile.PL make make test make install REPOSITORY The public repository of this module is L<https://github.com/Corion/WWW-Mechanize-Shell>. SUPPORT The public support forum of this module is L<http://perlmonks.org/>. AUTHOR Max Maischein, E<lt>corion@cpan.orgE<gt> Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome ! COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (C) 2002-2017 Max Maischein ����������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/MANIFEST�������������������������������������������������������������������0000644�0001750�0001750�00000002323�13077733715�015610� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������.gitignore bin/banking.postbank.de.mech bin/hotmail.signup.mech bin/wwwshell.pl Changes inc/IO/Catch.pm inc/Test/HTTP/cookie-server inc/Test/HTTP/LocalServer.pm inc/Test/HTTP/log-server lib/WWW/Mechanize/Shell.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.json META.yml Module meta-data (added by MakeMaker) README README.mkdn t/00-load.t t/00-use.t t/00a-Term-Shell-catch-smry.t t/01-fallback-Win32-OLE.t t/02-fallback-HTML-TableExtract.t t/02-fallback-Pod-Constant.t t/03-documentation.t t/04-history-invariant.t t/05-options.t t/06-valid-output.t t/07-history-items.t t/08-unknown-command.t t/09-invalid-filename.t t/11-browse-without-request.t t/12-comments.t t/13-command-au.t t/14-command-identity.t t/15-history-save.t t/16-form-fillout.t t/17-eval-multiline.t t/18-browser-autosync.t t/19-value-multi.t t/20-restart-without-script.t t/21-autofill-re.t t/22-complete-command.t t/23-check-dumpresponses.t t/24-source-file.t t/25-save-file-nolink.t t/26-form-no-form.t t/27-form_number.t t/27-index.html t/28-cmd-headers.t t/28-cmd-title.t t/28-html-tableextract.t t/29-launch-shell.t t/401-server t/98-bin.t t/99-changes.t t/99-manifest.t t/99-pod.t t/99-todo.t t/99-unix-text.t t/99-versions.t t/source.mech �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/inc/�����������������������������������������������������������������������0000755�0001750�0001750�00000000000�13077733716�015231� 5����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/inc/IO/��������������������������������������������������������������������0000755�0001750�0001750�00000000000�13077733716�015540� 5����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/inc/IO/Catch.pm������������������������������������������������������������0000755�0001750�0001750�00000002416�13077733715�017125� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package IO::Catch; use strict; use Carp qw(croak); =head1 NAME IO::Catch - capture STDOUT and STDERR into global variables =head1 AUTHOR Max Maischein ( corion at cpan.org ) All code ripped from pod2test by M. Schwern =head1 SYNOPSIS # pre-5.8.0's warns aren't caught by a tied STDERR. use vars qw($_STDOUT_, $_STDERR_); tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; tie *STDERR, 'IO::Catch', '_STDERR_' or die $!; # now you can access $main::_STDOUT_ and $_STDERR_ # to see the output. =cut use vars qw($VERSION); $VERSION = '0.02'; sub TIEHANDLE { my($class, $var) = @_; croak "Need a variable name to tie to" unless $var; return bless { var => $var }, $class; } sub PRINT { no strict 'refs'; my($self) = shift; ${'main::'.$self->{var}} = "" unless defined ${'main::'.$self->{var}}; ${'main::'.$self->{var}} .= join '', @_; } sub PRINTF { no strict 'refs'; my($self) = shift; my $tmpl = shift; ${'main::'.$self->{var}} = "" unless defined ${'main::'.$self->{var}}; ${'main::'.$self->{var}} .= sprintf $tmpl, @_; } sub OPEN {} # XXX Hackery in case the user redirects sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want. sub READ {} sub READLINE {} sub GETC {} sub BINMODE {} 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/inc/Test/������������������������������������������������������������������0000755�0001750�0001750�00000000000�13077733716�016150� 5����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/inc/Test/HTTP/�������������������������������������������������������������0000755�0001750�0001750�00000000000�13077733716�016727� 5����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������WWW-Mechanize-Shell-0.56/inc/Test/HTTP/log-server���������������������������������������������������0000644�0001750�0001750�00000024034�13077733715�020741� 0����������������������������������������������������������������������������������������������������ustar �corion��������������������������corion�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Thanks to merlyn for nudging me and giving me this snippet! use strict; use HTTP::Daemon; use CGI; use Getopt::Long; use vars qw($VERSION); $VERSION = '0.55'; $|++; GetOptions( 'e=s' => \my $expression, ); my $host = 'localhost'; my $d = HTTP::Daemon->new( LocalAddr => $host, ) or die; # HTTP::Deamon doesn't return http://localhost:.../ # for LocalAddr => 'localhost'. This causes the # tests to fail of many machines. ( my $url = URI->new($d->url) )->host($host); print "$url\n"; my ($filename,$logfile) = @ARGV[0,1]; if ($filename) { open DATA, "< $filename" or die "Couldn't read page '$filename' : $!\n"; }; #open LOG, ">", $logfile # or die "Couldn't create logfile '$logfile' : $!\n"; my $log; my $body = join "", <DATA>; sub debug($) { my $message = $_[0]; $message =~ s!\n!\n#SERVER:!g; warn "#SERVER: $message" if $ENV{TEST_HTTP_VERBOSE}; }; my $multi_param = $CGI::VERSION >= 4.21 ? 'multi_param' : 'param'; SERVERLOOP: { my $quitserver; while (my $c = $d->accept) { debug "New connection"; while (my $r = $c->get_request) { debug "Request:\n" . $r->as_string; my $location = ($r->uri->path || "/"); my ($link1,$link2) = ('',''); if ($location =~ m!^/link/([^/]+)/(.*)$!) { ($link1,$link2) = ($1,$2); }; my $res; if ($location eq '/get_server_log') { $res = HTTP::Response->new(200, "OK", undef, $log); $log = ''; } elsif ( $location eq '/quit_server') { debug "Quitting"; $res = HTTP::Response->new(200, "OK", [Connection => 'close'], "quit"); $quitserver = 1; } else { eval $expression if $expression; warn "eval: $@" if $@; $log .= "Request:\n" . $r->as_string . "\n"; if ($location =~ m!^/redirect/(.*)$!) { $res = HTTP::Response->new(302); $res->header('location', $url . $1); } elsif ($location =~ m!^/local/(.*)$!) { my $rbody= do { open my $fh, '<', $1; binmode $fh; local $/; <$fh> }; $res = HTTP::Response->new(200, "OK", [ 'Cache-Control' => 'no-cache', 'Pragma' => 'no-cache', 'Max-Age' => 0, 'Connection' => 'close', 'Content-Length' => length($rbody), ], $rbody); } elsif ($location =~ m!^/error/notfound/(.*)$! or $location =~ m!^/favicon.ico!) { $res = HTTP::Response->new(404, "Not found", [Connection => 'close']); } elsif ($location =~ m!^/error/timeout/(\d+)$!) { sleep $1; $res = HTTP::Response->new(599, "Timeout reached", [Connection => 'close']); } elsif ($location =~ m!^/error/close/(\d+)$!) { sleep $1; $res = undef; } elsif ( $location =~ m!^/chunks!) { my $count = 5; $res = HTTP::Response->new(200, "OK", undef, sub { sleep 1; my $buf = 'x' x 16; return $buf if $count-- > 0; return undef; # done }); } elsif ($location =~ m!^/error/after_headers$!) { my $count = 2; $res = HTTP::Response->new(200, "OK", undef, sub { sleep 1; my $buf = 'x' x 16; return $buf if $count-- > 0; die "Planned error after headers"; }); } else { my $q = $r->content ? CGI->new($r->content ) : CGI->new($r->uri->query); # Make sticky form fields my ($query,$botcheck_query,$query2,$session,%cat); $query = defined $q->param('query') ? $q->param('query') : "(empty)"; $botcheck_query = defined $q->param('botcheck_query') ? $q->param('botcheck_query') : "(empty)"; $query2 = defined $q->param('query2') ? $q->param('query2') : "(empty)"; $session = defined $q->param('session') ? $q->param('session') : 1; my @cats = $q->$multi_param('cat'); %cat = map { $_ => 1 } ( @cats ? @cats : qw( cat_foo cat_bar )); my @categories = map { $cat{$_} ? "checked" : "" } qw( cat_foo cat_bar cat_baz ); my $headers = CGI::escapeHTML( $r->headers->as_string ); my $rbody = sprintf $body,$headers, $location,$session,$query,@categories; $res = HTTP::Response->new(200, "OK", [ 'Set-Cookie' => $q->cookie(-name => 'log-server-httponly',-value=>'supersecret', -discard => 1, -httponly=>1), 'Set-Cookie' => $q->cookie(-name => 'log-server',-value=>'shazam2', -discard=>1,), 'Cache-Control' => 'no-cache', 'Pragma' => 'no-cache', 'Max-Age' => 0, 'Connection' => 'close', 'Content-Length' => length($rbody), ], $rbody); $res->content_type('text/html; charset=ISO-8859-1'); debug "Request " . ($r->uri->path || "/"); }; }; debug "Response:\n" . $res->as_string if $res; eval { $c->send_response($res) if $res; }; if (my $err = $@) { debug "Server raised error: $err"; if ($err !~ /^Planned error\b/) { warn $err; }; $c->close; }; if (! $res) { $c->close; }; last if $quitserver; } sleep 1; undef($c); last SERVERLOOP if $quitserver; }; undef $d; }; END { debug "Server stopped" }; # The below <link> tag should stop the browser from requesting a favicon.ico, but we still see it... __DATA__ <html lang="en"> <head> <title>WWW::Mechanize::Firefox test page

Request headers

%s

Location: %s

Link /test Link /foo Link / /Link /Link in slashes/ Link foo1.save_log_server_test.tmp Link foo2.save_log_server_test.tmp Link foo3.save_log_server_test.tmp
Col1Col2Col3
A1A2A3
B1B2B3
C1C2C3

WWW-Mechanize-Shell-0.56/inc/Test/HTTP/LocalServer.pm0000755000175000017500000001652113077733715021515 0ustar corioncorionpackage Test::HTTP::LocalServer; use strict; # this has to happen here because LWP::Simple creates a $ua # on load so any time after this is too late. BEGIN { delete @ENV{qw( HTTP_PROXY http_proxy CGI_HTTP_PROXY HTTPS_PROXY https_proxy HTTP_PROXY_ALL http_proxy_all )}; } use LWP::Simple; use FindBin; use File::Spec; use File::Temp; use URI::URL qw(); use Carp qw(carp croak); use Cwd; use File::Basename; use vars qw($VERSION); $VERSION = '0.57'; =head1 SYNOPSIS use LWP::Simple qw(get); my $server = Test::HTTP::LocalServer->spawn; ok get $server->url, "Retrieve " . $server->url; $server->stop; =head1 METHODS =head2 Cspawn %ARGS> This spawns a new HTTP server. The server will stay running until $server->stop is called. Valid arguments are : =over 4 =item * C<< html => >> scalar containing the page to be served =item * C<< file => >> filename containing the page to be served =item * C<< debug => 1 >> to make the spawned server output debug information =item * C<< eval => >> string that will get evaluated per request in the server Try to avoid characters that are special to the shell, especially quotes. A good idea for a slow server would be eval => sleep+10 =back All served HTML will have the first %s replaced by the current location. The following entries will be removed from C<%ENV>: HTTP_PROXY http_proxy CGI_HTTP_PROXY =cut sub spawn { my ($class,%args) = @_; my $self = { %args }; bless $self,$class; local $ENV{TEST_HTTP_VERBOSE}; $ENV{TEST_HTTP_VERBOSE}= 1 if (delete $args{debug}); $self->{delete} = []; if (my $html = delete $args{html}) { # write the html to a temp file my ($fh,$tempfile) = File::Temp::tempfile(); binmode $fh; print $fh $html or die "Couldn't write tempfile $tempfile : $!"; close $fh; push @{$self->{delete}},$tempfile; $args{file} = $tempfile; }; my ($fh,$logfile) = File::Temp::tempfile(); close $fh; push @{$self->{delete}},$logfile; $self->{logfile} = $logfile; my $web_page = delete $args{file} || ""; my $server_file = File::Spec->catfile( $FindBin::Bin,File::Spec->updir,'inc','Test','HTTP','log-server' ); my @opts; push @opts, "-e" => delete($args{ eval }) if $args{ eval }; my @cmd=( "-|", $^X, $server_file, $web_page, $logfile, @opts ); if( $^O =~ /mswin/i ) { # Windows Perl doesn't support pipe-open with list shift @cmd; # remove pipe-open @cmd= join " ", map {qq{"$_"}} @cmd; }; my ($pid,$server); if( @cmd > 1 ) { # We can do a proper pipe-open my $mode = shift @cmd; $pid = open $server, $mode, @cmd or croak "Couldn't spawn local server $server_file : $!"; } else { # We can't do a proper pipe-open, so do the single-arg open # in the hope that everything has been set up properly $pid = open $server, "$cmd[0] |" or croak "Couldn't spawn local server $server_file : $!"; }; my $url = <$server>; chomp $url; die "Couldn't read back local server url" unless $url; $self->{_fh} = $server; $self->{_pid} = $pid; $self->{_server_url} = URI::URL->new($url); $self; }; =head2 C<< $server->port >> This returns the port of the current server. As new instances will most likely run under a different port, this is convenient if you need to compare results from two runs. =cut sub port { carp __PACKAGE__ . "::port called without a server" unless $_[0]->{_server_url}; $_[0]->{_server_url}->port }; =head2 C<< $server->url >> This returns the url where you can contact the server. This url is valid until the C<$server> goes out of scope or you call $server->stop; =cut sub url { $_[0]->{_server_url}->abs }; =head2 C<< $server->stop >> This stops the server process by requesting a special url. =cut sub stop { get( $_[0]->{_server_url} . "quit_server" ); close $_[0]->{_fh}; undef $_[0]->{_server_url} }; =head2 C<< $server->kill >> This kills the server process via C. The log cannot be retrieved then. =cut sub kill { CORE::kill( 'SIGKILL' => $_[0]->{ _pid } ); #print wait; my $fh = delete $_[0]->{_fh}; close $fh; undef $_[0]->{_server_url}; undef $_[0]->{_pid}; }; =head2 C<< $server->get_log >> This returns the output of the server process. This output will be a list of all requests made to the server concatenated together as a string. =cut sub get_log { my ($self) = @_; return get( $self->{_server_url} . "get_server_log" ); }; sub DESTROY { $_[0]->stop if $_[0]->{_server_url}; for my $file (@{$_[0]->{delete}}) { unlink $file or warn "Couldn't remove tempfile $file : $!\n"; }; if( $_[0]->{_pid } and CORE::kill( 0 => $_[0]->{_pid })) { $_[0]->kill; # boom }; }; =head2 C<< $server->local >> my $url = $server->local('foo.html'); # file:///.../foo.html Returns an URL for a local file which will be read and served by the webserver. The filename must be a relative filename relative to the location of the current program. =cut sub local { my ($self, $htmlfile) = @_; require Cwd; require File::Spec; my $fn= File::Spec->file_name_is_absolute( $htmlfile ) ? $htmlfile : File::Spec->rel2abs( File::Spec->catfile(dirname($0),$htmlfile), Cwd::getcwd(), ); $fn =~ s!\\!/!g; # fakey "make file:// URL" $self->local_abs($fn) } =head1 URLs implemented by the server =head2 302 redirect C<< $server->redirect($target) >> This URL will issue a redirect to C<$target>. No special care is taken towards URL-decoding C<$target> as not to complicate the server code. You need to be wary about issuing requests with escaped URL parameters. =head2 404 error C<< $server->error_notfound($target) >> This URL will response with status code 404. =head2 Timeout C<< $server->error_timeout($seconds) >> This URL will send a 599 error after C<$seconds> seconds. =head2 Timeout+close C<< $server->error_close($seconds) >> This URL will send nothing and close the connection after C<$seconds> seconds. =head2 Error in response content C<< $server->error_after_headers >> This URL will send headers for a successfull response but will close the socket with an error after 2 blocks of 16 spaces have been sent. =head2 Chunked response C<< $server->chunked >> This URL will return 5 blocks of 16 spaces at a rate of one block per second in a chunked response. =head2 Other URLs All other URLs will echo back the cookies and query parameters. =cut use vars qw(%urls); %urls = ( 'local_abs' => 'local/%s', 'redirect' => 'redirect/%s', 'error_notfound' => 'error/notfound/%s', 'error_timeout' => 'error/timeout/%s', 'error_close' => 'error/close/%s', 'error_after_headers' => 'error/after_headers', 'chunked' => 'chunks', ); for (keys %urls) { no strict 'refs'; my $name = $_; *{ $name } = sub { my $self = shift; $self->url . sprintf $urls{ $name }, @_; }; }; =head1 EXPORT None by default. =head1 COPYRIGHT AND LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright (C) 2003-2011 Max Maischein =head1 AUTHOR Max Maischein, Ecorion@cpan.orgE Please contact me if you find bugs or otherwise improve the module. More tests are also very welcome ! =head1 SEE ALSO L,L,L =cut 1; WWW-Mechanize-Shell-0.56/inc/Test/HTTP/cookie-server0000644000175000017500000000165513077733715021435 0ustar corioncorion#!perl -w # Thanks to merlyn for nudging me and giving me this snippet! use strict; require HTTP::Daemon; require LWP::UserAgent; $|++; my $d = HTTP::Daemon->new or die; print $d->url, "\n"; # How many requests do we expect? my ($ex_user,$ex_pass) = @ARGV; my $verbose = $ENV{TEST_HTTP_VERBOSE}; my $done = 0; while (! $done and my $c = $d->accept) { while (my $req = $c->get_request) { if ($verbose) { warn "# Request URI: " . $req->url->path; my @lines = split "\n",$req->as_string; warn "# $_\n" for @lines; }; my $res; my ($user,$pass); if ($req->url->path eq '/exit') { $done = 1; $res = HTTP::Response->new(200, "OK", undef, "done"); }; if ($verbose) { warn "---\n"; my @lines = split "\n",$res->as_string; warn "# $_\n" for @lines; }; $c->send_response($res); } $c->close; undef($c); }; WWW-Mechanize-Shell-0.56/bin/0000755000175000017500000000000013077733716015230 5ustar corioncorionWWW-Mechanize-Shell-0.56/bin/wwwshell.pl0000644000175000017500000000027113077733715017440 0ustar corioncorion#!/usr/bin/perl -w use strict; use WWW::Mechanize::Shell; my $shell = WWW::Mechanize::Shell->new("shell"); if (@ARGV) { $shell->source_file( @ARGV ); } else { $shell->cmdloop; }; WWW-Mechanize-Shell-0.56/bin/banking.postbank.de.mech0000644000175000017500000000044313077733715021706 0ustar corioncorionautofill TAN Keep autofill SUBMITPATTERN Keep get "https://banking.postbank.de/anfang.jsp" value Kontonummer 9999999999 value PIN 11111 value FUNCTION ACCOUNTSTATEMENT value TAN "" value SUBMITPATTERN "" fill click LOGIN value CHOICE COMPLETE click SUBMIT forms form 3 click DOWNLOAD historyWWW-Mechanize-Shell-0.56/bin/hotmail.signup.mech0000644000175000017500000000077213077733715021034 0ustar corioncorionauto Dirty Fixed "" auto FirstName Fixed Cor auto LastName Fixed Blimey auto Gender Fixed m auto PostalCode Fixed 666 auto TimeZone Fixed 1096 auto Month Fixed 2 auto Day Fixed 18 auto Year Fixed 1980 auto SignInName Fixed CorBlimey666 auto Password Fixed BlimeyCor999 auto ConfirmedPassword Fixed BlimeyCor999 auto SecretAnswer Fixed BlimeyCor969 auto ConsentEmail Fixed "" auto ConsentName Fixed "" auto ConsentDemographic Fixed "" get http://www.hotmail.com/ o "/^Sign Up/" form 2 click form 1 bro fill