X-Git-Url: http://git.maemo.org/git/?p=dh-make-perl;a=blobdiff_plain;f=dev%2Fi386%2Flibwww-perl%2Flibwww-perl-5.813%2Ft%2Flocal%2Fhttp-get.t;fp=dev%2Fi386%2Flibwww-perl%2Flibwww-perl-5.813%2Ft%2Flocal%2Fhttp-get.t;h=368fa42efc0f76c41cc96135f582d230c23b17db;hp=0000000000000000000000000000000000000000;hb=8977e561d8a9eae6959218b0306c9df2056a38a9;hpb=df794b845212301ea0d267c919232538bfef356a diff --git a/dev/i386/libwww-perl/libwww-perl-5.813/t/local/http-get.t b/dev/i386/libwww-perl/libwww-perl-5.813/t/local/http-get.t new file mode 100644 index 0000000..368fa42 --- /dev/null +++ b/dev/i386/libwww-perl/libwww-perl-5.813/t/local/http-get.t @@ -0,0 +1,422 @@ +if ($^O eq "MacOS") { + print "1..0\n"; + exit(0); +} + +unless (-f "CAN_TALK_TO_OURSELF") { + print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n"; + exit; +} + +# Hm, this should really use Test.pm, but not worth changing over, really. + + +$| = 1; # autoflush + +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); + + print "Please to meet you at: url, ">\n"; + open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/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); + } + } + $c = undef; # close connection + } + print STDERR "HTTP Server terminated\n"; + exit; +} +else { + use Config; + my $perl = $Config{'perlpath'}; + $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i; + open(DAEMON, "$perl local/http-get.t daemon |") or die "Can't exec daemon: $!"; +} + +print "1..21\n"; + + +my $greeting = ; +$greeting =~ /(<[^>]+>)/; + +require URI; +my $base = URI->new($1); +sub url { + my $u = URI->new(@_); + $u = $u->abs($_[1]) if @_ > 1; + $u->as_string; +} + +print "# Will access HTTP server at $base\n"; + +require LWP::UserAgent; +require HTTP::Request; +$ua = new LWP::UserAgent; +$ua->agent("Mozilla/0.01 " . $ua->agent); +$ua->from('gisle@aas.no'); +$ua->cookie_jar({}); + +#---------------------------------------------------------------- +print "#------------Testing: Bad request...\n"; +$res = $ua->get( + url("/not_found", $base), + 'X-Foo' => "Bar", +); + +print "not " unless $res->is_error + and $res->code == 404 + and $res->message =~ /not\s+found/i; +print "ok 1\n"; +# we also expect a few headers +print "not " if !$res->server and !$res->date; +print "ok 2\n"; + +#---------------------------------------------------------------- +print "#------------Testing: 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; +} + +$res = $ua->get( + url("/echo/path_info?query", $base), + Accept => 'text/html', + Accept => 'text/plain; q=0.9', + Accept => 'image/*', + Long_text => 'This is a very long header line +which is broken between +more than one line.', + X_Foo => "Bar", + +); +#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 "$_\n"; + +print "not " unless /^From:\s*gisle\@aas\.no$/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 /^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 "#------------Testing: Send file...\n"; + +my $file = "test-$$.html"; +sub _write_file { + open(FILE, ">$file") or die "Can't create $file: $!"; + binmode FILE or die "Can't binmode $file: $!"; + print FILE <En prøve +

Dette er en testfil

+Jeg vet ikke hvor stor fila behøver å være heller, men dette +er sikkert nok i massevis. +EOT + close(FILE); + print "# ", -s $file, " bytes written to $file\n"; + return; +} + +sub httpd_get_file +{ + my($c, $r) = @_; + my %form = $r->url->query_form; + my $file = $form{'name'}; + $c->send_file_response($file); +} + +_write_file(); + +$res = $ua->get( url("/file?name=$file", $base) ); + +#print $res->as_string; + +print "not " unless $res->is_success + and $res->content_type eq 'text/html' + and $res->content_length == 147 + and $res->title eq 'En prøve' + and $res->content =~ /å være/; +print "ok 5\n"; + + + +{ + +my $content; + +$res = $ua->get( url("/file?name=$file", $base), + ':content_cb' => sub { $content .= $_[0]; return; }, +); +#print $res->as_string; + +print "not " unless $res->is_success + and $res->content_type eq 'text/html' + and $res->content_length == 147 + and defined $content + and $res->title eq 'En prøve' + and ! $res->content # No content, because callback + and $content =~ /å være/; +print "ok 6\n"; + +} + +unlink($file); + + + +# Then try to list current directory +$res = $ua->get( url("/file?name=.", $base) ); +#print $res->as_string; +print "not " unless $res->code == 501; # NYI +print "ok 7\n"; + + +#---------------------------------------------------------------- +print "#------------Testing: Check redirect...\n"; +sub httpd_get_redirect +{ + my($c) = @_; + $c->send_redirect("/echo/redirect"); +} + +$res = $ua->get( url("/redirect/foo", $base) ); +#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/") } + +$res = $ua->get(url("/redirect2", $base)); +#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 == 7; +print "ok 11\n"; + +sub httpd_get_redirect_file { shift->send_redirect("file:/etc/passwd") } +$res = $ua->get(url("/redirect_file/", $base)); +#print $res->as_string; +print "not " unless $res->is_redirect + and $res->header("Client-Warning") =~ /can't redirect to a file:/i; +print "ok 12\n"; + + +#---------------------------------------------------------------- +print "#------------Testing: 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 13' && $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 13", "xyzzy"); + } + else { + return undef; + } + } +} + +{ +my $that_url = url("/basic", $base); + +$res = MyUA->new->get( $that_url ); +#print $res->as_string; + +my $host_port = $res->request->uri->host_port; + +print "not " unless $res->is_success; +print $res->content; + +# Let's try with a $ua that does not pass out credentials +$res = $ua->get( $that_url ); +print "not " unless $res->code == 401; +print "ok 14\n"; + + +print "# Host port: $host_port\n"; + +# Let's try to set credentials for this realm +$ua->credentials($host_port, "libwww-perl", "ok 13", "xyzzy"); + +$res = $ua->get( $that_url ); + +print "not " unless $res->is_success; +print "ok 15\n"; + +# Then illegal credentials +$ua->credentials($host_port, "libwww-perl", "user", "passwd"); +$res = $ua->get( $that_url ); +print "not " unless $res->code == 401; +print "ok 16\n"; +} + +#---------------------------------------------------------------- +print "#------------Testing: 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); + +$res = $ua->get( "ftp://ftp.perl.com/proxy" ); +#print $res->as_string; +print "not " unless $res->is_success; +print "ok 17\n"; + +#---------------------------------------------------------------- +print "#------------Testing: 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); +} + +$res = $ua->post( + url("/echo/foo", $base), + ['foo' => 'bar', 'bar' => 'test'], +); +#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"; + + +{ + +my $content; + +$res = $ua->post( + url("/echo/foo", $base), + ['foo' => 'bar', 'bar' => 'test'], + ':content_cb' => sub { $content .= $_[0]; return; }, +); + +$_ = $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 + and ! $res->content +; +print "ok 19\n"; + +} + +{ + +my $content; + +$res = $ua->post( + url("/echo/foo", $base), + Content_Type => 'text/plain', + Content => "Plain Text", + ':content_cb' => sub { $content .= $_[0]; return; }, +); + +$_ = $content; +print "not " unless $res->is_success + and /^Content-Length:\s*10$/mi + and /^Content-Type:\s*text\/plain$/mi + and /^Plain Text$/m + and ! $res->content +; +print "ok 20\n"; + +} + +#---------------------------------------------------------------- +print "#------------Testing: Terminating server...\n"; +sub httpd_get_quit +{ + my($c) = @_; + $c->send_error(503, "Bye, bye"); + exit; # terminate HTTP server +} + +$res = $ua->get( url("/quit", $base) ); + +print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/; +print "ok 21\n"; +