![[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|
Return to LightyTest.pm CVS log | Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / lighttpd / tests |
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;