lib/Catalyst/Stats.pm

   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 {
  15     enabled => 1,
  16     stack => [ $root ],
  17     tree => $root,
  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) {
  34     $params{comment} = shift || "";
  35     }
  36     elsif (@_ % 2 != 0) {
  37     die "profile() requires a single comment parameter or a list of name-value pairs; found "
  38         . (scalar @_) . " values: " . join(", ", @_);
  39     }
  40     else {
  41     (%params) = @_;
  42     $params{comment} ||= "";
  43     }
  44
  45     my $parent;
  46     my $prev;
  47     my $t = [ gettimeofday ];
  48
  49     if ($params{end}) {
  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
  62     }
  63     if ($params{parent}) {
  64     # parent is explicitly defined
  65     $prev = $parent = $self->_get_uid($params{parent});
  66     }
  67     if (!$parent) {
  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;
  72     }
  73
  74     my $node = Tree::Simple->new({
  75     action  => $params{begin} || "",
  76     t => $t,
  77     elapsed => tv_interval($prev->getNodeValue->{t}, $t),
  78     comment => $params{comment},
  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--) {
  97     $self->profile(end => $self->{stack}->[$i]->getNodeValue->{action});
  98     }
  99
 100     my $t = Text::SimpleTable->new( [ 62, 'Action' ], [ 9, 'Time' ] );
 101     my @results;
 102     $self->{tree}->traverse(
 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             );
 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;