init
This commit is contained in:
127
wcmtools/perlbal/lib/Perlbal/Test/WebClient.pm
Executable file
127
wcmtools/perlbal/lib/Perlbal/Test/WebClient.pm
Executable file
@@ -0,0 +1,127 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package Perlbal::Test::WebClient;
|
||||
|
||||
use strict;
|
||||
use IO::Socket::INET;
|
||||
use HTTP::Response;
|
||||
use Socket qw(MSG_NOSIGNAL);
|
||||
|
||||
require Exporter;
|
||||
use vars qw(@ISA @EXPORT $FLAG_NOSIGNAL);
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(new);
|
||||
|
||||
eval { $FLAG_NOSIGNAL = MSG_NOSIGNAL; };
|
||||
|
||||
# create a blank object
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
# get/set what server we should be testing; "ip:port" generally
|
||||
sub server {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
return $self->{server} = shift;
|
||||
} else {
|
||||
return $self->{server};
|
||||
}
|
||||
}
|
||||
|
||||
# set which HTTP version to emulate; specify '1.0' or '1.1'
|
||||
sub http_version {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
return $self->{http_version} = shift;
|
||||
} else {
|
||||
return $self->{http_version};
|
||||
}
|
||||
}
|
||||
|
||||
# set on or off to enable or disable persistent connection
|
||||
sub keepalive {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{keepalive} = shift() ? 1 : 0;
|
||||
}
|
||||
return $self->{keepalive};
|
||||
}
|
||||
|
||||
# construct and send a request
|
||||
sub request {
|
||||
my $self = shift;
|
||||
return undef unless $self->{server};
|
||||
|
||||
my $cmds = join(',', map { eurl($_) } @_);
|
||||
return undef unless $cmds;
|
||||
|
||||
# keep-alive header if 1.0, also means add content-length header
|
||||
my $headers = '';
|
||||
$headers .= "Connection: keep-alive\r\n"
|
||||
if $self->{keepalive};
|
||||
my $send = "GET /$cmds HTTP/$self->{http_version}\r\n$headers\r\n";
|
||||
my $len = length $send;
|
||||
|
||||
# send setup
|
||||
my $rv;
|
||||
my $sock = $self->{_sock};
|
||||
local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
|
||||
|
||||
### send it cached
|
||||
if ($sock) {
|
||||
$rv = send($sock, $send, $FLAG_NOSIGNAL);
|
||||
if ($! || ! defined $rv) {
|
||||
undef $self->{_sock};
|
||||
} elsif ($rv != $len) {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# failing that, send it through a new socket
|
||||
unless ($rv) {
|
||||
$sock = IO::Socket::INET->new(
|
||||
PeerAddr => $self->{server},
|
||||
Timeout => 3,
|
||||
) or return undef;
|
||||
$rv = send($sock, $send, $FLAG_NOSIGNAL);
|
||||
if ($! || $rv != $len) {
|
||||
return undef;
|
||||
}
|
||||
$self->{_sock} = $sock
|
||||
if $self->{keepalive};
|
||||
}
|
||||
|
||||
my $res = '';
|
||||
while (<$sock>) {
|
||||
$res .= $_;
|
||||
last if ! $_ || /^\r?\n/;
|
||||
}
|
||||
|
||||
my $resp = HTTP::Response->parse($res);
|
||||
return undef unless $resp;
|
||||
|
||||
my $cl = $resp->header('Content-Length');
|
||||
if ($cl > 0) {
|
||||
my $content = '';
|
||||
while (($cl -= read($sock, $content, $cl)) > 0) {
|
||||
# don't do anything, the loop is it
|
||||
}
|
||||
$resp->content($content);
|
||||
}
|
||||
|
||||
return $resp;
|
||||
}
|
||||
|
||||
# general purpose URL escaping function
|
||||
sub eurl {
|
||||
my $a = $_[0];
|
||||
$a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
|
||||
$a =~ tr/ /+/;
|
||||
return $a;
|
||||
}
|
||||
|
||||
1;
|
||||
114
wcmtools/perlbal/lib/Perlbal/Test/WebServer.pm
Executable file
114
wcmtools/perlbal/lib/Perlbal/Test/WebServer.pm
Executable file
@@ -0,0 +1,114 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package Perlbal::Test::WebServer;
|
||||
|
||||
use strict;
|
||||
use IO::Socket::INET;
|
||||
use HTTP::Request;
|
||||
|
||||
use Perlbal::Test;
|
||||
|
||||
require Exporter;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(start_webserver);
|
||||
|
||||
our @webserver_pids;
|
||||
|
||||
END {
|
||||
# ensure we kill off the webserver
|
||||
kill 9, @webserver_pids;
|
||||
}
|
||||
|
||||
sub start_webserver {
|
||||
my $port = new_port();
|
||||
|
||||
if (my $child = fork) {
|
||||
# i am parent, wait for child to startup
|
||||
push @webserver_pids, $child;
|
||||
my $sock = wait_on_child($child, $port);
|
||||
die "Unable to spawn webserver on port $port\n"
|
||||
unless $sock;
|
||||
print $sock "GET /status HTTP/1.0\r\n\r\n";
|
||||
my $line = <$sock>;
|
||||
die "Didn't get 200 OK: $line"
|
||||
unless $line =~ /200 OK/;
|
||||
return $port;
|
||||
}
|
||||
|
||||
# i am child, start up
|
||||
my $ssock = IO::Socket::INET->new(LocalPort => $port, ReuseAddr => 1, Listen => 3)
|
||||
or die "Unable to start socket: $!\n";
|
||||
while (my $csock = $ssock->accept) {
|
||||
exit 0 unless $csock;
|
||||
fork and next; # parent starts waiting for next request
|
||||
|
||||
my $response = sub {
|
||||
my ($code, $msg, $content, $ctype) = @_;
|
||||
$msg ||= { 200 => 'OK', 500 => 'Internal Server Error' }->{$code};
|
||||
$content ||= "$code $msg";
|
||||
my $clen = length $content;
|
||||
$ctype ||= "text/plain";
|
||||
return "HTTP/1.0 $code $msg\r\n" .
|
||||
"Content-Type: $ctype\r\n" .
|
||||
"Content-Length: $clen\r\n" .
|
||||
"\r\n" .
|
||||
"$content";
|
||||
};
|
||||
|
||||
my $req = '';
|
||||
while (<$csock>) {
|
||||
$req .= $_;
|
||||
last if ! $_ || /^\r?\n/;
|
||||
}
|
||||
|
||||
# parse out things we want to have
|
||||
my @cmds;
|
||||
my $httpver; # 0 = 1.0, 1 = 1.1, undef = neither
|
||||
if ($req =~ m!^GET /(\S+) HTTP/(1\.\d+)\r?\n?!) {
|
||||
@cmds = split(/\s*,\s*/, durl($1));
|
||||
$httpver = ($2 eq '1.0' ? 0 : ($2 eq '1.1' ? 1 : undef));
|
||||
}
|
||||
my $msg = HTTP::Request->parse($req);
|
||||
|
||||
# 500 if no commands were given or we don't know their HTTP version
|
||||
# or we didn't parse a proper HTTP request
|
||||
unless (@cmds && defined $httpver && $msg) {
|
||||
print $csock $response->(500);
|
||||
exit 0;
|
||||
}
|
||||
|
||||
# prepare a simple 200 to send; undef this if you want to control
|
||||
# your own output below
|
||||
my $to_send = $response->(200);
|
||||
|
||||
foreach my $cmd (@cmds) {
|
||||
$cmd =~ s/^\s+//;
|
||||
$cmd =~ s/\s+$//;
|
||||
|
||||
if ($cmd =~ /^sleep\s+(\d+)$/i) {
|
||||
sleep $1+0;
|
||||
}
|
||||
|
||||
if ($cmd =~ /^status$/i) {
|
||||
$to_send = $response->(200, undef, "pid = $$");
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $to_send) {
|
||||
print $csock $to_send;
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
|
||||
# de-url escape
|
||||
sub durl {
|
||||
my ($a) = @_;
|
||||
$a =~ tr/+/ /;
|
||||
$a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
|
||||
return $a;
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user