1package Catalyst::Stats;
2
3use Moose;
4use Time::HiRes qw/gettimeofday tv_interval/;
5use Text::SimpleTable ();
6use Catalyst::Utils;
7use Tree::Simple qw/use_weak_refs/;
8use Tree::Simple::Visitor::FindByUID;
9
10use namespace::clean -except => 'meta';
11
12has enable => (is => 'rw', required => 1, default => sub{ 1 });
13has tree => (
14             is => 'ro',
15             required => 1,
16             default => sub{ Tree::Simple->new({t => [gettimeofday]}) },
17             handles => [qw/ accept traverse /],
18            );
19has stack => (
20              is => 'ro',
21              required => 1,
22              lazy => 1,
23              default => sub { [ shift->tree ] }
24             );
25
26sub profile {
27    my $self = shift;
28
29    return unless $self->enable;
30
31    my %params;
32    if (@_ <= 1) {
33        $params{comment} = shift || "";
34    }
35    elsif (@_ % 2 != 0) {
36        die "profile() requires a single comment parameter or a list of name-value pairs; found "
37            . (scalar @_) . " values: " . join(", ", @_);
38    }
39    else {
40        (%params) = @_;
41        $params{comment} ||= "";
42    }
43
44    my $parent;
45    my $prev;
46    my $t = [ gettimeofday ];
47    my $stack = $self->stack;
48
49    if ($params{end}) {
50        # parent is on stack; search for matching block and splice out
51        for (my $i = $#{$stack}; $i > 0; $i--) {
52            if ($stack->[$i]->getNodeValue->{action} eq $params{end}) {
53                my ($node) = splice(@{$stack}, $i, 1);
54                # Adjust elapsed on partner node
55                my $v = $node->getNodeValue;
56                $v->{elapsed} =  tv_interval($v->{t}, $t);
57                return $node->getUID;
58            }
59        }
60    # if partner not found, fall through to treat as non-closing call
61    }
62    if ($params{parent}) {
63        # parent is explicitly defined
64        $prev = $parent = $self->_get_uid($params{parent});
65    }
66    if (!$parent) {
67        # Find previous node, which is either previous sibling or parent, for ref time.
68        $prev = $parent = $stack->[-1] or return undef;
69        my $n = $parent->getChildCount;
70        $prev = $parent->getChild($n - 1) if $n > 0;
71    }
72
73    my $node = Tree::Simple->new({
74        action  => $params{begin} || "",
75        t => $t,
76        elapsed => tv_interval($prev->getNodeValue->{t}, $t),
77        comment => $params{comment},
78    });
79    $node->setUID($params{uid}) if $params{uid};
80
81    $parent->addChild($node);
82    push(@{$stack}, $node) if $params{begin};
83
84    return $node->getUID;
85}
86
87sub created {
88    return @{ shift->{tree}->getNodeValue->{t} };
89}
90
91sub elapsed {
92    return tv_interval(shift->{tree}->getNodeValue->{t});
93}
94
95sub report {
96    my $self = shift;
97
98    my $t;
99    my @results;
100
101    if (!wantarray) {
102        $t = Text::SimpleTable->new(
103            [ Catalyst::Utils::term_width() - 9 - 13, 'Action' ],
104            [ 9, 'Time' ],
105        );
106    }
107
108    $self->traverse(sub {
109        my $action = shift;
110        my $stat   = $action->getNodeValue;
111        my @r = ( $action->getDepth,
112              ($stat->{action} || "") .
113              ($stat->{action} && $stat->{comment} ? " " : "") . ($stat->{comment} ? '- ' . $stat->{comment} : ""),
114              $stat->{elapsed},
115              $stat->{action} ? 1 : 0,
116              );
117        # Trim down any times >= 10 to avoid ugly Text::Simple line wrapping
118        my $elapsed = substr(sprintf("%f", $stat->{elapsed}), 0, 8) . "s";
119        if ($t) {
120            $t->row( ( q{ } x $r[0] ) . $r[1],
121              defined $r[2] ? $elapsed : '??');
122        }
123        else {
124            push @results, \@r;
125        }
126    });
127    return wantarray ? @results : $t->draw;
128}
129
130sub _get_uid {
131    my ($self, $uid) = @_;
132
133    my $visitor = Tree::Simple::Visitor::FindByUID->new;
134    $visitor->searchForUID($uid);
135    $self->accept($visitor);
136    return $visitor->getResult;
137}
138
139sub addChild {
140    my $self = shift;
141    my $node = $_[ 0 ];
142
143    my $stat = $node->getNodeValue;
144
145    # do we need to fake $stat->{ t } ?
146    if( $stat->{ elapsed } ) {
147        # remove the "s" from elapsed time
148        $stat->{ elapsed } =~ s{s$}{};
149    }
150
151    $self->tree->addChild( @_ );
152}
153
154sub setNodeValue {
155    my $self = shift;
156    my $stat = $_[ 0 ];
157
158    # do we need to fake $stat->{ t } ?
159    if( $stat->{ elapsed } ) {
160        # remove the "s" from elapsed time
161        $stat->{ elapsed } =~ s{s$}{};
162    }
163
164    $self->tree->setNodeValue( @_ );
165}
166
167sub getNodeValue {
168    my $self = shift;
169    $self->tree->getNodeValue( @_ )->{ t };
170}
171
172__PACKAGE__->meta->make_immutable();
173
1741;
175
176__END__
177
178=for stopwords addChild getNodeValue mysub rollup setNodeValue
179
180=head1 NAME
181
182Catalyst::Stats - Catalyst Timing Statistics Class
183
184=head1 SYNOPSIS
185
186    $stats = $c->stats;
187    $stats->enable(1);
188    $stats->profile($comment);
189    $stats->profile(begin => $block_name, comment =>$comment);
190    $stats->profile(end => $block_name);
191    $elapsed = $stats->elapsed;
192    $report = $stats->report;
193
194See L<Catalyst>.
195
196=head1 DESCRIPTION
197
198This module provides the default, simple timing stats collection functionality for Catalyst.
199If you want something different set C<< MyApp->stats_class >> in your application module,
200e.g.:
201
202    __PACKAGE__->stats_class( "My::Stats" );
203
204If you write your own, your stats object is expected to provide the interface described here.
205
206Catalyst uses this class to report timings of component actions.  You can add
207profiling points into your own code to get deeper insight. Typical usage might
208be like this:
209
210  sub mysub {
211    my ($c, ...) = @_;
212    $c->stats->profile(begin => "mysub");
213    # code goes here
214    ...
215    $c->stats->profile("starting critical bit");
216    # code here too
217    ...
218    $c->stats->profile("completed first part of critical bit");
219    # more code
220    ...
221    $c->stats->profile("completed second part of critical bit");
222    # more code
223    ...
224    $c->stats->profile(end => "mysub");
225  }
226
227Supposing mysub was called from the action "process" inside a Catalyst
228Controller called "service", then the reported timings for the above example
229might look something like this:
230
231  .----------------------------------------------------------------+-----------.
232  | Action                                                         | Time      |
233  +----------------------------------------------------------------+-----------+
234  | /service/process                                               | 1.327702s |
235  |  mysub                                                         | 0.555555s |
236  |   - starting critical bit                                      | 0.111111s |
237  |   - completed first part of critical bit                       | 0.333333s |
238  |   - completed second part of critical bit                      | 0.111000s |
239  | /end                                                           | 0.000160s |
240  '----------------------------------------------------------------+-----------'
241
242which means mysub took 0.555555s overall, it took 0.111111s to reach the
243critical bit, the first part of the critical bit took 0.333333s, and the second
244part 0.111s.
245
246
247=head1 METHODS
248
249=head2 new
250
251Constructor.
252
253    $stats = Catalyst::Stats->new;
254
255=head2 enable
256
257    $stats->enable(0);
258    $stats->enable(1);
259
260Enable or disable stats collection.  By default, stats are enabled after object creation.
261
262=head2 profile
263
264    $stats->profile($comment);
265    $stats->profile(begin => $block_name, comment =>$comment);
266    $stats->profile(end => $block_name);
267
268Marks a profiling point.  These can appear in pairs, to time the block of code
269between the begin/end pairs, or by themselves, in which case the time of
270execution to the previous profiling point will be reported.
271
272The argument may be either a single comment string or a list of name-value
273pairs.  Thus the following are equivalent:
274
275    $stats->profile($comment);
276    $stats->profile(comment => $comment);
277
278The following key names/values may be used:
279
280=over 4
281
282=item * begin => ACTION
283
284Marks the beginning of a block.  The value is used in the description in the
285timing report.
286
287=item * end => ACTION
288
289Marks the end of the block.  The name given must match a previous 'begin'.
290Correct nesting is recommended, although this module is tolerant of blocks that
291are not correctly nested, and the reported timings should accurately reflect the
292time taken to execute the block whether properly nested or not.
293
294=item * comment => COMMENT
295
296Comment string; use this to describe the profiling point.  It is combined with
297the block action (if any) in the timing report description field.
298
299=item * uid => UID
300
301Assign a predefined unique ID.  This is useful if, for whatever reason, you wish
302to relate a profiling point to a different parent than in the natural execution
303sequence.
304
305=item * parent => UID
306
307Explicitly relate the profiling point back to the parent with the specified UID.
308The profiling point will be ignored if the UID has not been previously defined.
309
310=back
311
312Returns the UID of the current point in the profile tree.  The UID is
313automatically assigned if not explicitly given.
314
315=head2 created
316
317    ($seconds, $microseconds) = $stats->created;
318
319Returns the time the object was created, in C<gettimeofday> format, with
320Unix epoch seconds followed by microseconds.
321
322=head2 elapsed
323
324    $elapsed = $stats->elapsed
325
326Get the total elapsed time (in seconds) since the object was created.
327
328=head2 report
329
330    print $stats->report ."\n";
331    $report = $stats->report;
332    @report = $stats->report;
333
334In scalar context, generates a textual report.  In array context, returns the
335array of results where each row comprises:
336
337    [ depth, description, time, rollup ]
338
339The depth is the calling stack level of the profiling point.
340
341The description is a combination of the block name and comment.
342
343The time reported for each block is the total execution time for the block, and
344the time associated with each intermediate profiling point is the elapsed time
345from the previous profiling point.
346
347The 'rollup' flag indicates whether the reported time is the rolled up time for
348the block, or the elapsed time from the previous profiling point.
349
350=head1 COMPATIBILITY METHODS
351
352Some components might expect the stats object to be a regular Tree::Simple object.
353We've added some compatibility methods to handle this scenario:
354
355=head2 accept
356
357=head2 addChild
358
359=head2 setNodeValue
360
361=head2 getNodeValue
362
363=head2 traverse
364
365=head1 SEE ALSO
366
367L<Catalyst>
368
369=head1 AUTHORS
370
371Catalyst Contributors, see Catalyst.pm
372
373=head1 COPYRIGHT
374
375This library is free software. You can redistribute it and/or modify
376it under the same terms as Perl itself.
377
378=cut
379
380__PACKAGE__->meta->make_immutable;
381
3821;
383