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