mirror of
https://github.com/moparisthebest/curl
synced 2024-12-21 23:58:49 -05:00
cut off the old perl one, this only runs the C coded version
This commit is contained in:
Daniel Stenberg
parent
6d8c7356d6
commit
6fe4a6fa9a
@ -1,15 +1,6 @@
|
||||
#!/usr/bin/perl
|
||||
use Socket;
|
||||
use Carp;
|
||||
use FileHandle;
|
||||
#!/usr/bin/env perl
|
||||
|
||||
#use strict;
|
||||
|
||||
require "getpart.pm";
|
||||
|
||||
sub spawn; # forward declaration
|
||||
sub logmsg { #print "$0 $$: @_ at ", scalar localtime, "\n"
|
||||
}
|
||||
use strict;
|
||||
|
||||
my $verbose=0; # set to 1 for debugging
|
||||
|
||||
@ -23,204 +14,4 @@ do {
|
||||
}
|
||||
} while(shift @ARGV);
|
||||
|
||||
my $proto = getprotobyname('tcp') || 6;
|
||||
|
||||
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: $!";
|
||||
|
||||
if($verbose) {
|
||||
print "HTTP server started on port $port\n";
|
||||
}
|
||||
|
||||
open(PID, ">.http.pid");
|
||||
print PID $$;
|
||||
close(PID);
|
||||
|
||||
my $PID=$$;
|
||||
|
||||
my $waitedpid = 0;
|
||||
my $paddr;
|
||||
|
||||
sub REAPER {
|
||||
$waitedpid = wait;
|
||||
$SIG{CHLD} = \&REAPER; # loathe sysV
|
||||
logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
|
||||
}
|
||||
|
||||
sub performcmd {
|
||||
my @cmd = @_;
|
||||
for(@cmd) {
|
||||
if($_ =~ /^ *wait *(\d*)/) {
|
||||
# instructed to sleep!
|
||||
sleep($1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$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 {
|
||||
my ($request, $path, $ver, $left, $cl);
|
||||
|
||||
my @headers;
|
||||
|
||||
while(<STDIN>) {
|
||||
if($_ =~ /([A-Z]*) (.*) HTTP\/1.(\d)/) {
|
||||
$request=$1;
|
||||
$path=$2;
|
||||
$ver=$3;
|
||||
}
|
||||
elsif($_ =~ /^Content-Length: (\d*)/) {
|
||||
$cl=$1;
|
||||
}
|
||||
|
||||
if($verbose) {
|
||||
print STDERR "IN: $_";
|
||||
}
|
||||
|
||||
push @headers, $_;
|
||||
|
||||
if($left > 0) {
|
||||
$left -= length($_);
|
||||
if($left == 0) {
|
||||
$left = -1; # just to force a loop break here
|
||||
}
|
||||
}
|
||||
# print STDERR "RCV ($left): $_";
|
||||
|
||||
if(!$left &&
|
||||
($_ eq "\r\n") or ($_ eq "")) {
|
||||
if($request =~ /^(POST|PUT)$/) {
|
||||
$left=$cl;
|
||||
}
|
||||
elsif($request =~ /^CONNECT$/) {
|
||||
if($verbose) {
|
||||
print STDERR "We're emulating a SSL proxy!\n";
|
||||
}
|
||||
$left = -1;
|
||||
}
|
||||
else {
|
||||
$left = -1; # force abort
|
||||
}
|
||||
}
|
||||
if($left < 0) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if($request =~ /^CONNECT$/) {
|
||||
# ssl proxy mode
|
||||
print "HTTP/1.1 400 WE CANNOT ROOL NOW\r\n",
|
||||
"Server: bahoooba\r\n\r\n";
|
||||
exit;
|
||||
}
|
||||
elsif($path =~ /verifiedserver/) {
|
||||
# this is a hard-coded query-string for the test script
|
||||
# to verify that this is the server actually running!
|
||||
print "HTTP/1.1 999 WE ROOLZ: $PID\r\n";
|
||||
exit;
|
||||
}
|
||||
else {
|
||||
|
||||
#
|
||||
# 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
|
||||
#
|
||||
my $testnum;
|
||||
if($path =~ /.*\/(\d*)/) {
|
||||
$testnum=$1;
|
||||
}
|
||||
else {
|
||||
$testnum=0;
|
||||
}
|
||||
open(INPUT, ">>log/server.input");
|
||||
|
||||
binmode(INPUT,":raw"); # this makes it work better on cygwin
|
||||
|
||||
for(@headers) {
|
||||
print INPUT $_;
|
||||
}
|
||||
close(INPUT);
|
||||
|
||||
if(0 == $testnum ) {
|
||||
print "HTTP/1.1 200 OK\r\n",
|
||||
"header: yes\r\n",
|
||||
"\r\n",
|
||||
"You must enter a test number to get good data back\r\n";
|
||||
}
|
||||
else {
|
||||
my $part="";
|
||||
if($testnum > 10000) {
|
||||
$part = $testnum % 10000;
|
||||
$testnum = sprintf("%d", $testnum/10000);
|
||||
}
|
||||
if($verbose) {
|
||||
print STDERR "OUT: sending reply $testnum (part $part)\n";
|
||||
}
|
||||
|
||||
loadtest("data/test$testnum");
|
||||
|
||||
|
||||
my @cmd = getpart("reply", "cmd");
|
||||
performcmd(@cmd);
|
||||
|
||||
# flush data:
|
||||
$| = 1;
|
||||
|
||||
# send a custom reply to the client
|
||||
my @data = getpart("reply", "data$part");
|
||||
for(@data) {
|
||||
print $_;
|
||||
if($verbose) {
|
||||
print STDERR "OUT: $_";
|
||||
}
|
||||
}
|
||||
my @postcmd = getpart("reply", "postcmd");
|
||||
performcmd(@postcmd);
|
||||
}
|
||||
}
|
||||
# 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();
|
||||
}
|
||||
exec("server/sws $port");
|
||||
|
||||
Loading…
Reference in New Issue
Block a user