Commit | Line | Data |
dc5f035e |
1 | package Catalyst::Stats; |
2 | |
e5ecd5bc |
3 | use Moose; |
dc5f035e |
4 | use Time::HiRes qw/gettimeofday tv_interval/; |
5 | use Text::SimpleTable (); |
39fc2ce1 |
6 | use Catalyst::Utils; |
dc5f035e |
7 | use Tree::Simple qw/use_weak_refs/; |
8 | use Tree::Simple::Visitor::FindByUID; |
9 | |
01b865ce |
10 | use namespace::clean -except => 'meta'; |
11 | |
e5ecd5bc |
12 | has enable => (is => 'rw', required => 1, default => sub{ 1 }); |
13 | has tree => ( |
14 | is => 'ro', |
15 | required => 1, |
02570318 |
16 | default => sub{ Tree::Simple->new({t => [gettimeofday]}) }, |
17 | handles => [qw/ accept traverse /], |
e5ecd5bc |
18 | ); |
19 | has stack => ( |
20 | is => 'ro', |
21 | required => 1, |
22 | lazy => 1, |
23 | default => sub { [ shift->tree ] } |
24 | ); |
dc5f035e |
25 | |
26 | sub profile { |
27 | my $self = shift; |
28 | |
e5ecd5bc |
29 | return unless $self->enable; |
dc5f035e |
30 | |
31 | my %params; |
32 | if (@_ <= 1) { |
e5ecd5bc |
33 | $params{comment} = shift || ""; |
dc5f035e |
34 | } |
35 | elsif (@_ % 2 != 0) { |
e5ecd5bc |
36 | die "profile() requires a single comment parameter or a list of name-value pairs; found " |
37 | . (scalar @_) . " values: " . join(", ", @_); |
dc5f035e |
38 | } |
39 | else { |
e5ecd5bc |
40 | (%params) = @_; |
41 | $params{comment} ||= ""; |
dc5f035e |
42 | } |
43 | |
44 | my $parent; |
45 | my $prev; |
46 | my $t = [ gettimeofday ]; |
e5ecd5bc |
47 | my $stack = $self->stack; |
dc5f035e |
48 | |
49 | if ($params{end}) { |
e5ecd5bc |
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 | } |
b01f0c69 |
59 | } |
b01f0c69 |
60 | # if partner not found, fall through to treat as non-closing call |
dc5f035e |
61 | } |
62 | if ($params{parent}) { |
e5ecd5bc |
63 | # parent is explicitly defined |
64 | $prev = $parent = $self->_get_uid($params{parent}); |
dc5f035e |
65 | } |
66 | if (!$parent) { |
e5ecd5bc |
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; |
dc5f035e |
71 | } |
72 | |
73 | my $node = Tree::Simple->new({ |
e5ecd5bc |
74 | action => $params{begin} || "", |
75 | t => $t, |
76 | elapsed => tv_interval($prev->getNodeValue->{t}, $t), |
77 | comment => $params{comment}, |
dc5f035e |
78 | }); |
79 | $node->setUID($params{uid}) if $params{uid}; |
80 | |
81 | $parent->addChild($node); |
e5ecd5bc |
82 | push(@{$stack}, $node) if $params{begin}; |
dc5f035e |
83 | |
84 | return $node->getUID; |
85 | } |
86 | |
221f7e77 |
87 | sub created { |
88 | return @{ shift->{tree}->getNodeValue->{t} }; |
89 | } |
90 | |
dc5f035e |
91 | sub elapsed { |
92 | return tv_interval(shift->{tree}->getNodeValue->{t}); |
93 | } |
94 | |
95 | sub report { |
96 | my $self = shift; |
97 | |
0ff7f36c |
98 | my $t; |
dc5f035e |
99 | my @results; |
0ff7f36c |
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 | }); |
dc5f035e |
127 | return wantarray ? @results : $t->draw; |
128 | } |
129 | |
130 | sub _get_uid { |
131 | my ($self, $uid) = @_; |
132 | |
133 | my $visitor = Tree::Simple::Visitor::FindByUID->new; |
134 | $visitor->searchForUID($uid); |
02570318 |
135 | $self->accept($visitor); |
dc5f035e |
136 | return $visitor->getResult; |
b0ad47c1 |
137 | } |
dc5f035e |
138 | |
2f381252 |
139 | sub 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 | |
02570318 |
151 | $self->tree->addChild( @_ ); |
2f381252 |
152 | } |
153 | |
154 | sub 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 | |
02570318 |
164 | $self->tree->setNodeValue( @_ ); |
2f381252 |
165 | } |
166 | |
167 | sub getNodeValue { |
168 | my $self = shift; |
02570318 |
169 | $self->tree->getNodeValue( @_ )->{ t }; |
2f381252 |
170 | } |
171 | |
6680c772 |
172 | __PACKAGE__->meta->make_immutable(); |
173 | |
dc5f035e |
174 | 1; |
175 | |
176 | __END__ |
177 | |
f4dda4a8 |
178 | =for stopwords addChild getNodeValue mysub rollup setNodeValue |
179 | |
dc5f035e |
180 | =head1 NAME |
181 | |
182 | Catalyst::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 | |
194 | See L<Catalyst>. |
195 | |
196 | =head1 DESCRIPTION |
197 | |
198 | This module provides the default, simple timing stats collection functionality for Catalyst. |
199 | If you want something different set C<< MyApp->stats_class >> in your application module, |
200 | e.g.: |
201 | |
202 | __PACKAGE__->stats_class( "My::Stats" ); |
203 | |
204 | If you write your own, your stats object is expected to provide the interface described here. |
205 | |
206 | Catalyst uses this class to report timings of component actions. You can add |
207 | profiling points into your own code to get deeper insight. Typical usage might |
208 | be 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 | ... |
b0ad47c1 |
224 | $c->stats->profile(end => "mysub"); |
dc5f035e |
225 | } |
226 | |
227 | Supposing mysub was called from the action "process" inside a Catalyst |
228 | Controller called "service", then the reported timings for the above example |
229 | might 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 | |
242 | which means mysub took 0.555555s overall, it took 0.111111s to reach the |
243 | critical bit, the first part of the critical bit took 0.333333s, and the second |
244 | part 0.111s. |
245 | |
246 | |
247 | =head1 METHODS |
248 | |
249 | =head2 new |
250 | |
b0ad47c1 |
251 | Constructor. |
dc5f035e |
252 | |
253 | $stats = Catalyst::Stats->new; |
254 | |
255 | =head2 enable |
256 | |
257 | $stats->enable(0); |
258 | $stats->enable(1); |
259 | |
260 | Enable 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 | |
268 | Marks a profiling point. These can appear in pairs, to time the block of code |
269 | between the begin/end pairs, or by themselves, in which case the time of |
b0ad47c1 |
270 | execution to the previous profiling point will be reported. |
dc5f035e |
271 | |
272 | The argument may be either a single comment string or a list of name-value |
273 | pairs. Thus the following are equivalent: |
274 | |
275 | $stats->profile($comment); |
276 | $stats->profile(comment => $comment); |
277 | |
278 | The following key names/values may be used: |
279 | |
280 | =over 4 |
281 | |
282 | =item * begin => ACTION |
283 | |
284 | Marks the beginning of a block. The value is used in the description in the |
285 | timing report. |
286 | |
287 | =item * end => ACTION |
288 | |
289 | Marks the end of the block. The name given must match a previous 'begin'. |
290 | Correct nesting is recommended, although this module is tolerant of blocks that |
291 | are not correctly nested, and the reported timings should accurately reflect the |
292 | time taken to execute the block whether properly nested or not. |
293 | |
294 | =item * comment => COMMENT |
295 | |
296 | Comment string; use this to describe the profiling point. It is combined with |
297 | the block action (if any) in the timing report description field. |
298 | |
299 | =item * uid => UID |
300 | |
301 | Assign a predefined unique ID. This is useful if, for whatever reason, you wish |
302 | to relate a profiling point to a different parent than in the natural execution |
303 | sequence. |
304 | |
305 | =item * parent => UID |
306 | |
307 | Explicitly relate the profiling point back to the parent with the specified UID. |
308 | The profiling point will be ignored if the UID has not been previously defined. |
309 | |
310 | =back |
311 | |
312 | Returns the UID of the current point in the profile tree. The UID is |
313 | automatically assigned if not explicitly given. |
314 | |
221f7e77 |
315 | =head2 created |
316 | |
317 | ($seconds, $microseconds) = $stats->created; |
318 | |
319 | Returns the time the object was created, in C<gettimeofday> format, with |
320 | Unix epoch seconds followed by microseconds. |
321 | |
dc5f035e |
322 | =head2 elapsed |
323 | |
324 | $elapsed = $stats->elapsed |
325 | |
326 | Get 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 | |
334 | In scalar context, generates a textual report. In array context, returns the |
335 | array of results where each row comprises: |
336 | |
337 | [ depth, description, time, rollup ] |
338 | |
339 | The depth is the calling stack level of the profiling point. |
340 | |
341 | The description is a combination of the block name and comment. |
342 | |
343 | The time reported for each block is the total execution time for the block, and |
344 | the time associated with each intermediate profiling point is the elapsed time |
345 | from the previous profiling point. |
346 | |
347 | The 'rollup' flag indicates whether the reported time is the rolled up time for |
348 | the block, or the elapsed time from the previous profiling point. |
349 | |
10011c19 |
350 | =head1 COMPATIBILITY METHODS |
2f381252 |
351 | |
352 | Some components might expect the stats object to be a regular Tree::Simple object. |
10011c19 |
353 | We've added some compatibility methods to handle this scenario: |
2f381252 |
354 | |
355 | =head2 accept |
356 | |
357 | =head2 addChild |
358 | |
359 | =head2 setNodeValue |
360 | |
361 | =head2 getNodeValue |
362 | |
363 | =head2 traverse |
dc5f035e |
364 | |
365 | =head1 SEE ALSO |
366 | |
2f381252 |
367 | L<Catalyst> |
dc5f035e |
368 | |
2f381252 |
369 | =head1 AUTHORS |
dc5f035e |
370 | |
2f381252 |
371 | Catalyst Contributors, see Catalyst.pm |
dc5f035e |
372 | |
373 | =head1 COPYRIGHT |
374 | |
536bee89 |
375 | This library is free software. You can redistribute it and/or modify |
dc5f035e |
376 | it under the same terms as Perl itself. |
377 | |
378 | =cut |
379 | |
e5ecd5bc |
380 | __PACKAGE__->meta->make_immutable; |
381 | |
dc5f035e |
382 | 1; |