--- /dev/null
+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:", $d->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 = <DAEMON>;
+$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 <<EOT;
+<html><title>En prøve</title>
+<h1>Dette er en testfil</h1>
+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";
+
projects / dh-make-perl / blobdiff