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