1#!/usr/bin/perl -w 2use strict; 3use FindBin; 4 5use lib './inc'; 6use IO::Catch; 7our ( $_STDOUT_, $_STDERR_ ); 8use URI; 9use Test::HTTP::LocalServer; 10 11# pre-5.8.0's warns aren't caught by a tied STDERR. 12tie *STDOUT, 'IO::Catch', '_STDOUT_' or die $!; 13 14# Disable all ReadLine functionality 15$ENV{PERL_RL} = 0; 16 17use Test::More tests => 4; 18 19use WWW::Mechanize::Shell; 20 21my $server = Test::HTTP::LocalServer->spawn(); 22 23my $user = 'foo'; 24my $pass = 'bar'; 25 26my $url = URI->new( $server->basic_auth($user => $pass)); 27my $host = $url->host; 28 29my $s = WWW::Mechanize::Shell->new( 'test', rcfile => undef, warnings => undef ); 30 31# Try without credentials: 32my $bare_url = $url; 33diag "get $bare_url"; 34$s->cmd( "get $bare_url" ); 35 36my $code = $s->agent->response->code; 37my $got_url = $s->agent->uri; 38 39if (! is $code, 401, "Request without credentials gives 401") { 40 diag "Page location : " . $s->agent->uri; 41}; 42 43# Now try the shell command for authentication with bad credentials 44$s->cmd( "auth x$user x$pass" ); 45$bare_url = $url; 46diag "get $bare_url"; 47eval { 48 $s->cmd( "get $bare_url" ); 49}; 50is $s->agent->res->code, 401, "Wrong password still results in a 401"; 51like $@, qr/Auth Required/, "We die because of that"; 52 53# Now try the shell command for authentication with correct credentials 54$s->cmd( "auth $user $pass" ); 55$s->cmd( "get $bare_url" ); 56is $s->agent->res->code, 200, "Right password results in 200"; 57 58#diag "Shutting down test server at $url"; 59$server->stop; 60 61