aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rwxr-xr-xtests/httpserver.pl132
1 files changed, 132 insertions, 0 deletions
diff --git a/tests/httpserver.pl b/tests/httpserver.pl
new file mode 100755
index 000000000..0fd0bc374
--- /dev/null
+++ b/tests/httpserver.pl
@@ -0,0 +1,132 @@
+#!/usr/bin/perl
+use Socket;
+use Carp;
+
+sub spawn; # forward declaration
+sub logmsg { #print "$0 $$: @_ at ", scalar localtime, "\n"
+ }
+
+my $port = shift || $ARGV[0];
+my $proto = getprotobyname('tcp');
+$port = $1 if $port =~ /(\d+)/; # untaint port number
+
+socket(Server, PF_INET, SOCK_STREAM, $proto)|| die "socket: $!";
+ setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
+ pack("l", 1)) || die "setsockopt: $!";
+bind(Server, sockaddr_in($port, INADDR_ANY))|| die "bind: $!";
+listen(Server,SOMAXCONN) || die "listen: $!";
+
+logmsg "server started on port $port";
+
+open(PID, ">log/server.pid");
+print PID $$;
+close(PID);
+
+my $waitedpid = 0;
+my $paddr;
+
+sub REAPER {
+ $waitedpid = wait;
+ $SIG{CHLD} = \&REAPER; # loathe sysV
+ logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
+}
+
+$SIG{CHLD} = \&REAPER;
+
+for ( $waitedpid = 0;
+ ($paddr = accept(Client,Server)) || $waitedpid;
+ $waitedpid = 0, close Client)
+{
+ next if $waitedpid and not $paddr;
+ my($port,$iaddr) = sockaddr_in($paddr);
+ my $name = gethostbyaddr($iaddr,AF_INET);
+
+ logmsg "connection from $name [", inet_ntoa($iaddr), "] at port $port";
+
+ # this code is forked and run
+ spawn sub {
+ while(<STDIN>) {
+ if($_ =~ /(GET|POST|HEAD) (.*) HTTP\/1.(\d)/) {
+ $request=$1;
+ $path=$2;
+ $ver=$3;
+ }
+ elsif($_ =~ /^Content-Length: (\d*)/) {
+ $cl=$1;
+ }
+ # print "RCV: $_";
+
+ push @headers, $_;
+
+ if($left > 0) {
+ $left -= length($_);
+ }
+
+ if(($_ eq "\r\n") or ($_ eq "")) {
+ if($request eq "POST") {
+ $left=$cl;
+ }
+ else {
+ $left = -1; # force abort
+ }
+ }
+ if($left < 0) {
+ last;
+ }
+ }
+
+ #
+ # we always start the path with a number, this is the
+ # test number that this server will use to know what
+ # contents to pass back to the client
+ #
+ if($path =~ /^\/(\d*)/) {
+ $testnum=$1;
+ }
+ else {
+ print STDERR "UKNOWN TEST CASE\n";
+ exit;
+ }
+ open(INPUT, ">log/server.input");
+ for(@headers) {
+ print INPUT $_;
+ }
+ close(INPUT);
+
+ # send a reply to the client
+ open(DATA, "<data/reply$testnum.txt");
+ while(<DATA>) {
+ print $_;
+ }
+ close(DATA);
+
+ # print "Hello there, $name, it's now ", scalar localtime, "\r\n";
+ };
+}
+
+
+sub spawn {
+ my $coderef = shift;
+
+
+ unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
+ confess "usage: spawn CODEREF";
+ }
+
+
+ my $pid;
+ if (!defined($pid = fork)) {
+ logmsg "cannot fork: $!";
+ return;
+ } elsif ($pid) {
+ logmsg "begat $pid";
+ return; # I'm the parent
+ }
+ # else I'm the child -- go spawn
+
+
+ open(STDIN, "<&Client") || die "can't dup client to stdin";
+ open(STDOUT, ">&Client") || die "can't dup client to stdout";
+ ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
+ exit &$coderef();
+}