Annotation of embedaddon/lighttpd/tests/LightyTest.pm, revision 1.1
1.1 ! misho 1: #! /usr/bin/perl -w
! 2:
! 3: package LightyTest;
! 4: use strict;
! 5: use IO::Socket;
! 6: use Test::More;
! 7: use Socket;
! 8: use Cwd 'abs_path';
! 9: use POSIX qw(:sys_wait_h dup2);
! 10: use Errno qw(EADDRINUSE);
! 11:
! 12: sub mtime {
! 13: my $file = shift;
! 14: my @stat = stat $file;
! 15: return @stat ? $stat[9] : 0;
! 16: }
! 17: sub new {
! 18: my $class = shift;
! 19: my $self = {};
! 20: my $lpath;
! 21:
! 22: $self->{CONFIGFILE} = 'lighttpd.conf';
! 23:
! 24: $lpath = (defined $ENV{'top_builddir'} ? $ENV{'top_builddir'} : '..');
! 25: $self->{BASEDIR} = abs_path($lpath);
! 26:
! 27: $lpath = (defined $ENV{'top_builddir'} ? $ENV{'top_builddir'}."/tests/" : '.');
! 28: $self->{TESTDIR} = abs_path($lpath);
! 29:
! 30: $lpath = (defined $ENV{'srcdir'} ? $ENV{'srcdir'} : '.');
! 31: $self->{SRCDIR} = abs_path($lpath);
! 32:
! 33:
! 34: if (mtime($self->{BASEDIR}.'/src/lighttpd') > mtime($self->{BASEDIR}.'/build/lighttpd')) {
! 35: $self->{BINDIR} = $self->{BASEDIR}.'/src';
! 36: if (mtime($self->{BASEDIR}.'/src/.libs')) {
! 37: $self->{MODULES_PATH} = $self->{BASEDIR}.'/src/.libs';
! 38: } else {
! 39: $self->{MODULES_PATH} = $self->{BASEDIR}.'/src';
! 40: }
! 41: } else {
! 42: $self->{BINDIR} = $self->{BASEDIR}.'/build';
! 43: $self->{MODULES_PATH} = $self->{BASEDIR}.'/build';
! 44: }
! 45: $self->{LIGHTTPD_PATH} = $self->{BINDIR}.'/lighttpd';
! 46: $self->{PORT} = 2048;
! 47:
! 48: my ($name, $aliases, $addrtype, $net) = gethostbyaddr(inet_aton("127.0.0.1"), AF_INET);
! 49:
! 50: $self->{HOSTNAME} = $name;
! 51:
! 52: bless($self, $class);
! 53:
! 54: return $self;
! 55: }
! 56:
! 57: sub listening_on {
! 58: my $self = shift;
! 59: my $port = shift;
! 60:
! 61: my $remote =
! 62: IO::Socket::INET->new(Proto => "tcp",
! 63: PeerAddr => "127.0.0.1",
! 64: PeerPort => $port) or return 0;
! 65:
! 66: close $remote;
! 67:
! 68: return 1;
! 69: }
! 70:
! 71: sub stop_proc {
! 72: my $self = shift;
! 73:
! 74: my $pid = $self->{LIGHTTPD_PID};
! 75: if (defined $pid && $pid != -1) {
! 76: kill('TERM', $pid) or return -1;
! 77: return -1 if ($pid != waitpid($pid, 0));
! 78: } else {
! 79: diag("\nProcess not started, nothing to stop");
! 80: return -1;
! 81: }
! 82:
! 83: return 0;
! 84: }
! 85:
! 86: sub wait_for_port_with_proc {
! 87: my $self = shift;
! 88: my $port = shift;
! 89: my $child = shift;
! 90: my $timeout = 5*10; # 5 secs, select waits 0.1 s
! 91:
! 92: while (0 == $self->listening_on($port)) {
! 93: select(undef, undef, undef, 0.1);
! 94: $timeout--;
! 95:
! 96: # the process is gone, we failed
! 97: if (0 != waitpid($child, WNOHANG)) {
! 98: return -1;
! 99: }
! 100: if (0 >= $timeout) {
! 101: diag("\nTimeout while trying to connect; killing child");
! 102: kill('TERM', $child);
! 103: return -1;
! 104: }
! 105: }
! 106:
! 107: return 0;
! 108: }
! 109:
! 110: sub start_proc {
! 111: my $self = shift;
! 112: # kill old proc if necessary
! 113: #$self->stop_proc;
! 114:
! 115: if ($self->listening_on($self->{PORT})) {
! 116: diag("\nPort ".$self->{PORT}." already in use");
! 117: return -1;
! 118: }
! 119:
! 120: # pre-process configfile if necessary
! 121: #
! 122:
! 123: $ENV{'SRCDIR'} = $self->{BASEDIR}.'/tests';
! 124: $ENV{'PORT'} = $self->{PORT};
! 125:
! 126: my @cmdline = ($self->{LIGHTTPD_PATH}, "-D", "-f", $self->{SRCDIR}."/".$self->{CONFIGFILE}, "-m", $self->{MODULES_PATH});
! 127: if (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'strace') {
! 128: @cmdline = (qw(strace -tt -s 512 -o strace), @cmdline);
! 129: } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'truss') {
! 130: @cmdline = (qw(truss -a -l -w all -v all -o strace), @cmdline);
! 131: } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'gdb') {
! 132: @cmdline = ('gdb', '--batch', '--ex', 'run', '--ex', 'bt full', '--args', @cmdline);
! 133: } elsif (defined $ENV{"TRACEME"} && $ENV{"TRACEME"} eq 'valgrind') {
! 134: @cmdline = (qw(valgrind --tool=memcheck --show-reachable=yes --leak-check=yes --log-file=valgrind), @cmdline);
! 135: }
! 136: # diag("\nstarting lighttpd at :".$self->{PORT}.", cmdline: ".@cmdline );
! 137: my $child = fork();
! 138: if (not defined $child) {
! 139: diag("\nFork failed");
! 140: return -1;
! 141: }
! 142: if ($child == 0) {
! 143: exec @cmdline or die($?);
! 144: }
! 145:
! 146: if (0 != $self->wait_for_port_with_proc($self->{PORT}, $child)) {
! 147: diag(sprintf('\nThe process %i is not up', $child));
! 148: return -1;
! 149: }
! 150:
! 151: $self->{LIGHTTPD_PID} = $child;
! 152:
! 153: 0;
! 154: }
! 155:
! 156: sub handle_http {
! 157: my $self = shift;
! 158: my $t = shift;
! 159: my $EOL = "\015\012";
! 160: my $BLANK = $EOL x 2;
! 161: my $host = "127.0.0.1";
! 162:
! 163: my @request = $t->{REQUEST};
! 164: my @response = $t->{RESPONSE};
! 165: my $slow = defined $t->{SLOWREQUEST};
! 166: my $is_debug = $ENV{"TRACE_HTTP"};
! 167:
! 168: my $remote =
! 169: IO::Socket::INET->new(Proto => "tcp",
! 170: PeerAddr => $host,
! 171: PeerPort => $self->{PORT});
! 172:
! 173: if (not defined $remote) {
! 174: diag("\nconnect failed: $!");
! 175: return -1;
! 176: }
! 177:
! 178: $remote->autoflush(1);
! 179:
! 180: if (!$slow) {
! 181: diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug;
! 182: foreach(@request) {
! 183: # pipeline requests
! 184: s/\r//g;
! 185: s/\n/$EOL/g;
! 186:
! 187: print $remote $_.$BLANK;
! 188: diag("\n<< ".$_) if $is_debug;
! 189: }
! 190: shutdown($remote, 1); # I've stopped writing data
! 191: } else {
! 192: diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug;
! 193: foreach(@request) {
! 194: # pipeline requests
! 195: chomp;
! 196: s/\r//g;
! 197: s/\n/$EOL/g;
! 198:
! 199: print $remote $_;
! 200: diag("<< ".$_."\n") if $is_debug;
! 201: select(undef, undef, undef, 0.1);
! 202: print $remote "\015";
! 203: select(undef, undef, undef, 0.1);
! 204: print $remote "\012";
! 205: select(undef, undef, undef, 0.1);
! 206: print $remote "\015";
! 207: select(undef, undef, undef, 0.1);
! 208: print $remote "\012";
! 209: select(undef, undef, undef, 0.1);
! 210: }
! 211:
! 212: }
! 213: diag("\n... done") if $is_debug;
! 214:
! 215: my $lines = "";
! 216:
! 217: diag("\nreceiving response") if $is_debug;
! 218: # read everything
! 219: while(<$remote>) {
! 220: $lines .= $_;
! 221: diag(">> ".$_) if $is_debug;
! 222: }
! 223: diag("\n... done") if $is_debug;
! 224:
! 225: close $remote;
! 226:
! 227: my $full_response = $lines;
! 228:
! 229: my $href;
! 230: foreach $href ( @{ $t->{RESPONSE} }) {
! 231: # first line is always response header
! 232: my %resp_hdr;
! 233: my $resp_body;
! 234: my $resp_line;
! 235: my $conditions = $_;
! 236:
! 237: for (my $ln = 0; defined $lines; $ln++) {
! 238: (my $line, $lines) = split($EOL, $lines, 2);
! 239:
! 240: # header finished
! 241: last if(!defined $line or length($line) == 0);
! 242:
! 243: if ($ln == 0) {
! 244: # response header
! 245: $resp_line = $line;
! 246: } else {
! 247: # response vars
! 248:
! 249: if ($line =~ /^([^:]+):\s*(.+)$/) {
! 250: (my $h = $1) =~ tr/[A-Z]/[a-z]/;
! 251:
! 252: if (defined $resp_hdr{$h}) {
! 253: # diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n",
! 254: # $h, $resp_hdr{$h}, $2));
! 255: $resp_hdr{$h} .= ', '.$2;
! 256: } else {
! 257: $resp_hdr{$h} = $2;
! 258: }
! 259: } else {
! 260: diag(sprintf("\nunexpected line '%s'", $line));
! 261: return -1;
! 262: }
! 263: }
! 264: }
! 265:
! 266: if (not defined($resp_line)) {
! 267: diag(sprintf("\nempty response"));
! 268: return -1;
! 269: }
! 270:
! 271: $t->{etag} = $resp_hdr{'etag'};
! 272: $t->{date} = $resp_hdr{'date'};
! 273:
! 274: # check length
! 275: if (defined $resp_hdr{"content-length"}) {
! 276: $resp_body = substr($lines, 0, $resp_hdr{"content-length"});
! 277: if (length($lines) < $resp_hdr{"content-length"}) {
! 278: $lines = "";
! 279: } else {
! 280: $lines = substr($lines, $resp_hdr{"content-length"});
! 281: }
! 282: undef $lines if (length($lines) == 0);
! 283: } else {
! 284: $resp_body = $lines;
! 285: undef $lines;
! 286: }
! 287:
! 288: # check conditions
! 289: if ($resp_line =~ /^(HTTP\/1\.[01]) ([0-9]{3}) .+$/) {
! 290: if ($href->{'HTTP-Protocol'} ne $1) {
! 291: diag(sprintf("\nproto failed: expected '%s', got '%s'", $href->{'HTTP-Protocol'}, $1));
! 292: return -1;
! 293: }
! 294: if ($href->{'HTTP-Status'} ne $2) {
! 295: diag(sprintf("\nstatus failed: expected '%s', got '%s'", $href->{'HTTP-Status'}, $2));
! 296: return -1;
! 297: }
! 298: } else {
! 299: diag(sprintf("\nunexpected resp_line '%s'", $resp_line));
! 300: return -1;
! 301: }
! 302:
! 303: if (defined $href->{'HTTP-Content'}) {
! 304: $resp_body = "" unless defined $resp_body;
! 305: if ($href->{'HTTP-Content'} ne $resp_body) {
! 306: diag(sprintf("\nbody failed: expected '%s', got '%s'", $href->{'HTTP-Content'}, $resp_body));
! 307: return -1;
! 308: }
! 309: }
! 310:
! 311: if (defined $href->{'-HTTP-Content'}) {
! 312: if (defined $resp_body && $resp_body ne '') {
! 313: diag(sprintf("\nbody failed: expected empty body, got '%s'", $resp_body));
! 314: return -1;
! 315: }
! 316: }
! 317:
! 318: foreach (keys %{ $href }) {
! 319: next if $_ eq 'HTTP-Protocol';
! 320: next if $_ eq 'HTTP-Status';
! 321: next if $_ eq 'HTTP-Content';
! 322: next if $_ eq '-HTTP-Content';
! 323:
! 324: (my $k = $_) =~ tr/[A-Z]/[a-z]/;
! 325:
! 326: my $verify_value = 1;
! 327: my $key_inverted = 0;
! 328:
! 329: if (substr($k, 0, 1) eq '+') {
! 330: $k = substr($k, 1);
! 331: $verify_value = 0;
! 332: } elsif (substr($k, 0, 1) eq '-') {
! 333: ## the key should NOT exist
! 334: $k = substr($k, 1);
! 335: $key_inverted = 1;
! 336: $verify_value = 0; ## skip the value check
! 337: }
! 338:
! 339: if ($key_inverted) {
! 340: if (defined $resp_hdr{$k}) {
! 341: diag(sprintf("\nheader '%s' MUST not be set", $k));
! 342: return -1;
! 343: }
! 344: } else {
! 345: if (not defined $resp_hdr{$k}) {
! 346: diag(sprintf("\nrequired header '%s' is missing", $k));
! 347: return -1;
! 348: }
! 349: }
! 350:
! 351: if ($verify_value) {
! 352: if ($href->{$_} =~ /^\/(.+)\/$/) {
! 353: if ($resp_hdr{$k} !~ /$1/) {
! 354: diag(sprintf("\nresponse-header failed: expected '%s', got '%s', regex: %s",
! 355: $href->{$_}, $resp_hdr{$k}, $1));
! 356: return -1;
! 357: }
! 358: } elsif ($href->{$_} ne $resp_hdr{$k}) {
! 359: diag(sprintf("\nresponse-header failed: expected '%s', got '%s'",
! 360: $href->{$_}, $resp_hdr{$k}));
! 361: return -1;
! 362: }
! 363: }
! 364: }
! 365: }
! 366:
! 367: # we should have sucked up everything
! 368: if (defined $lines) {
! 369: diag(sprintf("\nunexpected lines '%s'", $lines));
! 370: return -1;
! 371: }
! 372:
! 373: return 0;
! 374: }
! 375:
! 376: sub spawnfcgi {
! 377: my ($self, $binary, $port) = @_;
! 378: my $child = fork();
! 379: if (not defined $child) {
! 380: diag("\nCouldn't fork");
! 381: return -1;
! 382: }
! 383: if ($child == 0) {
! 384: my $iaddr = inet_aton('localhost') || die "no host: localhost";
! 385: my $proto = getprotobyname('tcp');
! 386: socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
! 387: setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!";
! 388: bind(SOCK, sockaddr_in($port, $iaddr)) || die "bind: $!";
! 389: listen(SOCK, 1024) || die "listen: $!";
! 390: dup2(fileno(SOCK), 0) || die "dup2: $!";
! 391: exec { $binary } ($binary) or die($?);
! 392: } else {
! 393: if (0 != $self->wait_for_port_with_proc($port, $child)) {
! 394: diag(sprintf("\nThe process %i is not up (port %i, %s)", $child, $port, $binary));
! 395: return -1;
! 396: }
! 397: return $child;
! 398: }
! 399: }
! 400:
! 401: sub endspawnfcgi {
! 402: my ($self, $pid) = @_;
! 403: return -1 if (-1 == $pid);
! 404: kill(2, $pid);
! 405: waitpid($pid, 0);
! 406: return 0;
! 407: }
! 408:
! 409: 1;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to LightyTest.pm CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / lighttpd / tests