1 # Copyright (C) 2016-2021 all contributors <meta@public-inbox.org>
2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
3 # note: our HTTP server should be standalone and capable of running
4 # generic PSGI/Plack apps.
8 use Time::HiRes qw(gettimeofday tv_interval);
9 use PublicInbox::Spawn qw(which spawn popen_rd);
10 use PublicInbox::TestCommon;
11 require_mods(qw(Plack::Util Plack::Builder HTTP::Date HTTP::Status));
12 use Digest::SHA qw(sha1_hex);
16 use Socket qw(IPPROTO_TCP TCP_NODELAY SOL_SOCKET);
19 my ($tmpdir, $for_destroy) = tmpdir();
20 my $fifo = "$tmpdir/fifo";
21 ok(defined mkfifo($fifo, 0777), 'created FIFO');
22 my $err = "$tmpdir/stderr.log";
23 my $out = "$tmpdir/stdout.log";
24 my $psgi = "./t/httpd-corner.psgi";
25 my $sock = tcp_server() or die;
26 my @zmods = qw(PublicInbox::GzipFilter IO::Uncompress::Gunzip);
28 # Make sure we don't clobber socket options set by systemd or similar
29 # using socket activation:
30 my ($defer_accept_val, $accf_arg, $TCP_DEFER_ACCEPT);
32 $TCP_DEFER_ACCEPT = eval { Socket::TCP_DEFER_ACCEPT() } // 9;
33 setsockopt($sock, IPPROTO_TCP, $TCP_DEFER_ACCEPT, 5) or die;
34 my $x = getsockopt($sock, IPPROTO_TCP, $TCP_DEFER_ACCEPT);
35 defined $x or die "getsockopt: $!";
36 $defer_accept_val = unpack('i', $x);
37 if ($defer_accept_val <= 0) {
38 die "unexpected TCP_DEFER_ACCEPT value: $defer_accept_val";
40 } elsif ($^O eq 'freebsd' && system('kldstat -m accf_data >/dev/null') == 0) {
41 require PublicInbox::Daemon;
42 my $var = PublicInbox::Daemon::SO_ACCEPTFILTER();
43 $accf_arg = pack('a16a240', 'dataready', '');
44 setsockopt($sock, SOL_SOCKET, $var, $accf_arg) or die "setsockopt: $!";
48 my $s = IO::Socket::UNIX->new(
50 Type => Socket::SOCK_STREAM(),
52 ) or BAIL_OUT "bind + listen $_[0]: $!";
57 my $upath = "$tmpdir/s";
58 my $unix = unix_server($upath);
60 my $spawn_httpd = sub {
62 my $cmd = [ '-httpd', @args, "--stdout=$out", "--stderr=$err", $psgi ];
63 $td = start_script($cmd, undef, { 3 => $sock, 4 => $unix });
67 if ('test worker death') {
68 my $conn = conn_for($sock, 'killed worker');
69 $conn->write("GET /pid HTTP/1.1\r\nHost:example.com\r\n\r\n");
71 while (defined(my $line = $conn->getline)) {
72 next unless $line eq "\r\n";
73 chomp($pid = $conn->getline);
76 like($pid, qr/\A[0-9]+\z/, '/pid response');
77 is(kill('KILL', $pid), 1, 'killed worker');
78 is($conn->getline, undef, 'worker died and EOF-ed client');
80 $conn = conn_for($sock, 'respawned worker');
81 $conn->write("GET /pid HTTP/1.0\r\n\r\n");
82 ok($conn->read(my $buf, 8192), 'read response');
83 my ($head, $body) = split(/\r\n\r\n/, $buf);
85 like($body, qr/\A[0-9]+\z/, '/pid response');
86 isnt($body, $pid, 'respawned worker');
90 my $conn = conn_for($sock, 'streaming callback');
91 $conn->write("GET /callback HTTP/1.0\r\n\r\n");
92 ok($conn->read(my $buf, 8192), 'read response');
93 my ($head, $body) = split(/\r\n\r\n/, $buf);
94 is($body, "hello world\n", 'callback body matches expected');
98 my $conn = conn_for($sock, 'getline-die');
99 $conn->write("GET /getline-die HTTP/1.1\r\nHost: example.com\r\n\r\n");
100 ok($conn->read(my $buf, 8192), 'read some response');
101 like($buf, qr!HTTP/1\.1 200\b[^\r]*\r\n!, 'got some sort of header');
102 is($conn->read(my $nil, 8192), 0, 'read EOF');
104 my $after = capture($err);
105 is(scalar(grep(/GETLINE FAIL/, @$after)), 1, 'failure logged');
106 is(scalar(grep(/CLOSE FAIL/, @$after)), 1, 'body->close not called');
110 my $conn = conn_for($sock, 'close-die');
111 $conn->write("GET /close-die HTTP/1.1\r\nHost: example.com\r\n\r\n");
112 ok($conn->read(my $buf, 8192), 'read some response');
113 like($buf, qr!HTTP/1\.1 200\b[^\r]*\r\n!, 'got some sort of header');
114 is($conn->read(my $nil, 8192), 0, 'read EOF');
116 my $after = capture($err);
117 is(scalar(grep(/GETLINE FAIL/, @$after)), 0, 'getline not failed');
118 is(scalar(grep(/CLOSE FAIL/, @$after)), 1, 'body->close not called');
123 my $r = $conn->read(my $buf, 8192);
124 # ECONNRESET and $r==0 are both observed on FreeBSD 11.2
126 ok($!{ECONNRESET}, 'ECONNRESET on read (BSD sometimes)');
128 like($buf, qr!\AHTTP/1\.\d 400 !, 'got 400 response');
130 is($r, 0, 'got EOF (BSD sometimes)');
132 close($conn); # ensure we don't get SIGPIPE later
136 local $SIG{PIPE} = 'IGNORE';
137 my $conn = conn_for($sock, 'excessive header');
138 $conn->write("GET /callback HTTP/1.0\r\n");
139 foreach my $i (1..500000) {
140 last unless $conn->write("X-xxxxxJunk-$i: omg\r\n");
142 ok(!$conn->write("\r\n"), 'broken request');
147 my $conn = conn_for($sock, 'excessive body Content-Length');
148 my $n = (10 * 1024 * 1024) + 1;
149 $conn->write("PUT /sha1 HTTP/1.0\r\nContent-Length: $n\r\n\r\n");
150 my $r = $conn->read(my $buf, 8192);
151 ok($r > 0, 'read response');
152 my ($head, $body) = split(/\r\n\r\n/, $buf);
153 like($head, qr/\b413\b/, 'got 413 response');
157 my $conn = conn_for($sock, 'excessive body chunked');
158 my $n = (10 * 1024 * 1024) + 1;
159 $conn->write("PUT /sha1 HTTP/1.1\r\nTransfer-Encoding: chunked\r\n");
160 $conn->write("\r\n".sprintf("%x\r\n", $n));
161 my $r = $conn->read(my $buf, 8192);
162 ok($r > 0, 'read response');
163 my ($head, $body) = split(/\r\n\r\n/, $buf);
164 like($head, qr/\b413\b/, 'got 413 response');
168 my $conn = conn_for($sock, '1.1 Transfer-Encoding bogus');
169 $conn->write("PUT /sha1 HTTP/1.1\r\nTransfer-Encoding: bogus\r\n\r\n");
170 $conn->read(my $buf, 4096);
171 like($buf, qr!\AHTTP/1\.[0-9] 400 !, 'got 400 response on bogus TE');
174 my $conn = conn_for($sock, '1.1 Content-Length bogus');
175 $conn->write("PUT /sha1 HTTP/1.1\r\nContent-Length: 3.3\r\n\r\n");
176 $conn->read(my $buf, 4096);
177 like($buf, qr!\AHTTP/1\.[0-9] 400 !, 'got 400 response on bad length');
181 my $req = "PUT /sha1 HTTP/1.1\r\nContent-Length: 3\r\n" .
182 "Content-Length: 3\r\n\r\n";
183 # this is stricter than it needs to be. Due to the way
184 # Plack::HTTPParser, PSGI specs, and how hash tables work in common
185 # languages; it's not possible to tell the difference between folded
186 # and intentionally bad commas (e.g. "Content-Length: 3, 3")
188 require Plack::HTTPParser; # XS or pure Perl
189 require Data::Dumper;
190 Plack::HTTPParser::parse_http_request($req, my $env = {});
191 diag Data::Dumper::Dumper($env); # "Content-Length: 3, 3"
193 my $conn = conn_for($sock, '1.1 Content-Length dupe');
195 $conn->read(my $buf, 4096);
196 like($buf, qr!\AHTTP/1\.[0-9] 400 !, 'got 400 response on dupe length');
200 my $conn = conn_for($sock, 'chunk with pipeline');
202 my $payload = 'b'x$n;
203 $conn->write("PUT /sha1 HTTP/1.1\r\nTransfer-Encoding: chunked\r\n");
204 $conn->write("\r\n".sprintf("%x\r\n", $n));
205 $conn->write($payload . "\r\n0\r\n\r\nGET /empty HTTP/1.0\r\n\r\n");
206 $conn->read(my $buf, 4096);
208 $lim++ while ($conn->read($buf, 4096, length($buf)) && $lim < 9);
209 my $exp = sha1_hex($payload);
210 like($buf, qr!\r\n\r\n${exp}HTTP/1\.0 200 OK\r\n!s,
211 'chunk parser can handled pipelined requests');
214 # Unix domain sockets
216 my $u = IO::Socket::UNIX->new(Type => SOCK_STREAM, Peer => $upath);
217 ok($u, 'unix socket connected');
218 $u->write("GET /host-port HTTP/1.0\r\n\r\n");
219 $u->read(my $buf, 4096);
220 like($buf, qr!\r\n\r\n127\.0\.0\.1 0\z!,
221 'set REMOTE_ADDR and REMOTE_PORT for Unix socket');
225 my ($dest, $msg) = @_;
226 my $conn = tcp_connect($dest);
227 ok($conn, "connected for $msg");
228 setsockopt($conn, IPPROTO_TCP, TCP_NODELAY, 1);
233 my $conn = conn_for($sock, 'host-port');
234 $conn->write("GET /host-port HTTP/1.0\r\n\r\n");
235 $conn->read(my $buf, 4096);
236 my ($head, $body) = split(/\r\n\r\n/, $buf);
237 my ($addr, $port) = split(/ /, $body);
238 is($addr, (tcp_host_port($conn))[0], 'host matches addr');
239 is($port, $conn->sockport, 'port matches');
242 # graceful termination
244 my $conn = conn_for($sock, 'graceful termination via slow header');
245 $conn->write("GET /slow-header HTTP/1.0\r\n" .
246 "X-Check-Fifo: $fifo\r\n\r\n");
247 open my $f, '>', $fifo or die "open $fifo: $!\n";
249 ok(print($f "hello\n"), 'wrote something to fifo');
250 is($td->kill, 1, 'started graceful shutdown');
251 ok(print($f "world\n"), 'wrote else to fifo');
252 close $f or die "close fifo: $!\n";
253 $conn->read(my $buf, 8192);
254 my ($head, $body) = split(/\r\n\r\n/, $buf, 2);
255 like($head, qr!\AHTTP/1\.[01] 200 OK!, 'got 200 for slow-header');
256 is($body, "hello\nworld\n", 'read expected body');
258 is($?, 0, 'no error');
259 $spawn_httpd->('-W0');
263 my $conn = conn_for($sock, 'graceful termination via slow-body');
264 $conn->write("GET /slow-body HTTP/1.0\r\n" .
265 "X-Check-Fifo: $fifo\r\n\r\n");
266 open my $f, '>', $fifo or die "open $fifo: $!\n";
269 $conn->sysread($buf, 8192);
270 like($buf, qr!\AHTTP/1\.[01] 200 OK!, 'got 200 for slow-body');
271 like($buf, qr!\r\n\r\n!, 'finished HTTP response header');
273 foreach my $c ('a'..'c') {
275 ok(print($f $c), 'wrote line to fifo');
276 $conn->sysread($buf, 8192);
277 is($buf, $c, 'got trickle for reading');
279 is($td->kill, 1, 'started graceful shutdown');
280 ok(print($f "world\n"), 'wrote else to fifo');
281 close $f or die "close fifo: $!\n";
282 $conn->sysread($buf, 8192);
283 is($buf, "world\n", 'read expected body');
284 is($conn->sysread($buf, 8192), 0, 'got EOF from server');
286 is($?, 0, 'no error');
287 $spawn_httpd->('-W0');
290 sub delay { select(undef, undef, undef, shift || rand(0.02)) }
292 my $str = 'abcdefghijklmnopqrstuvwxyz';
293 my $len = length $str;
294 is($len, 26, 'got the alphabet');
295 my $check_self = sub {
297 vec(my $rbits = '', fileno($conn), 1) = 1;
298 select($rbits, undef, undef, 30) or Carp::confess('timed out');
299 $conn->read(my $buf, 4096);
300 my ($head, $body) = split(/\r\n\r\n/, $buf, 2);
301 like($head, qr/\r\nContent-Length: 40\r\n/s, 'got expected length');
302 is($body, sha1_hex($str), 'read expected body');
306 my $curl = which('curl') or skip('curl(1) missing', 4);
307 my $base = 'http://'.tcp_host_port($sock);
308 my $url = "$base/sha1";
310 pipe($r, $w) or die "pipe: $!";
311 my $cmd = [$curl, qw(--tcp-nodelay -T- -HExpect: -sSN), $url];
312 open my $cout, '+>', undef or die;
313 open my $cerr, '>', undef or die;
314 my $rdr = { 0 => $r, 1 => $cout, 2 => $cerr };
315 my $pid = spawn($cmd, undef, $rdr);
316 close $r or die "close read pipe: $!";
317 foreach my $c ('a'..'z') {
318 print $w $c or die "failed to write to curl: $!";
321 close $w or die "close write pipe: $!";
323 is($?, 0, 'curl exited successfully');
324 is(-s $cerr, 0, 'no errors from curl');
325 seek($cout, 0, SEEK_SET);
326 is(<$cout>, sha1_hex($str), 'read expected body');
328 my $fh = popen_rd([$curl, '-sS', "$base/async-big"]);
332 my $r = sysread($fh, my $buf, 4096) or last;
334 $buf =~ /\A\0+\z/ or $non_zero++;
336 close $fh or die "close curl pipe: $!";
337 is($?, 0, 'curl succesful');
338 is($n, 30 * 1024 * 1024, 'got expected output from curl');
339 is($non_zero, 0, 'read all zeros');
341 require_mods(@zmods, 4);
342 my $buf = xqx([$curl, '-sS', "$base/psgi-return-gzip"]);
343 is($?, 0, 'curl succesful');
344 IO::Uncompress::Gunzip::gunzip(\$buf => \(my $out));
345 is($out, "hello world\n");
346 my $curl_rdr = { 2 => \(my $curl_err = '') };
347 $buf = xqx([$curl, qw(-sSv --compressed),
348 "$base/psgi-return-compressible"], undef, $curl_rdr);
349 is($?, 0, 'curl --compressed successful');
350 is($buf, "goodbye world\n", 'gzipped response as expected');
351 like($curl_err, qr/\bContent-Encoding: gzip\b/,
352 'curl got gzipped response');
356 my $conn = conn_for($sock, 'psgi_return ENOENT');
357 print $conn "GET /psgi-return-enoent HTTP/1.1\r\n\r\n" or die;
359 sysread($conn, $buf, 16384, length($buf)) until $buf =~ /\r\n\r\n/;
360 like($buf, qr!HTTP/1\.[01] 500\b!, 'got 500 error on ENOENT');
364 my $conn = conn_for($sock, '1.1 pipeline together');
365 $conn->write("PUT /sha1 HTTP/1.1\r\nUser-agent: hello\r\n\r\n" .
366 "PUT /sha1 HTTP/1.1\r\n\r\n");
369 until (scalar(@r) >= 2) {
370 my $r = $conn->sysread(my $tmp, 4096);
371 die $! unless defined $r;
372 die "EOF <$buf>" unless $r;
374 @r = ($buf =~ /\r\n\r\n([a-f0-9]{40})/g);
376 is(2, scalar @r, 'got 2 responses');
378 foreach my $hex (@r) {
379 is($hex, sha1_hex(''), "read expected body $i");
385 my $conn = conn_for($sock, 'no TCP_CORK on empty body');
386 $conn->write("GET /empty HTTP/1.1\r\nHost:example.com\r\n\r\n");
388 my $t0 = [ gettimeofday ];
389 until ($buf =~ /\r\n\r\n/s) {
390 $conn->sysread($buf, 4096, length($buf));
392 my $elapsed = tv_interval($t0, [ gettimeofday ]);
393 ok($elapsed < 0.190, 'no 200ms TCP cork delay on empty body');
397 my $conn = conn_for($sock, 'graceful termination during slow request');
398 $conn->write("PUT /sha1 HTTP/1.0\r\nContent-Length: $len\r\n\r\n");
400 # XXX ugh, want a reliable and non-intrusive way to detect
401 # that the server has started buffering our partial request so we
402 # can reliably test graceful termination. Maybe making this and
403 # similar tests dependent on Linux strace is a possibility?
406 is($td->kill, 1, 'start graceful shutdown');
408 foreach my $c ('a'..'z') {
409 $n += $conn->write($c);
411 ok(kill(0, $td->{pid}), 'graceful shutdown did not kill httpd');
412 is($n, $len, 'wrote alphabet');
413 $check_self->($conn);
415 is($?, 0, 'no error');
416 $spawn_httpd->('-W0');
419 # various DoS attacks against the chunk parser:
421 local $SIG{PIPE} = 'IGNORE';
422 my $conn = conn_for($sock, '1.1 chunk header excessive');
423 $conn->write("PUT /sha1 HTTP/1.1\r\nTransfer-Encoding:chunked\r\n\r\n");
426 while ($w = $conn->write('ffffffff')) {
429 ok($!, 'got error set in $!');
430 is($w, undef, 'write error happened');
431 ok($n > 0, 'was able to write');
433 $conn = conn_for($sock, '1.1 chunk trailer excessive');
434 $conn->write("PUT /sha1 HTTP/1.1\r\nTransfer-Encoding:chunked\r\n\r\n");
435 is($conn->syswrite("1\r\na"), 4, 'wrote first header + chunk');
438 while ($w = $conn->write("\r")) {
441 ok($!, 'got error set in $!');
442 ok($n > 0, 'wrote part of chunk end (\r)');
447 my $conn = conn_for($sock, '1.1 chunked close trickle');
448 $conn->write("PUT /sha1 HTTP/1.1\r\nConnection:close\r\n");
449 $conn->write("Transfer-encoding: chunked\r\n\r\n");
450 foreach my $x ('a'..'z') {
474 $check_self->($conn);
478 my $conn = conn_for($sock, '1.1 chunked close');
479 $conn->write("PUT /sha1 HTTP/1.1\r\nConnection:close\r\n");
480 my $xlen = sprintf('%x', $len);
481 $conn->write("Transfer-Encoding: chunked\r\n\r\n$xlen\r\n" .
482 "$str\r\n0\r\n\r\n");
483 $check_self->($conn);
487 my $conn = conn_for($sock, 'chunked body + pipeline');
488 $conn->write("PUT /sha1 HTTP/1.1\r\n" .
489 "Transfer-Encoding: chunked\r\n");
491 $conn->write("\r\n1\r\n");
495 $conn->write("\r\n0\r\n\r\nPUT /sha1 HTTP/1.1\r\n");
499 until ($buf =~ /\r\n\r\n[a-f0-9]{40}\z/) {
500 $conn->sysread(my $tmp, 4096);
503 my ($head, $body) = split(/\r\n\r\n/, $buf, 2);
504 like($head, qr/\r\nContent-Length: 40\r\n/s, 'got expected length');
505 is($body, sha1_hex('a'), 'read expected body');
507 $conn->write("Connection: close\r\n");
508 $conn->write("Content-Length: $len\r\n\r\n$str");
509 $check_self->($conn);
513 my $conn = conn_for($sock, 'trickle header, one-shot body + pipeline');
514 $conn->write("PUT /sha1 HTTP/1.0\r\n" .
515 "Connection: keep-alive\r\n");
517 $conn->write("Content-Length: $len\r\n\r\n${str}PUT");
519 until ($buf =~ /\r\n\r\n[a-f0-9]{40}\z/) {
520 $conn->sysread(my $tmp, 4096);
523 my ($head, $body) = split(/\r\n\r\n/, $buf, 2);
524 like($head, qr/\r\nContent-Length: 40\r\n/s, 'got expected length');
525 is($body, sha1_hex($str), 'read expected body');
527 $conn->write(" /sha1 HTTP/1.0\r\nContent-Length: $len\r\n\r\n$str");
528 $check_self->($conn);
532 my $conn = conn_for($sock, 'trickle body');
533 $conn->write("PUT /sha1 HTTP/1.0\r\n");
534 $conn->write("Content-Length: $len\r\n\r\n");
535 my $beg = substr($str, 0, 10);
536 my $end = substr($str, 10);
537 is($beg . $end, $str, 'substr setup correct');
542 $check_self->($conn);
546 my $conn = conn_for($sock, 'one-shot write');
547 $conn->write("PUT /sha1 HTTP/1.0\r\n" .
548 "Content-Length: $len\r\n\r\n$str");
549 $check_self->($conn);
553 my $conn = conn_for($sock, 'trickle header, one-shot body');
554 $conn->write("PUT /sha1 HTTP/1.0\r\n");
556 $conn->write("Content-Length: $len\r\n\r\n$str");
557 $check_self->($conn);
561 my $conn = conn_for($sock, '1.1 Connection: close');
562 $conn->write("PUT /sha1 HTTP/1.1\r\nConnection:close\r\n");
564 $conn->write("Content-Length: $len\r\n\r\n$str");
565 $check_self->($conn);
569 my $conn = conn_for($sock, '1.1 pipeline start');
570 $conn->write("PUT /sha1 HTTP/1.1\r\n\r\nPUT");
572 until ($buf =~ /\r\n\r\n[a-f0-9]{40}\z/) {
573 $conn->sysread(my $tmp, 4096);
576 my ($head, $body) = split(/\r\n\r\n/, $buf, 2);
577 like($head, qr/\r\nContent-Length: 40\r\n/s, 'got expected length');
578 is($body, sha1_hex(''), 'read expected body');
581 $conn->write(" /sha1 HTTP/1.1\r\n\r\n");
583 until ($buf =~ /\r\n\r\n[a-f0-9]{40}\z/) {
584 $conn->sysread(my $tmp, 4096);
587 ($head, $body) = split(/\r\n\r\n/, $buf, 2);
588 like($head, qr/\r\nContent-Length: 40\r\n/s, 'got expected length');
589 is($body, sha1_hex(''), 'read expected body #2');
593 skip 'TCP_DEFER_ACCEPT is Linux-only', 1 if $^O ne 'linux';
594 my $var = $TCP_DEFER_ACCEPT;
595 defined(my $x = getsockopt($sock, IPPROTO_TCP, $var)) or die;
596 is(unpack('i', $x), $defer_accept_val,
597 'TCP_DEFER_ACCEPT unchanged if previously set');
600 skip 'SO_ACCEPTFILTER is FreeBSD-only', 1 if $^O ne 'freebsd';
601 skip 'accf_data not loaded: kldload accf_data' if !defined $accf_arg;
602 my $var = PublicInbox::Daemon::SO_ACCEPTFILTER();
603 defined(my $x = getsockopt($sock, SOL_SOCKET, $var)) or die;
604 is($x, $accf_arg, 'SO_ACCEPTFILTER unchanged if previously set');
608 skip 'only testing lsof(8) output on Linux', 1 if $^O ne 'linux';
609 my $lsof = which('lsof') or skip 'no lsof in PATH', 1;
611 my $rdr = { 2 => \(my $null_err), 0 => \$null_in };
612 my @lsof = xqx([$lsof, '-p', $td->{pid}], undef, $rdr);
613 is_deeply([grep(/\bdeleted\b/, @lsof)], [], 'no lingering deleted inputs');
615 # filter out pipes inherited from the parent
616 my @this = xqx([$lsof, '-p', $$], undef, $rdr);
618 my $extract_inodes = sub {
620 my @f = split(' ', $_);
622 $bad = $_ if $inode !~ /\A[0-9]+\z/;
624 } grep (/\bpipe\b/, @_);
626 my %child = $extract_inodes->(@lsof);
627 my %parent = $extract_inodes->(@this);
628 skip("inode not in expected format: $bad", 1) if defined($bad);
629 delete @child{(keys %parent)};
630 is_deeply([], [keys %child], 'no extra pipes with -W0');
633 # ensure compatibility with other PSGI servers
635 require_mods(@zmods, qw(Plack::Test HTTP::Request::Common), 3);
636 use_ok 'HTTP::Request::Common';
637 use_ok 'Plack::Test';
639 open my $olderr, '>&', \*STDERR or die "dup stderr: $!";
640 open my $tmperr, '+>', undef or die;
641 open STDERR, '>&', $tmperr or die;
642 STDERR->autoflush(1);
643 my $app = require $psgi;
644 test_psgi($app, sub {
646 my $req = GET('http://example.com/psgi-return-gzip');
647 my $res = $cb->($req);
648 my $buf = $res->content;
649 IO::Uncompress::Gunzip::gunzip(\$buf => \(my $out));
650 is($out, "hello world\n", 'got expected output');
652 $req = GET('http://example.com/psgi-return-enoent');
654 is($res->code, 500, 'got error on ENOENT');
655 seek($tmperr, 0, SEEK_SET) or die;
656 my $errbuf = do { local $/; <$tmperr> };
657 like($errbuf, qr/this-better-not-exist/,
658 'error logged about missing command');
660 open STDERR, '>&', $olderr or die "restore stderr: $!";
667 open my $fh, '+<', $f or die "failed to open $f: $!\n";
670 truncate($fh, 0) or die "truncate failed on $f: $!\n";