File Coverage

blib/lib/Plack/Test/Suite.pm
Criterion Covered Total %
statement 74 79 93.6
branch 5 6 83.3
condition 2 5 40.0
subroutine 23 24 95.8
pod 0 3 0.0
total 104 117 88.8


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__