Annotation of embedaddon/lighttpd/tests/LightyTest.pm, revision 1.1.1.2
1.1 misho 1: package LightyTest;
1.1.1.2 ! misho 2:
1.1 misho 3: use strict;
4: use IO::Socket;
5: use Test::More;
6: use Socket;
7: use Cwd 'abs_path';
8: use POSIX qw(:sys_wait_h dup2);
9: use Errno qw(EADDRINUSE);
10:
1.1.1.2 ! misho 11: sub 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:
! 38: BEGIN {
! 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:
1.1 misho 46: sub mtime {
47: my $file = shift;
48: my @stat = stat $file;
49: return @stat ? $stat[9] : 0;
50: }
1.1.1.2 ! misho 51:
1.1 misho 52: sub 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:
92: sub listening_on {
93: my $self = shift;
94: my $port = shift;
95:
1.1.1.2 ! misho 96: my $remote = IO::Socket::INET->new(
! 97: Proto => "tcp",
! 98: PeerAddr => "127.0.0.1",
! 99: PeerPort => $port) or return 0;
1.1 misho 100:
101: close $remote;
102:
103: return 1;
104: }
105:
106: sub 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:
121: sub wait_for_port_with_proc {
122: my $self = shift;
123: my $port = shift;
124: my $child = shift;
1.1.1.2 ! misho 125: my $timeout = 10*10; # 10 secs (valgrind might take a while), select waits 0.1 s
1.1 misho 126:
127: while (0 == $self->listening_on($port)) {
128: select(undef, undef, undef, 0.1);
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:
145: sub 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') {
1.1.1.2 ! misho 163: @cmdline = (qw(strace -tt -s 4096 -o strace -f -v), @cmdline);
1.1 misho 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') {
1.1.1.2 ! misho 169: @cmdline = (qw(valgrind --tool=memcheck --track-origins=yes --show-reachable=yes --leak-check=yes --log-file=valgrind.%p), @cmdline);
1.1 misho 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:
191: sub 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:
1.1.1.2 ! misho 203: my $remote =
! 204: IO::Socket::INET->new(
! 205: Proto => "tcp",
! 206: PeerAddr => $host,
! 207: PeerPort => $self->{PORT});
1.1 misho 208:
209: if (not defined $remote) {
210: diag("\nconnect failed: $!");
1.1.1.2 ! misho 211: return -1;
1.1 misho 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: } else {
227: diag("\nsending request header to ".$host.":".$self->{PORT}) if $is_debug;
228: foreach(@request) {
229: # pipeline requests
230: chomp;
231: s/\r//g;
232: s/\n/$EOL/g;
233:
234: print $remote $_;
235: diag("<< ".$_."\n") if $is_debug;
236: select(undef, undef, undef, 0.1);
237: print $remote "\015";
238: select(undef, undef, undef, 0.1);
239: print $remote "\012";
240: select(undef, undef, undef, 0.1);
241: print $remote "\015";
242: select(undef, undef, undef, 0.1);
243: print $remote "\012";
244: select(undef, undef, undef, 0.1);
245: }
1.1.1.2 ! misho 246:
1.1 misho 247: }
248: diag("\n... done") if $is_debug;
249:
250: my $lines = "";
251:
252: diag("\nreceiving response") if $is_debug;
253: # read everything
254: while(<$remote>) {
255: $lines .= $_;
256: diag(">> ".$_) if $is_debug;
257: }
258: diag("\n... done") if $is_debug;
1.1.1.2 ! misho 259:
1.1 misho 260: close $remote;
261:
262: my $full_response = $lines;
263:
264: my $href;
265: foreach $href ( @{ $t->{RESPONSE} }) {
266: # first line is always response header
267: my %resp_hdr;
268: my $resp_body;
269: my $resp_line;
270: my $conditions = $_;
271:
272: for (my $ln = 0; defined $lines; $ln++) {
273: (my $line, $lines) = split($EOL, $lines, 2);
274:
275: # header finished
276: last if(!defined $line or length($line) == 0);
277:
278: if ($ln == 0) {
279: # response header
280: $resp_line = $line;
281: } else {
282: # response vars
283:
284: if ($line =~ /^([^:]+):\s*(.+)$/) {
285: (my $h = $1) =~ tr/[A-Z]/[a-z]/;
286:
287: if (defined $resp_hdr{$h}) {
1.1.1.2 ! misho 288: # diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n",
! 289: # $h, $resp_hdr{$h}, $2));
1.1 misho 290: $resp_hdr{$h} .= ', '.$2;
291: } else {
292: $resp_hdr{$h} = $2;
293: }
294: } else {
295: diag(sprintf("\nunexpected line '%s'", $line));
296: return -1;
297: }
298: }
299: }
300:
301: if (not defined($resp_line)) {
302: diag(sprintf("\nempty response"));
303: return -1;
304: }
305:
306: $t->{etag} = $resp_hdr{'etag'};
307: $t->{date} = $resp_hdr{'date'};
308:
309: # check length
310: if (defined $resp_hdr{"content-length"}) {
311: $resp_body = substr($lines, 0, $resp_hdr{"content-length"});
312: if (length($lines) < $resp_hdr{"content-length"}) {
313: $lines = "";
314: } else {
315: $lines = substr($lines, $resp_hdr{"content-length"});
316: }
317: undef $lines if (length($lines) == 0);
318: } else {
319: $resp_body = $lines;
320: undef $lines;
321: }
322:
323: # check conditions
324: if ($resp_line =~ /^(HTTP\/1\.[01]) ([0-9]{3}) .+$/) {
325: if ($href->{'HTTP-Protocol'} ne $1) {
326: diag(sprintf("\nproto failed: expected '%s', got '%s'", $href->{'HTTP-Protocol'}, $1));
327: return -1;
328: }
329: if ($href->{'HTTP-Status'} ne $2) {
330: diag(sprintf("\nstatus failed: expected '%s', got '%s'", $href->{'HTTP-Status'}, $2));
331: return -1;
332: }
333: } else {
334: diag(sprintf("\nunexpected resp_line '%s'", $resp_line));
335: return -1;
336: }
337:
338: if (defined $href->{'HTTP-Content'}) {
339: $resp_body = "" unless defined $resp_body;
340: if ($href->{'HTTP-Content'} ne $resp_body) {
341: diag(sprintf("\nbody failed: expected '%s', got '%s'", $href->{'HTTP-Content'}, $resp_body));
342: return -1;
343: }
344: }
1.1.1.2 ! misho 345:
1.1 misho 346: if (defined $href->{'-HTTP-Content'}) {
347: if (defined $resp_body && $resp_body ne '') {
348: diag(sprintf("\nbody failed: expected empty body, got '%s'", $resp_body));
349: return -1;
350: }
351: }
352:
353: foreach (keys %{ $href }) {
354: next if $_ eq 'HTTP-Protocol';
355: next if $_ eq 'HTTP-Status';
356: next if $_ eq 'HTTP-Content';
357: next if $_ eq '-HTTP-Content';
358:
359: (my $k = $_) =~ tr/[A-Z]/[a-z]/;
360:
361: my $verify_value = 1;
362: my $key_inverted = 0;
363:
364: if (substr($k, 0, 1) eq '+') {
365: $k = substr($k, 1);
366: $verify_value = 0;
367: } elsif (substr($k, 0, 1) eq '-') {
368: ## the key should NOT exist
369: $k = substr($k, 1);
370: $key_inverted = 1;
371: $verify_value = 0; ## skip the value check
1.1.1.2 ! misho 372: }
1.1 misho 373:
374: if ($key_inverted) {
375: if (defined $resp_hdr{$k}) {
376: diag(sprintf("\nheader '%s' MUST not be set", $k));
377: return -1;
378: }
379: } else {
380: if (not defined $resp_hdr{$k}) {
381: diag(sprintf("\nrequired header '%s' is missing", $k));
382: return -1;
383: }
384: }
385:
386: if ($verify_value) {
387: if ($href->{$_} =~ /^\/(.+)\/$/) {
388: if ($resp_hdr{$k} !~ /$1/) {
1.1.1.2 ! misho 389: diag(sprintf(
! 390: "\nresponse-header failed: expected '%s', got '%s', regex: %s",
! 391: $href->{$_}, $resp_hdr{$k}, $1));
1.1 misho 392: return -1;
393: }
394: } elsif ($href->{$_} ne $resp_hdr{$k}) {
1.1.1.2 ! misho 395: diag(sprintf(
! 396: "\nresponse-header failed: expected '%s', got '%s'",
! 397: $href->{$_}, $resp_hdr{$k}));
1.1 misho 398: return -1;
399: }
400: }
401: }
402: }
403:
404: # we should have sucked up everything
405: if (defined $lines) {
406: diag(sprintf("\nunexpected lines '%s'", $lines));
407: return -1;
408: }
409:
410: return 0;
411: }
412:
413: sub spawnfcgi {
414: my ($self, $binary, $port) = @_;
415: my $child = fork();
416: if (not defined $child) {
417: diag("\nCouldn't fork");
418: return -1;
419: }
420: if ($child == 0) {
421: my $iaddr = inet_aton('localhost') || die "no host: localhost";
422: my $proto = getprotobyname('tcp');
423: socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
424: setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!";
425: bind(SOCK, sockaddr_in($port, $iaddr)) || die "bind: $!";
426: listen(SOCK, 1024) || die "listen: $!";
427: dup2(fileno(SOCK), 0) || die "dup2: $!";
428: exec { $binary } ($binary) or die($?);
429: } else {
430: if (0 != $self->wait_for_port_with_proc($port, $child)) {
431: diag(sprintf("\nThe process %i is not up (port %i, %s)", $child, $port, $binary));
432: return -1;
433: }
434: return $child;
435: }
436: }
437:
438: sub endspawnfcgi {
439: my ($self, $pid) = @_;
440: return -1 if (-1 == $pid);
441: kill(2, $pid);
442: waitpid($pid, 0);
443: return 0;
444: }
445:
446: 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