| 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 : | |||||