diff options
Diffstat (limited to 'data/lighttpd/lighttpd-1.4.53/tests/LightyTest.pm')
| -rw-r--r-- | data/lighttpd/lighttpd-1.4.53/tests/LightyTest.pm | 447 |
1 files changed, 447 insertions, 0 deletions
diff --git a/data/lighttpd/lighttpd-1.4.53/tests/LightyTest.pm b/data/lighttpd/lighttpd-1.4.53/tests/LightyTest.pm new file mode 100644 index 000000000..74caea1e4 --- /dev/null +++ b/data/lighttpd/lighttpd-1.4.53/tests/LightyTest.pm @@ -0,0 +1,447 @@ +package LightyTest; + +use strict; +use IO::Socket; +use Test::More; +use Socket; +use Cwd 'abs_path'; +use POSIX qw(:sys_wait_h dup2); +use Errno qw(EADDRINUSE); + +sub find_program { + my @DEFAULT_PATHS = ('/usr/bin/', '/usr/local/bin/'); + my ($envname, $program) = @_; + my $location; + + if (defined $ENV{$envname}) { + $location = $ENV{$envname}; + } else { + $location = `which "$program" 2>/dev/null`; + chomp $location; + if (! -x $location) { + for my $path (@DEFAULT_PATHS) { + $location = $path . $program; + last if -x $location; + } + } + } + + if (-x $location) { + $ENV{$envname} = $location; + return 1; + } else { + delete $ENV{$envname}; + return 0; + } +} + +BEGIN { + our $HAVE_PHP = find_program('PHP', 'php-cgi'); + our $HAVE_PERL = find_program('PERL', 'perl'); + if (!$HAVE_PERL) { + die "Couldn't find path to perl, but it obviously seems to be running"; + } +} + +sub mtime { + my $file = shift; + my @stat = stat $file; + return @stat ? $stat[9] : 0; +} + +sub new { + my $class = shift; + my $self = {}; + my $lpath; + + $self->{CONFIGFILE} = 'lighttpd.conf'; + + $lpath = (defined $ENV{'top_builddir'} ? $ENV{'top_builddir'} : '..'); + $self->{BASEDIR} = abs_path($lpath); + + $lpath = (defined $ENV{'top_builddir'} ? $ENV{'top_builddir'}."/tests/" : '.'); + $self->{TESTDIR} = abs_path($lpath); + + $lpath = (defined $ENV{'srcdir'} ? $ENV{'srcdir'} : '.'); + $self->{SRCDIR} = abs_path($lpath); + + + if (mtime($self->{BASEDIR}.'/src/lighttpd') > mtime($self->{BASEDIR}.'/build/lighttpd')) { + $self->{BINDIR} = $self->{BASEDIR}.'/src'; + if (mtime($self->{BASEDIR}.'/src/.libs')) { + $self->{MODULES_PATH} = $self->{BASEDIR}.'/src/.libs'; + } else { + $self->{MODULES_PATH} = $self->{BASEDIR}.'/src'; + } + } else { + $self->{BINDIR} = $self->{BASEDIR}.'/build'; + $self->{MODULES_PATH} = $self->{BASEDIR}.'/build'; + } + $self->{LIGHTTPD_PATH} = $self->{BINDIR}.'/lighttpd'; + $self->{PORT} = 2048; + + my ($name, $aliases, $addrtype, $net) = gethostbyaddr(inet_aton("127.0.0.1"), AF_INET); + + $self->{HOSTNAME} = $name; + + bless($self, $class); + + return $self; +} + +sub listening_on { + my $self = shift; + my $port = shift; + + my $remote = IO::Socket::INET->new( + Proto => "tcp", + PeerAddr => "127.0.0.1", + PeerPort => $port) or return 0; + + close $remote; + + return 1; +} + +sub stop_proc { + my $self = shift; + + my $pid = $self->{LIGHTTPD_PID}; + if (defined $pid && $pid != -1) { + kill('TERM', $pid) or return -1; + return -1 if ($pid != waitpid($pid, 0)); + } else { + diag("\nProcess not started, nothing to stop"); + return -1; + } + + return 0; +} + +sub wait_for_port_with_proc { + my $self = shift; + my $port = shift; + my $child = shift; + my $timeout = 10*50; # 10 secs (valgrind might take a while), select waits 0.02 s + + while (0 == $self->listening_on($port)) { + select(undef, undef, undef, 0.02); + $timeout--; + + # the process is gone, we failed + if (0 != waitpid($child, WNOHANG)) { + return -1; + } + if (0 >= $timeout) { + diag("\nTimeout while trying to connect; killing child"); + kill('TERM', $child); + return -1; + } + } + + return 0; +} + +sub start_proc { + my $self = shift; + # kill old proc if necessary + #$self->stop_proc; + + if ($self->listening_on($self->{PORT})) { + diag("\nPort ".$self->{PORT}." already in use"); + return -1; + } + + # pre-process configfile if necessary + # + + $ENV{'SRCDIR'} = $self->{BASEDIR}.'/tests'; + $ENV{'PORT'} = $self->{PORT}; + + my @cmdline = ($self->{LIGHTTPD_PATH}, "-D", "-f", $self->{SRCDIR}."/".$self->{CONFIGFILE}, "-m", $self->{MODULES_PATH}); + if (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'strace') { + @cmdline = (qw(strace -tt -s 4096 -o strace -f -v), @cmdline); + } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'truss') { + @cmdline = (qw(truss -a -l -w all -v all -o strace), @cmdline); + } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'gdb') { + @cmdline = ('gdb', '--batch', '--ex', 'run', '--ex', 'bt full', '--args', @cmdline); + } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'valgrind') { + @cmdline = (qw(valgrind --tool=memcheck --track-origins=yes --show-reachable=yes --leak-check=yes --log-file=valgrind.%p), @cmdline); + } + # diag("\nstarting lighttpd at :".$self->{PORT}.", cmdline: ".@cmdline ); + my $child = fork(); + if (not defined $child) { + diag("\nFork failed"); + return -1; + } + if ($child == 0) { + exec @cmdline or die($?); + } + + if (0 != $self->wait_for_port_with_proc($self->{PORT}, $child)) { + diag(sprintf('\nThe process %i is not up', $child)); + return -1; + } + + $self->{LIGHTTPD_PID} = $child; + + 0; +} + +sub handle_http { + my $self = shift; + my $t = shift; + my $EOL = "\015\012"; + my $BLANK = $EOL x 2; + my $host = "127.0.0.1"; + + my @request = $t->{REQUEST}; + my @response = $t->{RESPONSE}; + my $slow = defined $t->{SLOWREQUEST}; + my $is_debug = $ENV{"TRACE_HTTP"}; + + my $remote = + IO::Socket::INET->new( + Proto => "tcp", + PeerAddr => $host, + PeerPort => $self->{PORT}); + + if (not defined $remote) { + diag("\nconnect failed: $!"); + return -1; + } + + $remote->autoflush(1); + + if (!$slow) { + diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug; + foreach(@request) { + # pipeline requests + s/\r//g; + s/\n/$EOL/g; + + print $remote $_.$BLANK; + diag("\n<< ".$_) if $is_debug; + } + shutdown($remote, 1) if ($^O ne "openbsd" && $^O ne "dragonfly"); # I've stopped writing data + } else { + diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug; + foreach(@request) { + # pipeline requests + chomp; + s/\r//g; + s/\n/$EOL/g; + + print $remote $_; + diag("<< ".$_."\n") if $is_debug; + select(undef, undef, undef, 0.1); + print $remote "\015"; + select(undef, undef, undef, 0.1); + print $remote "\012"; + select(undef, undef, undef, 0.1); + print $remote "\015"; + select(undef, undef, undef, 0.1); + print $remote "\012"; + select(undef, undef, undef, 0.1); + } + + } + diag("\n... done") if $is_debug; + + my $lines = ""; + + diag("\nreceiving response") if $is_debug; + # read everything + while(<$remote>) { + $lines .= $_; + diag(">> ".$_) if $is_debug; + } + diag("\n... done") if $is_debug; + + close $remote; + + my $full_response = $lines; + + my $href; + foreach $href ( @{ $t->{RESPONSE} }) { + # first line is always response header + my %resp_hdr; + my $resp_body; + my $resp_line; + my $conditions = $_; + + for (my $ln = 0; defined $lines; $ln++) { + (my $line, $lines) = split($EOL, $lines, 2); + + # header finished + last if(!defined $line or length($line) == 0); + + if ($ln == 0) { + # response header + $resp_line = $line; + } else { + # response vars + + if ($line =~ /^([^:]+):\s*(.+)$/) { + (my $h = $1) =~ tr/[A-Z]/[a-z]/; + + if (defined $resp_hdr{$h}) { +# diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n", +# $h, $resp_hdr{$h}, $2)); + $resp_hdr{$h} .= ', '.$2; + } else { + $resp_hdr{$h} = $2; + } + } else { + diag(sprintf("\nunexpected line '%s'", $line)); + return -1; + } + } + } + + if (not defined($resp_line)) { + diag(sprintf("\nempty response")); + return -1; + } + + $t->{etag} = $resp_hdr{'etag'}; + $t->{date} = $resp_hdr{'date'}; + + # check length + if (defined $resp_hdr{"content-length"}) { + $resp_body = substr($lines, 0, $resp_hdr{"content-length"}); + if (length($lines) < $resp_hdr{"content-length"}) { + $lines = ""; + } else { + $lines = substr($lines, $resp_hdr{"content-length"}); + } + undef $lines if (length($lines) == 0); + } else { + $resp_body = $lines; + undef $lines; + } + + # check conditions + if ($resp_line =~ /^(HTTP\/1\.[01]) ([0-9]{3}) .+$/) { + if ($href->{'HTTP-Protocol'} ne $1) { + diag(sprintf("\nproto failed: expected '%s', got '%s'", $href->{'HTTP-Protocol'}, $1)); + return -1; + } + if ($href->{'HTTP-Status'} ne $2) { + diag(sprintf("\nstatus failed: expected '%s', got '%s'", $href->{'HTTP-Status'}, $2)); + return -1; + } + } else { + diag(sprintf("\nunexpected resp_line '%s'", $resp_line)); + return -1; + } + + if (defined $href->{'HTTP-Content'}) { + $resp_body = "" unless defined $resp_body; + if ($href->{'HTTP-Content'} ne $resp_body) { + diag(sprintf("\nbody failed: expected '%s', got '%s'", $href->{'HTTP-Content'}, $resp_body)); + return -1; + } + } + + if (defined $href->{'-HTTP-Content'}) { + if (defined $resp_body && $resp_body ne '') { + diag(sprintf("\nbody failed: expected empty body, got '%s'", $resp_body)); + return -1; + } + } + + foreach (keys %{ $href }) { + next if $_ eq 'HTTP-Protocol'; + next if $_ eq 'HTTP-Status'; + next if $_ eq 'HTTP-Content'; + next if $_ eq '-HTTP-Content'; + + (my $k = $_) =~ tr/[A-Z]/[a-z]/; + + my $verify_value = 1; + my $key_inverted = 0; + + if (substr($k, 0, 1) eq '+') { + $k = substr($k, 1); + $verify_value = 0; + } elsif (substr($k, 0, 1) eq '-') { + ## the key should NOT exist + $k = substr($k, 1); + $key_inverted = 1; + $verify_value = 0; ## skip the value check + } + + if ($key_inverted) { + if (defined $resp_hdr{$k}) { + diag(sprintf("\nheader '%s' MUST not be set", $k)); + return -1; + } + } else { + if (not defined $resp_hdr{$k}) { + diag(sprintf("\nrequired header '%s' is missing", $k)); + return -1; + } + } + + if ($verify_value) { + if ($href->{$_} =~ /^\/(.+)\/$/) { + if ($resp_hdr{$k} !~ /$1/) { + diag(sprintf( + "\nresponse-header failed: expected '%s', got '%s', regex: %s", + $href->{$_}, $resp_hdr{$k}, $1)); + return -1; + } + } elsif ($href->{$_} ne $resp_hdr{$k}) { + diag(sprintf( + "\nresponse-header failed: expected '%s', got '%s'", + $href->{$_}, $resp_hdr{$k})); + return -1; + } + } + } + } + + # we should have sucked up everything + if (defined $lines) { + diag(sprintf("\nunexpected lines '%s'", $lines)); + return -1; + } + + return 0; +} + +sub spawnfcgi { + my ($self, $binary, $port) = @_; + my $child = fork(); + if (not defined $child) { + diag("\nCouldn't fork"); + return -1; + } + if ($child == 0) { + my $iaddr = inet_aton('localhost') || die "no host: localhost"; + my $proto = getprotobyname('tcp'); + socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; + setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!"; + bind(SOCK, sockaddr_in($port, $iaddr)) || die "bind: $!"; + listen(SOCK, 1024) || die "listen: $!"; + dup2(fileno(SOCK), 0) || die "dup2: $!"; + exec { $binary } ($binary) or die($?); + } else { + if (0 != $self->wait_for_port_with_proc($port, $child)) { + diag(sprintf("\nThe process %i is not up (port %i, %s)", $child, $port, $binary)); + return -1; + } + return $child; + } +} + +sub endspawnfcgi { + my ($self, $pid) = @_; + return -1 if (-1 == $pid); + kill(2, $pid); + waitpid($pid, 0); + return 0; +} + +1; |