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