view release on metacpan or  search on metacpan

t/local/http.t  view on Meta::CPAN

sub httpd_get_redirect
{
   my($c) = @_;
   $c->send_redirect("/echo/redirect");
}

$req = new HTTP::Request GET => url("/redirect/foo", $base);
$res = $ua->request($req);
#print $res->as_string;

print "not " unless $res->is_success
                and $res->content =~ m|/echo/redirect|;
print "ok 8\n";
print "not " unless $res->previous->is_redirect
                and $res->previous->code == 301;
print "ok 9\n";

# Let's test a redirect loop too
sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") }
sub httpd_get_redirect3 { shift->send_redirect("/redirect2/") }

$req->url(url("/redirect2", $base));
$ua->max_redirect(5);
$res = $ua->request($req);
#print $res->as_string;
print "not " unless $res->is_redirect
                and $res->header("Client-Warning") =~ /loop detected/i;
print "ok 10\n";
$i = 0;
while ($res->previous) {
   $i++;
   $res = $res->previous;
}

print "not " unless $i == 5;
print "ok 11\n";

#----------------------------------------------------------------
print "Check basic authorization...\n";
sub httpd_get_basic
{
    my($c, $r) = @_;
    #print STDERR $r->as_string;
    my($u,$p) = $r->authorization_basic;
    if (defined($u) && $u eq 'ok 12' && $p eq 'xyzzy') {
        $c->send_basic_header(200);
	print $c "Content-Type: text/plain";
	$c->send_crlf;
	$c->send_crlf;
	$c->print("$u\n");
    }
    else {
        $c->send_basic_header(401);
	$c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012");
	$c->send_crlf;
    }
}

{
   package MyUA; @ISA=qw(LWP::UserAgent);
   sub get_basic_credentials {
      my($self, $realm, $uri, $proxy) = @_;
      if ($realm eq "libwww-perl" && $uri->rel($base) eq "basic") {
	  return ("ok 12", "xyzzy");
      }
      else {
          return undef;
      }
   }
}
$req = new HTTP::Request GET => url("/basic", $base);
$res = MyUA->new->request($req);
#print $res->as_string;

print "not " unless $res->is_success;
print $res->content;

# Let's try with a $ua that does not pass out credentials
$res = $ua->request($req);
print "not " unless $res->code == 401;
print "ok 13\n";

# Let's try to set credentials for this realm
$ua->credentials($req->url->host_port, "libwww-perl", "ok 12", "xyzzy");
$res = $ua->request($req);
print "not " unless $res->is_success;
print "ok 14\n";

# Then illegal credentials
$ua->credentials($req->url->host_port, "libwww-perl", "user", "passwd");
$res = $ua->request($req);
print "not " unless $res->code == 401;
print "ok 15\n";


#----------------------------------------------------------------
print "Check proxy...\n";
sub httpd_get_proxy
{
   my($c,$r) = @_;
   if ($r->method eq "GET" and
       $r->url->scheme eq "ftp") {
       $c->send_basic_header(200);
       $c->send_crlf;
   }
   else {
       $c->send_error;
   }
}

$ua->proxy(ftp => $base);
$req = new HTTP::Request GET => "ftp://ftp.perl.com/proxy";
$res = $ua->request($req);
#print $res->as_string;
print "not " unless $res->is_success;
print "ok 16\n";

#----------------------------------------------------------------
print "Check POSTing...\n";
sub httpd_post_echo
{
   my($c,$r) = @_;
   $c->send_basic_header;
   $c->print("Content-Type: text/plain");
   $c->send_crlf;
   $c->send_crlf;

   # Do it the hard way to test the send_file
   open(TMP, ">tmp$$") || die;
   binmode(TMP);
   print TMP $r->as_string;
   close(TMP) || die;

   $c->send_file("tmp$$");

   unlink("tmp$$");
}

$req = new HTTP::Request POST => url("/echo/foo", $base);
$req->content_type("application/x-www-form-urlencoded");
$req->content("foo=bar&bar=test");
$res = $ua->request($req);
#print $res->as_string;

$_ = $res->content;
print "not " unless $res->is_success
                and /^Content-Length:\s*16$/mi
		and /^Content-Type:\s*application\/x-www-form-urlencoded$/mi
		and /^foo=bar&bar=test$/m;
print "ok 17\n";