# Thanks to merlyn for nudging me and giving me this snippet!
use strict;
use HTTP::Daemon;
use CGI 4.08;
use Getopt::Long;
$|++;
GetOptions(
'e=s' => \my $expression,
);
my $host = 'localhost';
my $d = HTTP::Daemon->new(
LocalAddr => $host,
) or die;
# HTTP::Deamon doesn't return http://localhost:.../
# for LocalAddr => 'localhost'. This causes the
# tests to fail of many machines.
( my $url = URI->new($d->url) )->host($host);
print "$url\n";
my ($filename,$logfile) = @ARGV[0,1];
if ($filename) {
open DATA, "< $filename"
or die "Couldn't read page '$filename' : $!\n";
};
#open LOG, ">", $logfile
# or die "Couldn't create logfile '$logfile' : $!\n";
my $log;
my $body = join "", <DATA>;
$body =~ s/<!x([0-9a-fA-F]+)>/chr(hex($1))/eg;
utf8::encode($body);
utf8::upgrade($body);
sub debug($) {
my $message = $_[0];
$message =~ s!\n!\n#SERVER:!g;
warn "#SERVER: $message"
if $ENV{TEST_HTTP_VERBOSE};
};
SERVERLOOP: {
my $quitserver;
while (my $c = $d->accept) {
debug "New connection";
while (my $r = $c->get_request) {
debug "Request:\n" . $r->as_string;
my $location = ($r->uri->path || "/");
my ($link1,$link2) = ('','');
if ($location =~ m!^/link/([^/]+)/(.*)$!) {
($link1,$link2) = ($1,$2);
};
my $res;
if ($location eq '/get_server_log') {
$res = HTTP::Response->new(200, "OK", undef, $log);
$log = '';
} elsif ( $location eq '/quit_server') {
debug "Quitting";
$res = HTTP::Response->new(200, "OK", [Connection => 'close'], "quit");
$quitserver = 1;
} else {
eval $expression
if $expression;
warn "eval: $@" if $@;
$log .= "Request:\n" . $r->as_string . "\n";
if ($location =~ m!^/redirect/(.*)$!) {
$res = HTTP::Response->new(302);
$res->header('location', $d->url . $1);
} elsif ($location =~ m!^/error/notfound/(.*)$!) {
$res = HTTP::Response->new(404, "Not found", [Connection => 'close']);
} elsif ($location =~ m!^/error/timeout/(\d+)$!) {
sleep $1;
$res = HTTP::Response->new(599, "Timeout reached", [Connection => 'close']);
} elsif ($location =~ m!^/error/close/(\d+)$!) {
sleep $1;
$res = undef;
} elsif ( $location =~ m!^/chunks!) {
my $count = 5;
$res = HTTP::Response->new(200, "OK", undef, sub {
sleep 1;
my $buf = 'x' x 16;
return $buf if $count-- > 0;
return undef; # done
});
} elsif ($location =~ m!^/error/after_headers$!) {
my $count = 2;
$res = HTTP::Response->new(200, "OK", undef, sub {
sleep 1;
my $buf = 'x' x 16;
return $buf if $count-- > 0;
die "Planned error after headers";
});
} elsif ($location =~ m!^/encoding/(.*)!) {
my $encoding = $1;
$res = HTTP::Response->new(
200, "OK",
[ 'Content-Type' => "text/html; charset=$encoding" ],
"encoding $encoding"
);
} else {
my $q = CGI->new($r->uri->query);
# Make sticky form fields
my ($query,$session,%cat);
$query = defined $q->param('query') ? $q->param('query') : "(empty)";
$session = defined $q->param('session') ? $q->param('session') : 1;
%cat = map { $_ => 1 } (defined $q->param('cat') ? $q->multi_param('cat') : qw( cat_foo cat_bar ));
my @categories = map { $cat{$_} ? "checked" : "" } qw( cat_foo cat_bar cat_baz );
(my $h = $r->headers->{host}) =~ s/:\d+//;
my $rbody = sprintf $body,$location,$session,$query,@categories;
$res = HTTP::Response->new(200, "OK", [
"Set-Cookie" => $q->cookie(-name => 'log-server',-value=>'shazam2', -discard=>1,),
'Cache-Control' => 'no-cache',
'Pragma' => 'no-cache',
'Max-Age' => 0,
'Connection' => 'close',
'Content-Length' => length($rbody),
], $rbody);
$res->content_type(
$q->param('xml') ? 'application/xhtml+xml' : 'text/html'
);
debug "Request " . ($r->uri->path || "/");
};
};
debug "Response:\n" . $res->as_string
if $res;
eval {
$c->send_response($res)
if $res;
};
if (my $err = $@) {
debug "Server raised error: $err";
if ($err !~ /^Planned error\b/) {
warn $err;
};
$c->close;
};
if (! $res) {
$c->close;
};
last if $quitserver;
}
sleep 1;
undef($c);
last SERVERLOOP
if $quitserver;
}
};
END { debug "Server stopped" };
__DATA__
<html>
<head>
<title>WWW::Mechanize test page</title>
</head>
<body>
<h1>Location: %s</h1>
<p>
<a href="/test">Link /test</a>
<a href="/foo">Link /foo</a>
<a href="/slash_end">Link /</a>
<a href="/slash_front">/Link </a>
<a href="/slash_both">/Link in slashes/</a>
<a href="/foo1.save_log_server_test.tmp">Link foo1.save_log_server_test.tmp</a>
<a href="/foo2.save_log_server_test.tmp">Link foo2.save_log_server_test.tmp</a>
<a href="/foo3.save_log_server_test.tmp">Link foo3.save_log_server_test.tmp</a>
<a href="/o-umlaut">L<!xf6>schen -- testing for o-umlaut.</a>
<a href="/o-umlaut-encoded">Stösberg -- testing for encoded o-umlaut.</a>
<table>
<tr><th>Col1</th><th>Col2</th><th>Col3</th></tr>
<tr><td>A1</td><td>A2</td><td>A3</td></tr>
<tr><td>B1</td><td>B2</td><td>B3</td></tr>
<tr><td>C1</td><td>C2</td><td>C3</td></tr>
</table>
<form name="f" action="/formsubmit" class="test" foo="">
<input type="hidden" name="session" value="%s"/>
<input type="text" name="query" value="%s"/>
<input type="submit" name="submit" value="Go" id="0" />
<input type="checkbox" name="cat" value="cat_foo" %s />
<input type="checkbox" name="cat" value="cat_bar" %s />
<input type="checkbox" name="cat" value="cat_baz" %s />
<input type="file" name="upload" value="README" />
</form>
<form id="pounder" action="/formsubmit" class="test" foo="">
<input type="text" name="query" value="%s"/>
</form>
</p>
</body>
</html>