File Coverage

File:lib/App/plackbench.pm
Coverage:95.5%

linestmtbrancondsubtimecode
1package 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
17my %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);
26for 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
38sub 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
69sub _build_app {
70
9
21
    my $self = shift;
71
9
29
    return Plack::Util::load_psgi($self->psgi_path());
72}
73
74sub 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
104sub _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
112sub _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
132sub _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
146sub 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
170sub _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
1851;
186