curl/tests/runserv.pl

#!/usr/bin/perl
#
# runserv.pl - run a dumb tcp server on a port for the curl test suite
# derived from 'ftproxy' by Björn Stenberg/Linus Nielsen that was
# derived from "fwdport.pl" by Tom Christiansen

use FileHandle;
use Net::hostent;      # Example 17-8    # by-name interface for host info
use IO::Socket;             # for creating server and client sockets
use POSIX ":sys_wait_h";    # for reaping our dead children

my $localip = $ARGV[0];
my $localport = $ARGV[1];

if(($localip eq "") ||
   ($localport eq "")) {
    print "Usage: runserv.pl <ip> <port>\n";
    exit;
}

my (
    %Children,              # hash of outstanding child processes
    $proxy_server,          # the socket we accept() from
    $ME,                    # basename of this program
);

($ME = $0) =~ s,.*/,,;      # retain just basename of script name

start_server();             # launch our own server
service_clients();          # wait for incoming
print "[TCP server exited]\n";
exit;

# begin our server 
sub start_server {
    $proxy_server = IO::Socket::INET->new(Listen    => 5,
                                          LocalAddr => $localip,
                                          LocalPort => $localport,
                                          Proto     => 'tcp',
                                          Reuse     => 1)
        or die "can't open socket";

#    print "[TCP server initialized";
#    print " on " . $proxy_server->sockhost() . ":" . 
#        $proxy_server->sockport() . "]\n";
}

sub service_clients { 
    my (
        $local_client,              # someone internal wanting out
        $lc_info,                   # local client's name/port information
        @rs_config,                 # temp array for remote socket options
        $rs_info,                   # remote server's name/port information
        $kidpid,                    # spawned child for each connection
        $file,
        $request,
        @headers
    );

    $SIG{CHLD} = \&REAPER;          # harvest the moribund

#    print "Listening...\n";

    while ($local_client = $proxy_server->accept()) {
        $lc_info = peerinfo($local_client);
        printf "[Connect from $lc_info]\n";

        $kidpid = fork();
        die "Cannot fork" unless defined $kidpid;
        if ($kidpid) {
            $Children{$kidpid} = time();            # remember his start time
            close $local_client;                    # likewise
            next;                                   # go get another client
        } 

        # now, read the data from the client
        # and pass back what we want it to have

        undef $request;
        undef $path;
        undef $ver;
        undef @headers;
        $cl=0;
        $left=0;
        while(<$local_client>) {
            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;
            }
        }
     #   print "Request: $request\n",
     #   "Path: $path\n",
     #   "Version: $ver\n";

        #
        # 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 "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 $local_client $_;
        }
        close(DATA);

        exit; # whoever's still alive bites it
    }
}

# helper function to produce a nice string in the form HOST:PORT
sub peerinfo {
    my $sock = shift;
    my $hostinfo = gethostbyaddr($sock->peeraddr);
    return sprintf("%s:%s", 
                    $hostinfo->name || $sock->peerhost, 
                    $sock->peerport);
} 

# somebody just died.  keep harvesting the dead until 
# we run out of them.  check how long they ran.
sub REAPER { 
    my $child;
    my $start;
    while (($child = waitpid(-1,WNOHANG)) > 0) {
        if ($start = $Children{$child}) {
            my $runtime = time() - $start;
          #  printf "Child $child ran %dm%ss\n", 
          #  $runtime / 60, $runtime % 60;
            delete $Children{$child};
        } else {
          #  print "Unknown child process $child exited $?\n";
        } 
    }
    # If I had to choose between System V and 4.2, I'd resign. --Peter Honeyman
    $SIG{CHLD} = \&REAPER; 
};