view release on metacpan or  search on metacpan

t/14-command-identity.t  view on Meta::CPAN

                                                             'submit',
                                                             'content' ],
                                        location => qr'^%s/formsubmit$' },
    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$' },
    tick_all => { requests => 2,
              lines => [ 'get %s','tick cat','submit','content' ],
              location => qr'^%s/formsubmit$' },
    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$' },
    untick_all => { requests => 2,
              lines => [ 'get %s','untick cat','submit','content' ],
              location => qr'^%s/formsubmit$' },
  );

BEGIN {
  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;
        };
    };
};

plan tests => (scalar keys %tests)*10;
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 WWW::Mechanize::Shell;

SKIP: {

# We want to be safe from non-resolving local host names
delete @ENV{qw(HTTP_PROXY http_proxy CGI_HTTP_PROXY)};

our ($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]->();
  #};
};

my $server = Test::HTTP::LocalServer->spawn();
diag "Spawned local test server at " . $server->url;

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}, quotemeta $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");

  my $parameters_ok = 1;
  my $expected_values = $tests{$name}->{values};
  for my $valname (sort keys %$expected_values) {
      if( $s->agent->value( $valname ) !~ /^$expected_values->{ $valname }$/) {
          $parameters_ok = 0;
          diag sprintf "Expected '%s', got '%s'",