1: package LightyTest;
2:
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:
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:
46: sub mtime {
47: my $file = shift;
48: my @stat = stat $file;
49: return @stat ? $stat[9] : 0;
50: }
51:
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:
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:
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;
125: my $timeout = 10*10; # 10 secs (valgrind might take a while), select waits 0.1 s
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') {
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:
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:
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: } 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: }
246:
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;
259:
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}) {
288: # diag(sprintf("\nheader '%s' is duplicated: '%s' and '%s'\n",
289: # $h, $resp_hdr{$h}, $2));
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: }
345:
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
372: }
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/) {
389: diag(sprintf(
390: "\nresponse-header failed: expected '%s', got '%s', regex: %s",
391: $href->{$_}, $resp_hdr{$k}, $1));
392: return -1;
393: }
394: } elsif ($href->{$_} ne $resp_hdr{$k}) {
395: diag(sprintf(
396: "\nresponse-header failed: expected '%s', got '%s'",
397: $href->{$_}, $resp_hdr{$k}));
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