File: | lib/App/plackbench.pm |
Coverage: | 95.5% |
line | stmt | bran | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | package App::plackbench; | |||||
2 | ||||||
3 | 5 5 5 | 27 10 191 | use strict; | |||
4 | 5 5 5 | 28 10 159 | use warnings; | |||
5 | 5 5 5 | 287 16846 28 | use autodie; | |||
6 | 5 5 5 | 24327 35 241 | use v5.10; | |||
7 | ||||||
8 | 5 5 5 | 1484 106663 181 | use HTTP::Request qw(); | |||
9 | 5 5 5 | 65 9 478 | use List::Util qw( reduce ); | |||
10 | 5 5 5 | 1137 6784 323 | use Plack::Test qw( test_psgi ); | |||
11 | 5 5 5 | 1314 48776 162 | use Plack::Util qw(); | |||
12 | 5 5 5 | 34 13 293 | use Scalar::Util qw( reftype ); | |||
13 | 5 5 5 | 1673 5841 24 | use Time::HiRes qw( gettimeofday tv_interval ); | |||
14 | ||||||
15 | 5 5 5 | 2289 61 743 | use App::plackbench::Stats; | |||
16 | ||||||
17 | my %attributes = ( | |||||
18 | app => \&_build_app, | |||||
19 | count => 1, | |||||
20 | warm => 0, | |||||
21 | fixup => sub { [] }, | |||||
22 | post_data => undef, | |||||
23 | psgi_path => undef, | |||||
24 | uri => undef, | |||||
25 | ); | |||||
26 | for my $attribute (keys %attributes) { | |||||
27 | my $accessor = sub { | |||||
28 | 148 | 301 | my $self = shift; | |||
29 | ||||||
30 | # $self is a coderef, so yes.. call $self on $self. | |||||
31 | 148 | 440 | return $self->$self($attribute, @_); | |||
32 | }; | |||||
33 | ||||||
34 | 5 5 5 | 30 11 6407 | no strict 'refs'; | |||
35 | *$attribute = $accessor; | |||||
36 | } | |||||
37 | ||||||
38 | sub new { | |||||
39 | 10 | 28 | my $class = shift; | |||
40 | 10 | 47 | my %stash = @_; | |||
41 | ||||||
42 | # $self is a blessed coderef, which is a closure on %stash. I might end up | |||||
43 | # replacing this with a more typical blessed hashref. But, I don't think | |||||
44 | # it's as awful as it sounds. | |||||
45 | ||||||
46 | my $self = sub { | |||||
47 | 148 | 301 | my $self = shift; | |||
48 | 148 | 298 | my $key = shift; | |||
49 | ||||||
50 | 148 | 401 | $stash{$key} = shift if @_; | |||
51 | ||||||
52 | 148 | 445 | if (!exists $stash{$key}) { | |||
53 | 30 | 74 | my $value = $attributes{$key}; | |||
54 | ||||||
55 | # If the default value is a subref, call it. | |||||
56 | 30 | 170 | if (ref($value) && ref($value) eq 'CODE') { | |||
57 | 15 | 46 | $value = $self->$value(); | |||
58 | } | |||||
59 | ||||||
60 | 30 | 371 | $stash{$key} = $value; | |||
61 | } | |||||
62 | ||||||
63 | 148 | 749 | return $stash{$key}; | |||
64 | 10 | 65 | }; | |||
65 | ||||||
66 | 10 | 48 | return bless $self, $class; | |||
67 | } | |||||
68 | ||||||
69 | sub _build_app { | |||||
70 | 9 | 21 | my $self = shift; | |||
71 | 9 | 29 | return Plack::Util::load_psgi($self->psgi_path()); | |||
72 | } | |||||
73 | ||||||
74 | sub run { | |||||
75 | 11 | 27 | my $self = shift; | |||
76 | 11 | 30 | my %args = @_; | |||
77 | ||||||
78 | 11 | 35 | my $app = $self->app(); | |||
79 | 11 | 41 | my $count = $self->count(); | |||
80 | ||||||
81 | 11 | 36 | my $requests = $self->_create_requests(); | |||
82 | ||||||
83 | 11 | 35 | if ( $self->warm() ) { | |||
84 | 1 | 4 | $self->_execute_request( $requests->[0] ); | |||
85 | } | |||||
86 | ||||||
87 | # If it's possible to enable NYTProf, then do so now. | |||||
88 | 11 | 96 | if ( DB->can('enable_profile') ) { | |||
89 | 0 | 0 | DB::enable_profile(); | |||
90 | } | |||||
91 | ||||||
92 | my $stats = reduce { | |||||
93 | 44 44 | 88 108 | my $request_number = $b % scalar(@{$requests}); | |||
94 | 44 | 97 | my $request = $requests->[$request_number]; | |||
95 | ||||||
96 | 44 | 117 | my $elapsed = $self->_time_request( $request ); | |||
97 | 41 | 594 | $a->insert($elapsed); | |||
98 | 41 | 97 | $a; | |||
99 | 11 | 122 | } App::plackbench::Stats->new(), ( 0 .. ( $count - 1 ) ); | |||
100 | ||||||
101 | 8 | 85 | return $stats; | |||
102 | } | |||||
103 | ||||||
104 | sub _time_request { | |||||
105 | 44 | 86 | my $self = shift; | |||
106 | ||||||
107 | 44 | 228 | my @start = gettimeofday; | |||
108 | 44 | 140 | $self->_execute_request(@_); | |||
109 | 41 | 148 | return tv_interval( \@start ); | |||
110 | } | |||||
111 | ||||||
112 | sub _create_requests { | |||||
113 | 11 | 23 | my $self = shift; | |||
114 | ||||||
115 | 11 | 25 | my @requests; | |||
116 | 11 | 34 | if ( $self->post_data() ) { | |||
117 | 3 | 9 | @requests = map { | |||
118 | 1 | 4 | my $req = HTTP::Request->new( POST => $self->uri() ); | |||
119 | 3 | 204 | $req->content($_); | |||
120 | 3 | 44 | $req; | |||
121 | 1 | 2 | } @{ $self->post_data() }; | |||
122 | } | |||||
123 | else { | |||||
124 | 10 | 31 | @requests = ( HTTP::Request->new( GET => $self->uri() ) ); | |||
125 | } | |||||
126 | ||||||
127 | 11 | 17144 | $self->_fixup_requests(\@requests); | |||
128 | ||||||
129 | 11 | 32 | return \@requests; | |||
130 | } | |||||
131 | ||||||
132 | sub _fixup_requests { | |||||
133 | 11 | 26 | my $self = shift; | |||
134 | 11 | 25 | my $requests = shift; | |||
135 | ||||||
136 | 11 | 35 | my $fixups = $self->fixup(); | |||
137 | 11 5 11 | 26 67 35 | $fixups = [ grep { reftype($_) && reftype($_) eq 'CODE' } @{$fixups} ]; | |||
138 | ||||||
139 | 11 11 | 24 31 | for my $request (@{$requests}) { | |||
140 | 13 13 | 25 78 | $_->($request) for @{$fixups}; | |||
141 | } | |||||
142 | ||||||
143 | 11 | 247 | return; | |||
144 | } | |||||
145 | ||||||
146 | sub add_fixup_from_file { | |||||
147 | 6 | 15 | my $self = shift; | |||
148 | 6 | 14 | my $file = shift; | |||
149 | ||||||
150 | 6 | 1049 | my $sub = do $file; | |||
151 | ||||||
152 | 6 | 29 | if (!$sub) { | |||
153 | 2 | 28 | die($@ || $!); | |||
154 | } | |||||
155 | ||||||
156 | 4 | 40 | if (!reftype($sub) || !reftype($sub) eq 'CODE') { | |||
157 | 1 | 8 | die("$file: does not return a subroutine reference"); | |||
158 | } | |||||
159 | ||||||
160 | 3 | 10 | my $existing = $self->fixup(); | |||
161 | 3 | 37 | if (!$existing || !reftype($existing) || reftype($existing) ne 'ARRAY') { | |||
162 | 1 | 4 | $self->fixup([]); | |||
163 | } | |||||
164 | ||||||
165 | 3 3 | 8 9 | push @{$self->fixup()}, $sub; | |||
166 | ||||||
167 | 3 | 10 | return; | |||
168 | } | |||||
169 | ||||||
170 | sub _execute_request { | |||||
171 | 45 | 90 | my $self = shift; | |||
172 | 45 | 85 | my $request = shift; | |||
173 | ||||||
174 | test_psgi $self->app(), sub { | |||||
175 | 45 | 25421 | my $cb = shift; | |||
176 | 45 | 144 | my $response = $cb->($request); | |||
177 | 45 | 4994 | if ( $response->is_error() ) { | |||
178 | 3 | 37 | die "Request failed: " . $response->decoded_content; | |||
179 | } | |||||
180 | 45 | 112 | }; | |||
181 | ||||||
182 | 42 | 637 | return; | |||
183 | } | |||||
184 | ||||||
185 | 1; | |||||
186 |