1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
use strict;
use Test::More;
use Test::Requires { 'CGI::Emulate::PSGI' => 0.06, 'CGI::Compile' => 0.03 };
use Plack::Test;
use HTTP::Request::Common;
use Plack::App::WrapCGI;
use IO::File;
use File::Temp;
plan skip_all => $^O if $^O eq "MSWin32";
{
my $tmp = File::Temp->new(CLEANUP => 1);
print $tmp <<"...";
#!$^X
use CGI;
my \$q = CGI->new;
print \$q->header, "Hello ", \$q->param('name'), " counter=", ++\$COUNTER;
...
close $tmp;
chmod(oct("0700"), $tmp->filename) or die "Cannot chmod";
my $app_exec = Plack::App::WrapCGI->new(script => "$tmp", execute => 1)->to_app;
test_psgi app => $app_exec, client => sub {
my $cb = shift;
my $res = $cb->(GET "http://localhost/?name=foo");
is $res->code, 200;
is $res->content, "Hello foo counter=1";
$res = $cb->(POST "http://localhost/", ['name' => 'bar']);
is $res->code, 200;
is $res->content, "Hello bar counter=1";
};
undef $tmp;
};
{
my $tmp = File::Temp->new(CLEANUP => 1);
print $tmp <<"...";
#!$^X
use CGI;
my \$q = CGI->new;
print \$q->header, "Hello " x 10000;
...
close $tmp;
chmod(oct("0700"), $tmp->filename) or die "Cannot chmod";
my $app_exec = Plack::App::WrapCGI->new(script => "$tmp", execute => 1)->to_app;
test_psgi app => $app_exec, client => sub {
my $cb = shift;
my $res = $cb->(GET "http://localhost/");
is $res->code, 200;
};
undef $tmp;
}
# test that wrapped cgi doesn't wait indefinitely for STDIN
{
my $tmp = File::Temp->new(CLEANUP => 1);
print $tmp <<"...";
#!$^X
print "Content-type: text/plain\\n\\nYou said: ";
local \$/;
print <STDIN>;
...
close $tmp;
chmod(oct("0700"), $tmp->filename) or die "Cannot chmod";
my $app_exec = Plack::App::WrapCGI->new(script => "$tmp", execute => 1)->to_app;
test_psgi app => $app_exec, client => sub {
my $cb = shift;
eval {
# without the fix $res->content seems to be "alarm\n" which still fails
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm(10);
my $res = $cb->(GET "http://localhost/?name=foo");
alarm(0);
is $res->code, 200;
is $res->content, "You said: ";
alarm(10);
$res = $cb->(POST "http://localhost/", Content => "doing things\nthe hard way");
alarm(0);
is $res->code, 200;
is $res->content, "You said: doing things\nthe hard way";
};
if ( $@ ) {
die unless $@ eq "alarm\n"; # propagate unexpected errors
ok 0, "request timed out waiting for STDIN";
}
};
undef $tmp;
};
done_testing;
|
