line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Plack::Test::Suite; |
2
|
40
|
|
|
40
|
|
2202058
|
use strict; |
|
40
|
|
|
|
|
239
|
|
|
40
|
|
|
|
|
960
|
|
3
|
40
|
|
|
40
|
|
161
|
use warnings; |
|
40
|
|
|
|
|
42
|
|
|
40
|
|
|
|
|
759
|
|
4
|
40
|
|
|
40
|
|
464
|
use Digest::MD5; |
|
40
|
|
|
|
|
78
|
|
|
40
|
|
|
|
|
1183
|
|
5
|
40
|
|
|
40
|
|
16591
|
use File::ShareDir; |
|
40
|
|
|
|
|
959959
|
|
|
40
|
|
|
|
|
1491
|
|
6
|
40
|
|
|
40
|
|
16446
|
use HTTP::Request; |
|
40
|
|
|
|
|
578582
|
|
|
40
|
|
|
|
|
1389
|
|
7
|
40
|
|
|
40
|
|
15373
|
use HTTP::Request::Common; |
|
40
|
|
|
|
|
75041
|
|
|
40
|
|
|
|
|
2167
|
|
8
|
40
|
|
|
40
|
|
241
|
use Test::More; |
|
40
|
|
|
|
|
42
|
|
|
40
|
|
|
|
|
202
|
|
9
|
40
|
|
|
40
|
|
22898
|
use Test::TCP; |
|
40
|
|
|
|
|
2479114
|
|
|
40
|
|
|
|
|
2274
|
|
10
|
40
|
|
|
40
|
|
14961
|
use Plack::Loader; |
|
40
|
|
|
|
|
80
|
|
|
40
|
|
|
|
|
962
|
|
11
|
40
|
|
|
40
|
|
14231
|
use Plack::Middleware::Lint; |
|
40
|
|
|
|
|
81
|
|
|
40
|
|
|
|
|
1119
|
|
12
|
40
|
|
|
40
|
|
200
|
use Plack::Util; |
|
40
|
|
|
|
|
117
|
|
|
40
|
|
|
|
|
597
|
|
13
|
40
|
|
|
40
|
|
15077
|
use Plack::Request; |
|
40
|
|
|
|
|
82
|
|
|
40
|
|
|
|
|
1082
|
|
14
|
40
|
|
|
40
|
|
237
|
use Try::Tiny; |
|
40
|
|
|
|
|
41
|
|
|
40
|
|
|
|
|
1837
|
|
15
|
40
|
|
|
40
|
|
12913
|
use Plack::LWPish; |
|
40
|
|
|
|
|
81
|
|
|
40
|
|
|
|
|
176487
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
my $share_dir = try { File::ShareDir::dist_dir('Plack') } || 'share'; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
$ENV{PLACK_TEST_SCRIPT_NAME} = ''; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# 0: test name |
22
|
|
|
|
|
|
|
# 1: request generator coderef. |
23
|
|
|
|
|
|
|
# 2: request handler |
24
|
|
|
|
|
|
|
# 3: test case for response |
25
|
|
|
|
|
|
|
our @TEST = ( |
26
|
|
|
|
|
|
|
[ |
27
|
|
|
|
|
|
|
'SCRIPT_NAME', |
28
|
|
|
|
|
|
|
sub { |
29
|
|
|
|
|
|
|
my $cb = shift; |
30
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/"); |
31
|
|
|
|
|
|
|
is $res->content, "script_name=$ENV{PLACK_TEST_SCRIPT_NAME}"; |
32
|
|
|
|
|
|
|
}, |
33
|
|
|
|
|
|
|
sub { |
34
|
|
|
|
|
|
|
my $env = shift; |
35
|
|
|
|
|
|
|
return [ 200, ["Content-Type", "text/plain"], [ "script_name=$env->{SCRIPT_NAME}" ] ]; |
36
|
|
|
|
|
|
|
}, |
37
|
|
|
|
|
|
|
], |
38
|
|
|
|
|
|
|
[ |
39
|
|
|
|
|
|
|
'GET', |
40
|
|
|
|
|
|
|
sub { |
41
|
|
|
|
|
|
|
my $cb = shift; |
42
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa"); |
43
|
|
|
|
|
|
|
is $res->code, 200; |
44
|
|
|
|
|
|
|
is $res->message, 'OK'; |
45
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
46
|
|
|
|
|
|
|
is $res->content, 'Hello, name=miyagawa'; |
47
|
|
|
|
|
|
|
}, |
48
|
|
|
|
|
|
|
sub { |
49
|
|
|
|
|
|
|
my $env = shift; |
50
|
|
|
|
|
|
|
return [ |
51
|
|
|
|
|
|
|
200, |
52
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
53
|
|
|
|
|
|
|
[ 'Hello, ' . $env->{QUERY_STRING} ], |
54
|
|
|
|
|
|
|
]; |
55
|
|
|
|
|
|
|
}, |
56
|
|
|
|
|
|
|
], |
57
|
|
|
|
|
|
|
[ |
58
|
|
|
|
|
|
|
'POST', |
59
|
|
|
|
|
|
|
sub { |
60
|
|
|
|
|
|
|
my $cb = shift; |
61
|
|
|
|
|
|
|
my $res = $cb->(POST "http://127.0.0.1/", [name => 'tatsuhiko']); |
62
|
|
|
|
|
|
|
is $res->code, 200; |
63
|
|
|
|
|
|
|
is $res->message, 'OK'; |
64
|
|
|
|
|
|
|
is $res->header('Client-Content-Length'), 14; |
65
|
|
|
|
|
|
|
is $res->header('Client-Content-Type'), 'application/x-www-form-urlencoded'; |
66
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
67
|
|
|
|
|
|
|
is $res->content, 'Hello, name=tatsuhiko'; |
68
|
|
|
|
|
|
|
}, |
69
|
|
|
|
|
|
|
sub { |
70
|
|
|
|
|
|
|
my $env = shift; |
71
|
|
|
|
|
|
|
my $body; |
72
|
|
|
|
|
|
|
$env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH}); |
73
|
|
|
|
|
|
|
return [ |
74
|
|
|
|
|
|
|
200, |
75
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', |
76
|
|
|
|
|
|
|
'Client-Content-Length' => $env->{CONTENT_LENGTH}, |
77
|
|
|
|
|
|
|
'Client-Content-Type' => $env->{CONTENT_TYPE}, |
78
|
|
|
|
|
|
|
], |
79
|
|
|
|
|
|
|
[ 'Hello, ' . $body ], |
80
|
|
|
|
|
|
|
]; |
81
|
|
|
|
|
|
|
}, |
82
|
|
|
|
|
|
|
], |
83
|
|
|
|
|
|
|
[ |
84
|
|
|
|
|
|
|
'big POST', |
85
|
|
|
|
|
|
|
sub { |
86
|
|
|
|
|
|
|
my $cb = shift; |
87
|
|
|
|
|
|
|
my $chunk = "abcdefgh" x 12000; |
88
|
|
|
|
|
|
|
my $req = HTTP::Request->new(POST => "http://127.0.0.1/"); |
89
|
|
|
|
|
|
|
$req->content_length(length $chunk); |
90
|
|
|
|
|
|
|
$req->content_type('application/octet-stream'); |
91
|
|
|
|
|
|
|
$req->content($chunk); |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
my $res = $cb->($req); |
94
|
|
|
|
|
|
|
is $res->code, 200; |
95
|
|
|
|
|
|
|
is $res->message, 'OK'; |
96
|
|
|
|
|
|
|
is $res->header('Client-Content-Length'), length $chunk; |
97
|
|
|
|
|
|
|
is length $res->content, length $chunk; |
98
|
|
|
|
|
|
|
is Digest::MD5::md5_hex($res->content), Digest::MD5::md5_hex($chunk); |
99
|
|
|
|
|
|
|
}, |
100
|
|
|
|
|
|
|
sub { |
101
|
|
|
|
|
|
|
my $env = shift; |
102
|
|
|
|
|
|
|
my $len = $env->{CONTENT_LENGTH}; |
103
|
|
|
|
|
|
|
my $body = ''; |
104
|
|
|
|
|
|
|
my $spin; |
105
|
|
|
|
|
|
|
while ($len > 0) { |
106
|
|
|
|
|
|
|
my $rc = $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH}, length $body); |
107
|
|
|
|
|
|
|
$len -= $rc; |
108
|
|
|
|
|
|
|
last if $spin++ > 2000; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
return [ |
111
|
|
|
|
|
|
|
200, |
112
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', |
113
|
|
|
|
|
|
|
'Client-Content-Length' => $env->{CONTENT_LENGTH}, |
114
|
|
|
|
|
|
|
'Client-Content-Type' => $env->{CONTENT_TYPE}, |
115
|
|
|
|
|
|
|
], |
116
|
|
|
|
|
|
|
[ $body ], |
117
|
|
|
|
|
|
|
]; |
118
|
|
|
|
|
|
|
}, |
119
|
|
|
|
|
|
|
], |
120
|
|
|
|
|
|
|
[ |
121
|
|
|
|
|
|
|
'psgi.url_scheme', |
122
|
|
|
|
|
|
|
sub { |
123
|
|
|
|
|
|
|
my $cb = shift; |
124
|
|
|
|
|
|
|
my $res = $cb->(POST "http://127.0.0.1/"); |
125
|
|
|
|
|
|
|
is $res->code, 200; |
126
|
|
|
|
|
|
|
is $res->message, 'OK'; |
127
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
128
|
|
|
|
|
|
|
is $res->content, 'http'; |
129
|
|
|
|
|
|
|
}, |
130
|
|
|
|
|
|
|
sub { |
131
|
|
|
|
|
|
|
my $env = $_[0]; |
132
|
|
|
|
|
|
|
return [ |
133
|
|
|
|
|
|
|
200, |
134
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
135
|
|
|
|
|
|
|
[ $env->{'psgi.url_scheme'} ], |
136
|
|
|
|
|
|
|
]; |
137
|
|
|
|
|
|
|
}, |
138
|
|
|
|
|
|
|
], |
139
|
|
|
|
|
|
|
[ |
140
|
|
|
|
|
|
|
'return glob', |
141
|
|
|
|
|
|
|
sub { |
142
|
|
|
|
|
|
|
my $cb = shift; |
143
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/"); |
144
|
|
|
|
|
|
|
is $res->code, 200; |
145
|
|
|
|
|
|
|
is $res->message, 'OK'; |
146
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
147
|
|
|
|
|
|
|
like $res->content, qr/^package /; |
148
|
|
|
|
|
|
|
like $res->content, qr/END_MARK_FOR_TESTING$/; |
149
|
|
|
|
|
|
|
}, |
150
|
|
|
|
|
|
|
sub { |
151
|
|
|
|
|
|
|
my $env = shift; |
152
|
|
|
|
|
|
|
open my $fh, '<', __FILE__ or die $!; |
153
|
|
|
|
|
|
|
return [ |
154
|
|
|
|
|
|
|
200, |
155
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
156
|
|
|
|
|
|
|
$fh, |
157
|
|
|
|
|
|
|
]; |
158
|
|
|
|
|
|
|
}, |
159
|
|
|
|
|
|
|
], |
160
|
|
|
|
|
|
|
[ |
161
|
|
|
|
|
|
|
'filehandle', |
162
|
|
|
|
|
|
|
sub { |
163
|
|
|
|
|
|
|
my $cb = shift; |
164
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo.jpg"); |
165
|
|
|
|
|
|
|
is $res->code, 200; |
166
|
|
|
|
|
|
|
is $res->message, 'OK'; |
167
|
|
|
|
|
|
|
is $res->header('content_type'), 'image/jpeg'; |
168
|
|
|
|
|
|
|
is length $res->content, 2898; |
169
|
|
|
|
|
|
|
}, |
170
|
|
|
|
|
|
|
sub { |
171
|
|
|
|
|
|
|
my $env = shift; |
172
|
|
|
|
|
|
|
open my $fh, '<', "$share_dir/face.jpg"; |
173
|
|
|
|
|
|
|
return [ |
174
|
|
|
|
|
|
|
200, |
175
|
|
|
|
|
|
|
[ 'Content-Type' => 'image/jpeg', 'Content-Length' => -s $fh ], |
176
|
|
|
|
|
|
|
$fh |
177
|
|
|
|
|
|
|
]; |
178
|
|
|
|
|
|
|
}, |
179
|
|
|
|
|
|
|
], |
180
|
|
|
|
|
|
|
[ |
181
|
|
|
|
|
|
|
'bigger file', |
182
|
|
|
|
|
|
|
sub { |
183
|
|
|
|
|
|
|
my $cb = shift; |
184
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/baybridge.jpg"); |
185
|
|
|
|
|
|
|
is $res->code, 200; |
186
|
|
|
|
|
|
|
is $res->message, 'OK'; |
187
|
|
|
|
|
|
|
is $res->header('content_type'), 'image/jpeg'; |
188
|
|
|
|
|
|
|
is length $res->content, 14750; |
189
|
|
|
|
|
|
|
is Digest::MD5::md5_hex($res->content), '70546a79c7abb9c497ca91730a0686e4'; |
190
|
|
|
|
|
|
|
}, |
191
|
|
|
|
|
|
|
sub { |
192
|
|
|
|
|
|
|
my $env = shift; |
193
|
|
|
|
|
|
|
open my $fh, '<', "$share_dir/baybridge.jpg"; |
194
|
|
|
|
|
|
|
binmode $fh; |
195
|
|
|
|
|
|
|
return [ |
196
|
|
|
|
|
|
|
200, |
197
|
|
|
|
|
|
|
[ 'Content-Type' => 'image/jpeg', 'Content-Length' => -s $fh ], |
198
|
|
|
|
|
|
|
$fh |
199
|
|
|
|
|
|
|
]; |
200
|
|
|
|
|
|
|
}, |
201
|
|
|
|
|
|
|
], |
202
|
|
|
|
|
|
|
[ |
203
|
|
|
|
|
|
|
'handle HTTP-Header', |
204
|
|
|
|
|
|
|
sub { |
205
|
|
|
|
|
|
|
my $cb = shift; |
206
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan", Foo => "Bar"); |
207
|
|
|
|
|
|
|
is $res->code, 200; |
208
|
|
|
|
|
|
|
is $res->message, 'OK'; |
209
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
210
|
|
|
|
|
|
|
is $res->content, 'Bar'; |
211
|
|
|
|
|
|
|
}, |
212
|
|
|
|
|
|
|
sub { |
213
|
|
|
|
|
|
|
my $env = shift; |
214
|
|
|
|
|
|
|
return [ |
215
|
|
|
|
|
|
|
200, |
216
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
217
|
|
|
|
|
|
|
[$env->{HTTP_FOO}], |
218
|
|
|
|
|
|
|
]; |
219
|
|
|
|
|
|
|
}, |
220
|
|
|
|
|
|
|
], |
221
|
|
|
|
|
|
|
[ |
222
|
|
|
|
|
|
|
'handle HTTP-Cookie', |
223
|
|
|
|
|
|
|
sub { |
224
|
|
|
|
|
|
|
my $cb = shift; |
225
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan", Cookie => "foo"); |
226
|
|
|
|
|
|
|
is $res->code, 200; |
227
|
|
|
|
|
|
|
is $res->message, 'OK'; |
228
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
229
|
|
|
|
|
|
|
is $res->content, 'foo'; |
230
|
|
|
|
|
|
|
}, |
231
|
|
|
|
|
|
|
sub { |
232
|
|
|
|
|
|
|
my $env = shift; |
233
|
|
|
|
|
|
|
return [ |
234
|
|
|
|
|
|
|
200, |
235
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
236
|
|
|
|
|
|
|
[$env->{HTTP_COOKIE}], |
237
|
|
|
|
|
|
|
]; |
238
|
|
|
|
|
|
|
}, |
239
|
|
|
|
|
|
|
], |
240
|
|
|
|
|
|
|
[ |
241
|
|
|
|
|
|
|
'validate env', |
242
|
|
|
|
|
|
|
sub { |
243
|
|
|
|
|
|
|
my $cb = shift; |
244
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan"); |
245
|
|
|
|
|
|
|
is $res->code, 200; |
246
|
|
|
|
|
|
|
is $res->message, 'OK'; |
247
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
248
|
|
|
|
|
|
|
is $res->content, join("\n", |
249
|
|
|
|
|
|
|
'REQUEST_METHOD:GET', |
250
|
|
|
|
|
|
|
"SCRIPT_NAME:$ENV{PLACK_TEST_SCRIPT_NAME}", |
251
|
|
|
|
|
|
|
'PATH_INFO:/foo/', |
252
|
|
|
|
|
|
|
'QUERY_STRING:dankogai=kogaidan', |
253
|
|
|
|
|
|
|
'SERVER_NAME:127.0.0.1', |
254
|
|
|
|
|
|
|
"SERVER_PORT:" . $res->request->uri->port, |
255
|
|
|
|
|
|
|
)."\n"; |
256
|
|
|
|
|
|
|
}, |
257
|
|
|
|
|
|
|
sub { |
258
|
|
|
|
|
|
|
my $env = shift; |
259
|
|
|
|
|
|
|
my $body; |
260
|
|
|
|
|
|
|
$body .= $_ . ':' . $env->{$_} . "\n" for qw/REQUEST_METHOD SCRIPT_NAME PATH_INFO QUERY_STRING SERVER_NAME SERVER_PORT/; |
261
|
|
|
|
|
|
|
return [ |
262
|
|
|
|
|
|
|
200, |
263
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
264
|
|
|
|
|
|
|
[$body], |
265
|
|
|
|
|
|
|
]; |
266
|
|
|
|
|
|
|
}, |
267
|
|
|
|
|
|
|
], |
268
|
|
|
|
|
|
|
[ |
269
|
|
|
|
|
|
|
'% encoding in PATH_INFO', |
270
|
|
|
|
|
|
|
sub { |
271
|
|
|
|
|
|
|
my $cb = shift; |
272
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/bar%2cbaz"); |
273
|
|
|
|
|
|
|
is $res->content, "/foo/bar,baz", "PATH_INFO should be decoded per RFC 3875"; |
274
|
|
|
|
|
|
|
}, |
275
|
|
|
|
|
|
|
sub { |
276
|
|
|
|
|
|
|
my $env = shift; |
277
|
|
|
|
|
|
|
return [ |
278
|
|
|
|
|
|
|
200, |
279
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
280
|
|
|
|
|
|
|
[ $env->{PATH_INFO} ], |
281
|
|
|
|
|
|
|
]; |
282
|
|
|
|
|
|
|
}, |
283
|
|
|
|
|
|
|
], |
284
|
|
|
|
|
|
|
[ |
285
|
|
|
|
|
|
|
'% double encoding in PATH_INFO', |
286
|
|
|
|
|
|
|
sub { |
287
|
|
|
|
|
|
|
my $cb = shift; |
288
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/bar%252cbaz"); |
289
|
|
|
|
|
|
|
is $res->content, "/foo/bar%2cbaz", "PATH_INFO should be decoded only once, per RFC 3875"; |
290
|
|
|
|
|
|
|
}, |
291
|
|
|
|
|
|
|
sub { |
292
|
|
|
|
|
|
|
my $env = shift; |
293
|
|
|
|
|
|
|
return [ |
294
|
|
|
|
|
|
|
200, |
295
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
296
|
|
|
|
|
|
|
[ $env->{PATH_INFO} ], |
297
|
|
|
|
|
|
|
]; |
298
|
|
|
|
|
|
|
}, |
299
|
|
|
|
|
|
|
], |
300
|
|
|
|
|
|
|
[ |
301
|
|
|
|
|
|
|
'% encoding in PATH_INFO (outside of URI characters)', |
302
|
|
|
|
|
|
|
sub { |
303
|
|
|
|
|
|
|
my $cb = shift; |
304
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo%E3%81%82"); |
305
|
|
|
|
|
|
|
is $res->content, "/foo\x{e3}\x{81}\x{82}"; |
306
|
|
|
|
|
|
|
}, |
307
|
|
|
|
|
|
|
sub { |
308
|
|
|
|
|
|
|
my $env = shift; |
309
|
|
|
|
|
|
|
return [ |
310
|
|
|
|
|
|
|
200, |
311
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
312
|
|
|
|
|
|
|
[ $env->{PATH_INFO} ], |
313
|
|
|
|
|
|
|
]; |
314
|
|
|
|
|
|
|
}, |
315
|
|
|
|
|
|
|
], |
316
|
|
|
|
|
|
|
[ |
317
|
|
|
|
|
|
|
'SERVER_PROTOCOL is required', |
318
|
|
|
|
|
|
|
sub { |
319
|
|
|
|
|
|
|
my $cb = shift; |
320
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan"); |
321
|
|
|
|
|
|
|
is $res->code, 200; |
322
|
|
|
|
|
|
|
is $res->message, 'OK'; |
323
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
324
|
|
|
|
|
|
|
like $res->content, qr{^HTTP/1\.[01]$}; |
325
|
|
|
|
|
|
|
}, |
326
|
|
|
|
|
|
|
sub { |
327
|
|
|
|
|
|
|
my $env = shift; |
328
|
|
|
|
|
|
|
return [ |
329
|
|
|
|
|
|
|
200, |
330
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
331
|
|
|
|
|
|
|
[$env->{SERVER_PROTOCOL}], |
332
|
|
|
|
|
|
|
]; |
333
|
|
|
|
|
|
|
}, |
334
|
|
|
|
|
|
|
], |
335
|
|
|
|
|
|
|
[ |
336
|
|
|
|
|
|
|
'SCRIPT_NAME should not be undef', |
337
|
|
|
|
|
|
|
sub { |
338
|
|
|
|
|
|
|
my $cb = shift; |
339
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan"); |
340
|
|
|
|
|
|
|
is $res->content, 1; |
341
|
|
|
|
|
|
|
}, |
342
|
|
|
|
|
|
|
sub { |
343
|
|
|
|
|
|
|
my $env = shift; |
344
|
|
|
|
|
|
|
my $cont = defined $env->{'SCRIPT_NAME'}; |
345
|
|
|
|
|
|
|
return [ |
346
|
|
|
|
|
|
|
200, |
347
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
348
|
|
|
|
|
|
|
[$cont], |
349
|
|
|
|
|
|
|
]; |
350
|
|
|
|
|
|
|
}, |
351
|
|
|
|
|
|
|
], |
352
|
|
|
|
|
|
|
[ |
353
|
|
|
|
|
|
|
'call close after read IO::Handle-like', |
354
|
|
|
|
|
|
|
sub { |
355
|
|
|
|
|
|
|
my $cb = shift; |
356
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/call_close"); |
357
|
|
|
|
|
|
|
is($res->content, '1234'); |
358
|
|
|
|
|
|
|
}, |
359
|
|
|
|
|
|
|
sub { |
360
|
|
|
|
|
|
|
my $env = shift; |
361
|
|
|
|
|
|
|
{ |
362
|
|
|
|
|
|
|
our $closed = -1; |
363
|
2
|
|
|
2
|
|
10
|
sub CalledClose::new { $closed = 0; my $i=0; bless \$i, 'CalledClose' } |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
17
|
|
364
|
|
|
|
|
|
|
sub CalledClose::getline { |
365
|
10
|
|
|
10
|
|
29
|
my $self = shift; |
366
|
10
|
100
|
|
|
|
52
|
return $$self++ < 4 ? $$self : undef; |
367
|
|
|
|
|
|
|
} |
368
|
2
|
50
|
|
2
|
|
31
|
sub CalledClose::close { ::ok(1, 'closed') if defined &::ok } |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
return [ |
371
|
|
|
|
|
|
|
200, |
372
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
373
|
|
|
|
|
|
|
CalledClose->new(), |
374
|
|
|
|
|
|
|
]; |
375
|
|
|
|
|
|
|
}, |
376
|
|
|
|
|
|
|
], |
377
|
|
|
|
|
|
|
[ |
378
|
|
|
|
|
|
|
'has errors', |
379
|
|
|
|
|
|
|
sub { |
380
|
|
|
|
|
|
|
my $cb = shift; |
381
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/has_errors"); |
382
|
|
|
|
|
|
|
is $res->content, 1; |
383
|
|
|
|
|
|
|
}, |
384
|
|
|
|
|
|
|
sub { |
385
|
|
|
|
|
|
|
my $env = shift; |
386
|
|
|
|
|
|
|
my $err = $env->{'psgi.errors'}; |
387
|
|
|
|
|
|
|
my $has_errors = defined $err; |
388
|
|
|
|
|
|
|
return [ |
389
|
|
|
|
|
|
|
200, |
390
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
391
|
|
|
|
|
|
|
[$has_errors] |
392
|
|
|
|
|
|
|
]; |
393
|
|
|
|
|
|
|
}, |
394
|
|
|
|
|
|
|
], |
395
|
|
|
|
|
|
|
[ |
396
|
|
|
|
|
|
|
'status line', |
397
|
|
|
|
|
|
|
sub { |
398
|
|
|
|
|
|
|
my $cb = shift; |
399
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan"); |
400
|
|
|
|
|
|
|
is($res->status_line, '200 OK'); |
401
|
|
|
|
|
|
|
}, |
402
|
|
|
|
|
|
|
sub { |
403
|
|
|
|
|
|
|
my $env = shift; |
404
|
|
|
|
|
|
|
return [ |
405
|
|
|
|
|
|
|
200, |
406
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
407
|
|
|
|
|
|
|
[1] |
408
|
|
|
|
|
|
|
]; |
409
|
|
|
|
|
|
|
}, |
410
|
|
|
|
|
|
|
], |
411
|
|
|
|
|
|
|
[ |
412
|
|
|
|
|
|
|
'Do not crash when the app dies', |
413
|
|
|
|
|
|
|
sub { |
414
|
|
|
|
|
|
|
my $cb = shift; |
415
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/"); |
416
|
|
|
|
|
|
|
is $res->code, 500; |
417
|
|
|
|
|
|
|
is $res->message, 'Internal Server Error'; |
418
|
|
|
|
|
|
|
}, |
419
|
|
|
|
|
|
|
sub { |
420
|
|
|
|
|
|
|
my $env = shift; |
421
|
|
|
|
|
|
|
open my $io, '>', \my $error; |
422
|
|
|
|
|
|
|
$env->{'psgi.errors'} = $io; |
423
|
|
|
|
|
|
|
die "Throwing an exception from app handler. Server shouldn't crash."; |
424
|
|
|
|
|
|
|
}, |
425
|
|
|
|
|
|
|
], |
426
|
|
|
|
|
|
|
[ |
427
|
|
|
|
|
|
|
'multi headers (request)', |
428
|
|
|
|
|
|
|
sub { |
429
|
|
|
|
|
|
|
my $cb = shift; |
430
|
|
|
|
|
|
|
my $req = HTTP::Request->new( |
431
|
|
|
|
|
|
|
GET => "http://127.0.0.1/", |
432
|
|
|
|
|
|
|
); |
433
|
|
|
|
|
|
|
$req->push_header(Foo => "bar"); |
434
|
|
|
|
|
|
|
$req->push_header(Foo => "baz"); |
435
|
|
|
|
|
|
|
my $res = $cb->($req); |
436
|
|
|
|
|
|
|
like($res->content, qr/^bar,\s*baz$/); |
437
|
|
|
|
|
|
|
}, |
438
|
|
|
|
|
|
|
sub { |
439
|
|
|
|
|
|
|
my $env = shift; |
440
|
|
|
|
|
|
|
return [ |
441
|
|
|
|
|
|
|
200, |
442
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
443
|
|
|
|
|
|
|
[ $env->{HTTP_FOO} ] |
444
|
|
|
|
|
|
|
]; |
445
|
|
|
|
|
|
|
}, |
446
|
|
|
|
|
|
|
], |
447
|
|
|
|
|
|
|
[ |
448
|
|
|
|
|
|
|
'multi headers (response)', |
449
|
|
|
|
|
|
|
sub { |
450
|
|
|
|
|
|
|
my $cb = shift; |
451
|
|
|
|
|
|
|
my $res = $cb->(HTTP::Request->new(GET => "http://127.0.0.1/")); |
452
|
|
|
|
|
|
|
my $foo = $res->header('X-Foo'); |
453
|
|
|
|
|
|
|
like $foo, qr/foo,\s*bar,\s*baz/; |
454
|
|
|
|
|
|
|
}, |
455
|
|
|
|
|
|
|
sub { |
456
|
|
|
|
|
|
|
my $env = shift; |
457
|
|
|
|
|
|
|
return [ |
458
|
|
|
|
|
|
|
200, |
459
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', 'X-Foo', 'foo', 'X-Foo', 'bar, baz' ], |
460
|
|
|
|
|
|
|
[ 'hi' ] |
461
|
|
|
|
|
|
|
]; |
462
|
|
|
|
|
|
|
}, |
463
|
|
|
|
|
|
|
], |
464
|
|
|
|
|
|
|
[ |
465
|
|
|
|
|
|
|
'Do not set $env->{COOKIE}', |
466
|
|
|
|
|
|
|
sub { |
467
|
|
|
|
|
|
|
my $cb = shift; |
468
|
|
|
|
|
|
|
my $req = HTTP::Request->new( |
469
|
|
|
|
|
|
|
GET => "http://127.0.0.1/", |
470
|
|
|
|
|
|
|
); |
471
|
|
|
|
|
|
|
$req->push_header(Cookie => "foo=bar"); |
472
|
|
|
|
|
|
|
my $res = $cb->($req); |
473
|
|
|
|
|
|
|
is($res->header('X-Cookie'), 0); |
474
|
|
|
|
|
|
|
is $res->content, 'foo=bar'; |
475
|
|
|
|
|
|
|
}, |
476
|
|
|
|
|
|
|
sub { |
477
|
|
|
|
|
|
|
my $env = shift; |
478
|
|
|
|
|
|
|
return [ |
479
|
|
|
|
|
|
|
200, |
480
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', 'X-Cookie' => $env->{COOKIE} ? 1 : 0 ], |
481
|
|
|
|
|
|
|
[ $env->{HTTP_COOKIE} ] |
482
|
|
|
|
|
|
|
]; |
483
|
|
|
|
|
|
|
}, |
484
|
|
|
|
|
|
|
], |
485
|
|
|
|
|
|
|
[ |
486
|
|
|
|
|
|
|
'no entity headers on 304', |
487
|
|
|
|
|
|
|
sub { |
488
|
|
|
|
|
|
|
my $cb = shift; |
489
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/"); |
490
|
|
|
|
|
|
|
is $res->code, 304; |
491
|
|
|
|
|
|
|
is $res->message, 'Not Modified'; |
492
|
|
|
|
|
|
|
is $res->content, ''; |
493
|
|
|
|
|
|
|
ok ! defined $res->header('content_type'), "No Content-Type"; |
494
|
|
|
|
|
|
|
ok ! defined $res->header('content_length'), "No Content-Length"; |
495
|
|
|
|
|
|
|
ok ! defined $res->header('transfer_encoding'), "No Transfer-Encoding"; |
496
|
|
|
|
|
|
|
}, |
497
|
|
|
|
|
|
|
sub { |
498
|
|
|
|
|
|
|
my $env = shift; |
499
|
|
|
|
|
|
|
return [ 304, [], [] ]; |
500
|
|
|
|
|
|
|
}, |
501
|
|
|
|
|
|
|
], |
502
|
|
|
|
|
|
|
[ |
503
|
|
|
|
|
|
|
'REQUEST_URI is set', |
504
|
|
|
|
|
|
|
sub { |
505
|
|
|
|
|
|
|
my $cb = shift; |
506
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo/bar%20baz%73?x=a"); |
507
|
|
|
|
|
|
|
is $res->content, $ENV{PLACK_TEST_SCRIPT_NAME} . "/foo/bar%20baz%73?x=a"; |
508
|
|
|
|
|
|
|
}, |
509
|
|
|
|
|
|
|
sub { |
510
|
|
|
|
|
|
|
my $env = shift; |
511
|
|
|
|
|
|
|
return [ 200, [ 'Content-Type' => 'text/plain' ], [ $env->{REQUEST_URI} ] ]; |
512
|
|
|
|
|
|
|
}, |
513
|
|
|
|
|
|
|
], |
514
|
|
|
|
|
|
|
[ |
515
|
|
|
|
|
|
|
'filehandle with path()', |
516
|
|
|
|
|
|
|
sub { |
517
|
|
|
|
|
|
|
my $cb = shift; |
518
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/foo.jpg"); |
519
|
|
|
|
|
|
|
is $res->code, 200; |
520
|
|
|
|
|
|
|
is $res->message, 'OK'; |
521
|
|
|
|
|
|
|
is $res->header('content_type'), 'image/jpeg'; |
522
|
|
|
|
|
|
|
is length $res->content, 2898; |
523
|
|
|
|
|
|
|
}, |
524
|
|
|
|
|
|
|
sub { |
525
|
|
|
|
|
|
|
my $env = shift; |
526
|
|
|
|
|
|
|
open my $fh, '<', "$share_dir/face.jpg"; |
527
|
|
|
|
|
|
|
Plack::Util::set_io_path($fh, "$share_dir/face.jpg"); |
528
|
|
|
|
|
|
|
return [ |
529
|
|
|
|
|
|
|
200, |
530
|
|
|
|
|
|
|
[ 'Content-Type' => 'image/jpeg', 'Content-Length' => -s $fh ], |
531
|
|
|
|
|
|
|
$fh |
532
|
|
|
|
|
|
|
]; |
533
|
|
|
|
|
|
|
}, |
534
|
|
|
|
|
|
|
], |
535
|
|
|
|
|
|
|
[ |
536
|
|
|
|
|
|
|
'a big header value > 128 bytes', |
537
|
|
|
|
|
|
|
sub { |
538
|
|
|
|
|
|
|
my $cb = shift; |
539
|
|
|
|
|
|
|
my $req = GET "http://127.0.0.1/"; |
540
|
|
|
|
|
|
|
my $v = ("abcdefgh" x 16); |
541
|
|
|
|
|
|
|
$req->header('X-Foo' => $v); |
542
|
|
|
|
|
|
|
my $res = $cb->($req); |
543
|
|
|
|
|
|
|
is $res->code, 200; |
544
|
|
|
|
|
|
|
is $res->message, 'OK'; |
545
|
|
|
|
|
|
|
is $res->content, $v; |
546
|
|
|
|
|
|
|
}, |
547
|
|
|
|
|
|
|
sub { |
548
|
|
|
|
|
|
|
my $env = shift; |
549
|
|
|
|
|
|
|
return [ |
550
|
|
|
|
|
|
|
200, |
551
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain' ], |
552
|
|
|
|
|
|
|
[ $env->{HTTP_X_FOO} ], |
553
|
|
|
|
|
|
|
]; |
554
|
|
|
|
|
|
|
}, |
555
|
|
|
|
|
|
|
], |
556
|
|
|
|
|
|
|
[ |
557
|
|
|
|
|
|
|
'coderef res', |
558
|
|
|
|
|
|
|
sub { |
559
|
|
|
|
|
|
|
my $cb = shift; |
560
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa"); |
561
|
|
|
|
|
|
|
return if $res->code == 501; |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
is $res->code, 200; |
564
|
|
|
|
|
|
|
is $res->message, 'OK'; |
565
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
566
|
|
|
|
|
|
|
is $res->content, 'Hello, name=miyagawa'; |
567
|
|
|
|
|
|
|
}, |
568
|
|
|
|
|
|
|
sub { |
569
|
|
|
|
|
|
|
my $env = shift; |
570
|
|
|
|
|
|
|
$env->{'psgi.streaming'} or return [ 501, ['Content-Type','text/plain'], [] ]; |
571
|
|
|
|
|
|
|
return sub { |
572
|
|
|
|
|
|
|
my $respond = shift; |
573
|
|
|
|
|
|
|
$respond->([ |
574
|
|
|
|
|
|
|
200, |
575
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
576
|
|
|
|
|
|
|
[ 'Hello, ' . $env->{QUERY_STRING} ], |
577
|
|
|
|
|
|
|
]); |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
}, |
580
|
|
|
|
|
|
|
], |
581
|
|
|
|
|
|
|
[ |
582
|
|
|
|
|
|
|
'coderef streaming', |
583
|
|
|
|
|
|
|
sub { |
584
|
|
|
|
|
|
|
my $cb = shift; |
585
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa"); |
586
|
|
|
|
|
|
|
return if $res->code == 501; |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
is $res->code, 200; |
589
|
|
|
|
|
|
|
is $res->message, 'OK'; |
590
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
591
|
|
|
|
|
|
|
is $res->content, 'Hello, name=miyagawa'; |
592
|
|
|
|
|
|
|
}, |
593
|
|
|
|
|
|
|
sub { |
594
|
|
|
|
|
|
|
my $env = shift; |
595
|
|
|
|
|
|
|
$env->{'psgi.streaming'} or return [ 501, ['Content-Type','text/plain'], [] ]; |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
return sub { |
598
|
|
|
|
|
|
|
my $respond = shift; |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
my $writer = $respond->([ |
601
|
|
|
|
|
|
|
200, |
602
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
603
|
|
|
|
|
|
|
]); |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
$writer->write("Hello, "); |
606
|
|
|
|
|
|
|
$writer->write($env->{QUERY_STRING}); |
607
|
|
|
|
|
|
|
$writer->close(); |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
}, |
610
|
|
|
|
|
|
|
], |
611
|
|
|
|
|
|
|
[ |
612
|
|
|
|
|
|
|
'CRLF output and FCGI parse bug', |
613
|
|
|
|
|
|
|
sub { |
614
|
|
|
|
|
|
|
my $cb = shift; |
615
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/"); |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
is $res->header("Foo"), undef; |
618
|
|
|
|
|
|
|
is $res->content, "Foo: Bar\r\n\r\nHello World"; |
619
|
|
|
|
|
|
|
}, |
620
|
|
|
|
|
|
|
sub { |
621
|
|
|
|
|
|
|
return [ 200, [ "Content-Type", "text/plain" ], [ "Foo: Bar\r\n\r\nHello World" ] ]; |
622
|
|
|
|
|
|
|
}, |
623
|
|
|
|
|
|
|
], |
624
|
|
|
|
|
|
|
[ |
625
|
|
|
|
|
|
|
'newlines', |
626
|
|
|
|
|
|
|
sub { |
627
|
|
|
|
|
|
|
my $cb = shift; |
628
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/"); |
629
|
|
|
|
|
|
|
is length($res->content), 7; |
630
|
|
|
|
|
|
|
}, |
631
|
|
|
|
|
|
|
sub { |
632
|
|
|
|
|
|
|
return [ 200, [ "Content-Type", "text/plain" ], [ "Bar\nBaz" ] ]; |
633
|
|
|
|
|
|
|
}, |
634
|
|
|
|
|
|
|
], |
635
|
|
|
|
|
|
|
[ |
636
|
|
|
|
|
|
|
'test 404', |
637
|
|
|
|
|
|
|
sub { |
638
|
|
|
|
|
|
|
my $cb = shift; |
639
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/"); |
640
|
|
|
|
|
|
|
is $res->code, 404; |
641
|
|
|
|
|
|
|
is $res->message, 'Not Found'; |
642
|
|
|
|
|
|
|
is $res->content, 'Not Found'; |
643
|
|
|
|
|
|
|
}, |
644
|
|
|
|
|
|
|
sub { |
645
|
|
|
|
|
|
|
return [ 404, [ "Content-Type", "text/plain" ], [ "Not Found" ] ]; |
646
|
|
|
|
|
|
|
}, |
647
|
|
|
|
|
|
|
], |
648
|
|
|
|
|
|
|
[ |
649
|
|
|
|
|
|
|
'request->input seekable', |
650
|
|
|
|
|
|
|
sub { |
651
|
|
|
|
|
|
|
my $cb = shift; |
652
|
|
|
|
|
|
|
my $req = HTTP::Request->new(POST => "http://127.0.0.1/"); |
653
|
|
|
|
|
|
|
$req->content("body"); |
654
|
|
|
|
|
|
|
$req->content_type('text/plain'); |
655
|
|
|
|
|
|
|
$req->content_length(4); |
656
|
|
|
|
|
|
|
my $res = $cb->($req); |
657
|
|
|
|
|
|
|
is $res->content, 'body'; |
658
|
|
|
|
|
|
|
}, |
659
|
|
|
|
|
|
|
sub { |
660
|
|
|
|
|
|
|
my $req = Plack::Request->new(shift); |
661
|
|
|
|
|
|
|
return [ 200, [ "Content-Type", "text/plain" ], [ $req->content ] ]; |
662
|
|
|
|
|
|
|
}, |
663
|
|
|
|
|
|
|
], |
664
|
|
|
|
|
|
|
[ |
665
|
|
|
|
|
|
|
'request->content on GET', |
666
|
|
|
|
|
|
|
sub { |
667
|
|
|
|
|
|
|
my $cb = shift; |
668
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1/"); |
669
|
|
|
|
|
|
|
ok $res->is_success; |
670
|
|
|
|
|
|
|
}, |
671
|
|
|
|
|
|
|
sub { |
672
|
|
|
|
|
|
|
my $req = Plack::Request->new(shift); |
673
|
|
|
|
|
|
|
$req->content; |
674
|
|
|
|
|
|
|
return [ 200, [ "Content-Type", "text/plain" ], [ "OK" ] ]; |
675
|
|
|
|
|
|
|
}, |
676
|
|
|
|
|
|
|
], |
677
|
|
|
|
|
|
|
[ |
678
|
|
|
|
|
|
|
'handle Authorization header', |
679
|
|
|
|
|
|
|
sub { |
680
|
|
|
|
|
|
|
my $cb = shift; |
681
|
|
|
|
|
|
|
SKIP: { |
682
|
|
|
|
|
|
|
skip "Authorization header is unsupported under CGI", 4 if ($ENV{PLACK_TEST_HANDLER} || "") eq "CGI"; |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
{ |
685
|
|
|
|
|
|
|
my $req = HTTP::Request->new( |
686
|
|
|
|
|
|
|
GET => "http://127.0.0.1/", |
687
|
|
|
|
|
|
|
); |
688
|
|
|
|
|
|
|
$req->push_header(Authorization => 'Basic XXXX'); |
689
|
|
|
|
|
|
|
my $res = $cb->($req); |
690
|
|
|
|
|
|
|
is $res->header('X-AUTHORIZATION'), 1; |
691
|
|
|
|
|
|
|
is $res->content, 'Basic XXXX'; |
692
|
|
|
|
|
|
|
}; |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
{ |
695
|
|
|
|
|
|
|
my $req = HTTP::Request->new( |
696
|
|
|
|
|
|
|
GET => "http://127.0.0.1/", |
697
|
|
|
|
|
|
|
); |
698
|
|
|
|
|
|
|
my $res = $cb->($req); |
699
|
|
|
|
|
|
|
is $res->header('X-AUTHORIZATION'), 0; |
700
|
|
|
|
|
|
|
is $res->content, 'no_auth'; |
701
|
|
|
|
|
|
|
}; |
702
|
|
|
|
|
|
|
}; |
703
|
|
|
|
|
|
|
}, |
704
|
|
|
|
|
|
|
sub { |
705
|
|
|
|
|
|
|
my $env = shift; |
706
|
|
|
|
|
|
|
return [ |
707
|
|
|
|
|
|
|
200, |
708
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', 'X-AUTHORIZATION' => exists($env->{HTTP_AUTHORIZATION}) ? 1 : 0 ], |
709
|
|
|
|
|
|
|
[ $env->{HTTP_AUTHORIZATION} || 'no_auth' ], |
710
|
|
|
|
|
|
|
]; |
711
|
|
|
|
|
|
|
}, |
712
|
|
|
|
|
|
|
], |
713
|
|
|
|
|
|
|
[ |
714
|
|
|
|
|
|
|
'repeated slashes', |
715
|
|
|
|
|
|
|
sub { |
716
|
|
|
|
|
|
|
my $cb = shift; |
717
|
|
|
|
|
|
|
my $res = $cb->(GET "http://127.0.0.1//foo///bar/baz"); |
718
|
|
|
|
|
|
|
is $res->code, 200; |
719
|
|
|
|
|
|
|
is $res->message, 'OK'; |
720
|
|
|
|
|
|
|
is $res->header('content_type'), 'text/plain'; |
721
|
|
|
|
|
|
|
is $res->content, '//foo///bar/baz'; |
722
|
|
|
|
|
|
|
}, |
723
|
|
|
|
|
|
|
sub { |
724
|
|
|
|
|
|
|
my $env = shift; |
725
|
|
|
|
|
|
|
return [ |
726
|
|
|
|
|
|
|
200, |
727
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', ], |
728
|
|
|
|
|
|
|
[ $env->{PATH_INFO} ], |
729
|
|
|
|
|
|
|
]; |
730
|
|
|
|
|
|
|
}, |
731
|
|
|
|
|
|
|
], |
732
|
|
|
|
|
|
|
); |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
sub runtests { |
735
|
1
|
|
|
1
|
0
|
92
|
my($class, $runner) = @_; |
736
|
1
|
|
|
|
|
3
|
for my $test (@TEST) { |
737
|
36
|
|
|
|
|
13208
|
$runner->(@$test); |
738
|
|
|
|
|
|
|
} |
739
|
|
|
|
|
|
|
} |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
sub run_server_tests { |
742
|
39
|
|
|
39
|
0
|
764
|
my($class, $server, $server_port, $http_port, %args) = @_; |
743
|
|
|
|
|
|
|
|
744
|
39
|
100
|
|
|
|
156
|
if (ref $server ne 'CODE') { |
745
|
1
|
|
|
|
|
2
|
my $server_class = $server; |
746
|
|
|
|
|
|
|
$server = sub { |
747
|
0
|
|
|
0
|
|
0
|
my($port, $app) = @_; |
748
|
0
|
|
|
|
|
0
|
my $server = Plack::Loader->load($server_class, port => $port, host => "127.0.0.1", %args); |
749
|
0
|
|
|
|
|
0
|
$app = Plack::Middleware::Lint->wrap($app); |
750
|
0
|
|
|
|
|
0
|
$server->run($app); |
751
|
|
|
|
|
|
|
} |
752
|
1
|
|
|
|
|
6
|
} |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
test_tcp( |
755
|
|
|
|
|
|
|
client => sub { |
756
|
2
|
|
|
2
|
|
78751
|
my $port = shift; |
757
|
2
|
|
|
|
|
118
|
my $ua = Plack::LWPish->new( no_proxy => [qw/127.0.0.1/] ); |
758
|
2
|
|
|
|
|
19
|
for my $i (0..$#TEST) { |
759
|
72
|
|
|
|
|
31059
|
my $test = $TEST[$i]; |
760
|
72
|
|
|
|
|
425
|
note $test->[0]; |
761
|
|
|
|
|
|
|
my $cb = sub { |
762
|
74
|
|
|
|
|
29960
|
my $req = shift; |
763
|
74
|
|
33
|
|
|
183
|
$req->uri->port($http_port || $port); |
764
|
74
|
|
50
|
|
|
6072
|
$req->uri->path(($ENV{PLACK_TEST_SCRIPT_NAME}||"") . $req->uri->path); |
765
|
74
|
|
|
|
|
3801
|
$req->header('X-Plack-Test' => $i); |
766
|
74
|
|
|
|
|
5328
|
return $ua->request($req); |
767
|
72
|
|
|
|
|
35684
|
}; |
768
|
|
|
|
|
|
|
|
769
|
72
|
|
|
|
|
431
|
$test->[1]->($cb); |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
}, |
772
|
|
|
|
|
|
|
server => sub { |
773
|
37
|
|
|
37
|
|
130721
|
my $port = shift; |
774
|
37
|
|
|
|
|
6808
|
my $app = $class->test_app_handler; |
775
|
37
|
|
|
|
|
2146
|
$server->($port, $app); |
776
|
0
|
|
|
|
|
0
|
exit(0); # for Test::TCP |
777
|
|
|
|
|
|
|
}, |
778
|
39
|
|
|
|
|
312
|
port => $server_port, |
779
|
|
|
|
|
|
|
); |
780
|
|
|
|
|
|
|
} |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
sub test_app_handler { |
783
|
|
|
|
|
|
|
return sub { |
784
|
37
|
|
|
37
|
|
1007
|
my $env = shift; |
785
|
37
|
|
|
|
|
1523
|
$TEST[$env->{HTTP_X_PLACK_TEST}][2]->($env); |
786
|
37
|
|
|
37
|
0
|
3182
|
}; |
787
|
|
|
|
|
|
|
} |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
1; |
790
|
|
|
|
|
|
|
__END__ |