File: | t/test_app.psgi |
Coverage: | 100.0% |
line | stmt | bran | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | package App::plackbench::test_app; | |||||
2 | ||||||
3 | 5 5 5 1 1 1 1 1 1 1 1 1 1 1 | 2336 12 212 2 497 273 3 513 252 2 506 269 2 488 | use strict; | |||
4 | 5 5 5 1 1 1 1 1 1 1 1 1 | 31 28 189 3 39 5 2 35 6 2 38 6 | use warnings; | |||
5 | ||||||
6 | # Sometimes this file gets loaded multiple times. Silence the "subroutine | |||||
7 | # redefined" warning when it is. | |||||
8 | 5 5 5 1 1 1 1 1 1 1 1 1 | 27 10 199 2 45 6 2 34 6 2 38 5 | no warnings 'redefine'; | |||
9 | ||||||
10 | 5 5 5 1 1 1 1 1 1 1 1 1 | 1216 26924 2213 2 38 6 2 37 6 2 41 5 | use HTTP::Response; | |||
11 | ||||||
12 | sub ok { | |||||
13 | 12 | 300 | return HTTP::Response->new(200, 'OK', [], 'ok'); | |||
14 | } | |||||
15 | ||||||
16 | sub slow { | |||||
17 | 1 | 2 | my $req = shift; | |||
18 | 1 | 38 | sleep 1; | |||
19 | 1 | 6 | return HTTP::Response->new(200, 'OK', [], 'slow'); | |||
20 | } | |||||
21 | ||||||
22 | sub fail { | |||||
23 | 4 | 12 | my $req = shift; | |||
24 | 4 | 53 | return HTTP::Response->new(500, 'Internal Server Error', [], 'Danger!'); | |||
25 | } | |||||
26 | ||||||
27 | my @requests; | |||||
28 | sub _get_requests { | |||||
29 | 1 | 5 | my $app = shift; | |||
30 | 1 | 2 | return \@requests; | |||
31 | } | |||||
32 | ||||||
33 | sub _clear_requests { | |||||
34 | 3 | 44 | my $app = shift; | |||
35 | 1 | 6 | @requests = (); | |||
36 | } | |||||
37 | ||||||
38 | my $app = sub { | |||||
39 | my $request = shift; | |||||
40 | ||||||
41 | my $method = $request->{PATH_INFO}; | |||||
42 | $method =~ s#^/|/$##g; | |||||
43 | $method =~ s#/#_#g; | |||||
44 | ||||||
45 | my $response = HTTP::Response->new(404, 'Not Found', [], 'Not Found'); | |||||
46 | if (my $sub = __PACKAGE__->can($method)) { | |||||
47 | $response = $sub->($request); | |||||
48 | } | |||||
49 | ||||||
50 | push @requests, $request; | |||||
51 | ||||||
52 | my @headers = map { $_ => $response->header($_) } $response->header_field_names(); | |||||
53 | ||||||
54 | my $return = [$response->code(), \@headers, [ $response->decoded_content() ]]; | |||||
55 | return $return; | |||||
56 | }; | |||||
57 | ||||||
58 | bless($app, __PACKAGE__); | |||||
59 | ||||||
60 | # Make sure this is the last statement in the file: | |||||
61 | $app; | |||||
62 | ||||||
63 | # vi: set ft=perl : |