# vim: set ft=perl : $| = 1; # autoflush my $DEBUG = 0; my $CRLF = "\015\012"; #use Data::Dump (); #use LWP::Debug qw(+debug +trace +conns); #use LWP::Debug qw(+debug); # First we create HTTP server for testing our http protocol # (this is stolen from the libwww t/local/http.t file) require IO::Socket; # make sure this work before we try to make a HTTP::Daemon # First we make ourself a daemon in another process my $D = shift || ''; if ($D eq 'daemon') { require HTTP::Daemon; my $d = HTTP::Daemon->new(Timeout => 10, LocalAddr=>'localhost'); print "[$$] Pleased to meet you at: url, ">\n"; open(STDOUT, ">/dev/null"); while ($c = $d->accept) { $r = $c->get_request; if ($r) { my $p = ($r->url->path_segments)[1]; my $func = lc("httpd_" . $r->method . "_$p"); if (defined &$func) { &$func($c, $r); } else { $c->send_error(404); } } else { print STDERR "Failed: Reason was '". $c->reason ."'\n"; } $c = undef; # close connection } print STDERR "HTTP Server terminated\n" if $DEBUG; exit 0; } else { use Config; print STDERR "[$$] i'm starting the daemon now!\n" if $DEBUG; open(DAEMON, "$Config{'perlpath'} local/compatibility.t daemon |") or die "Can't exec daemon: $!"; } print "1..20\n"; my $greeting = ; $greeting =~ /(<[^>]+>)/; print STDERR "I am [$$], greeting is [$greeting] and right now dollar 1 is [$1]\n" if $DEBUG; my $url_from_daemon = $1; require URI; my $base = URI->new($url_from_daemon); sub url { my $u = URI->new(@_); $u = $u->abs($_[1]) if @_ > 1; $u->as_string; } print "Will access HTTP server at $base\n"; # do tests from here on #use LWP::Debug qw(+); require LWP::Parallel::UserAgent; require HTTP::Request; my $ua = new LWP::Parallel::UserAgent; $ua->agent("Mozilla/0.01 " . $ua->agent); $ua->from('marclang@cpan.org'); #---------------------------------------------------------------- print "\nLWP::UserAgent compatibility...\n"; # ============ print " - Bad request...\n"; $req = new HTTP::Request GET => url("/not_found", $base); print STDERR "\tRegistering '".$req->url."'\n" if $DEBUG; $req->header(X_Foo => "Bar"); $res = $ua->request($req); print "not " unless $res->is_error and $res->code == 404 and $res->message =~ /not\s+found/i; print "ok 1\n"; print STDERR "\tResponse was '".$res->code. " ". $res->message."'\n" if $DEBUG; # we also expect a few headers print "not " if !$res->server and !$res->date; print "ok 2\n"; # ============= print " - Simple echo...\n"; sub httpd_get_echo { my($c, $req) = @_; $c->send_basic_header(200); print $c "Content-Type: text/plain\015\012"; $c->send_crlf; print $c $req->as_string; } $req = new HTTP::Request GET => url("/echo/path_info?query", $base); $req->push_header(Accept => 'text/html'); $req->push_header(Accept => 'text/plain; q=0.9'); $req->push_header(Accept => 'image/*'); $req->if_modified_since(time - 300); $req->header(Long_text => 'This is a very long header line which is broken between more than one line.'); $req->header(X_Foo => "Bar"); $res = $ua->request($req); #print $res->as_string; print "not " unless $res->is_success and $res->code == 200 && $res->message eq "OK"; print "ok 3\n"; $_ = $res->content; @accept = /^Accept:\s*(.*)/mg; print "not " unless /^From:\s*marclang\@cpan\.org$/m and /^Host:/m and @accept == 3 and /^Accept:\s*text\/html/m and /^Accept:\s*text\/plain/m and /^Accept:\s*image\/\*/m and /^If-Modified-Since:\s*\w{3},\s+\d+/m and /^Long-Text:\s*This.*broken between/m and /^X-Foo:\s*Bar$/m and /^User-Agent:\s*Mozilla\/0.01/m; print "ok 4\n"; # =========== print " - Send file...\n"; my $file = "test-$$.html"; open(FILE, ">$file") or die "Can't create $file: $!"; binmode FILE or die "Can't binmode $file: $!"; print FILE <Test

This should work

Now for something completely different, since it seems that the file transfer does work ok, right? EOT close(FILE); sub httpd_get_file { my($c, $r) = @_; my %form = $r->url->query_form; my $file = $form{'name'}; $c->send_file_response($file); unlink($file) if $file =~ /^test-/; } $req = new HTTP::Request GET => url("/file?name=$file", $base); $res = $ua->request($req); # under previous versions of the library a $res->title was # returned--that part of this test has been removed for # compatibility with the new library print "not " unless $res->is_success and $res->content_type eq 'text/html' and $res->content_length == 151 and $res->content =~ /different, since/; print "ok 5\n"; # A second try on the same file, should fail because we unlink it $res = $ua->request($req); #print $res->as_string; print "not " unless $res->is_error and $res->code == 404; # not found print "ok 6\n"; # Then try to list current directory $req = new HTTP::Request GET => url("/file?name=.", $base); $res = $ua->request($req); #print $res->as_string; use Data::Dumper; print Dumper($res). "\nnot " unless $res->code == 501; # NYI print "ok 7\n"; # ============= print " - Check redirect...\n"; 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 and $res->previous->is_redirect and $res->previous->code == 301; print "ok 9\n"; # Lets test a redirect loop too sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") } sub httpd_get_redirect3 { shift->send_redirect("/redirect4/") } sub httpd_get_redirect4 { shift->send_redirect("/redirect5/") } sub httpd_get_redirect5 { shift->send_redirect("/redirect6/") } sub httpd_get_redirect6 { shift->send_redirect("/redirect2/") } $req->url(url("/redirect2", $base)); $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 = 1; while ($res->previous) { $i++; $res = $res->previous; } # under the old library with the old "duplicated" methods (which are now # named with their old names preceded by "deprecated_") this chained # to a depth of 6. With the new library, and those methods # deprecated (search for 'sub deprecated_' in /LWP/Parallel/UserAgent.pm ), # it gives 8. print "not " unless ($i == 6 or $i == 8); 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::Parallel::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; # Lets try with a $ua that does not pass out credentials $res = $ua->request($req); print "not " unless $res->code == 401; print "ok 13\n"; # Lets 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_http { my($c,$r) = @_; if ($r->method eq "GET" and $r->url->scheme eq "http") { $c->send_basic_header(200); $c->send_crlf; } else { $c->send_error; } } sub httpd_get_proxy_ftp { 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; } } #use LWP::Debug qw(+debug +trace +conns); $ua->proxy(ftp => $base); $req = new HTTP::Request GET => "ftp://ftp.perl.com/proxy_ftp"; $res = $ua->request($req); #print $res->as_string; print "not " unless $res->is_success; print "ok 16\n"; $ua->proxy(http => $base); $req = new HTTP::Request GET => "http://www.perl.com/proxy_http"; $res = $ua->request($req); #print $res->as_string; print "not " unless $res->is_success; print "ok 17\n"; $ua->proxy(http => '', ftp => ''); #---------------------------------------------------------------- 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; $c->print($r->as_string); } $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 18\n"; #---------------------------------------------------------------- print "\nTerminating server...\n"; sub httpd_get_quit { my($c) = @_; $c->send_error(503, "Bye, bye"); exit; # terminate HTTP server } $ua->initialize; $req = new HTTP::Request GET => url("/quit", $base); print STDERR "\tRegistering '".$req->url."'\n" if $DEBUG; if ( $res = $ua->register ($req) ) { print STDERR $res->error_as_HTML; print "not"; } print "ok 19\n"; $entries = $ua->wait(5); foreach (keys %$entries) { # each entry available under the url-string of their request contains # a number of fields. The most important are $entry->request and # $entry->response. $res = $entries->{$_}->response; print STDERR "Answer for '",$res->request->url, "' was \t", $res->code,": ", $res->message,"\n" if $DEBUG; print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/; print "ok 20\n"; }