view release on metacpan or  search on metacpan

t/16-form-fillout.t  view on Meta::CPAN

#!/usr/bin/perl -w
use strict;
use FindBin;
use Test::More;

use File::Temp qw( tempfile );
our ($_STDOUT_, $_STDERR_ );
use URI::URL;
use Test::HTTP::LocalServer;
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 *STDOUT, 'IO::Catch', '_STDOUT_' or die $!;
tie *STDERR, 'IO::Catch', '_STDERR_' or die $!;

our %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' },
  );

plan tests => (scalar keys %tests)*6;
BEGIN {
  delete $ENV{PAGER};
  $ENV{PERL_RL} = 0;
};
use WWW::Mechanize::Shell;
SKIP: {

# Disable all ReadLine functionality
my $HTML = do { local $/; <DATA> };

# 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);