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
 130 sub accept {
 131     my $self = shift;
 132     $self->{tree}->accept( @_ );
 133 }
 134
 135 sub addChild {
 136     my $self = shift;
 137     my $node = $_[ 0 ];
 138
 139     my $stat = $node->getNodeValue;
 140
 141     # do we need to fake $stat->{ t } ?
 142     if( $stat->{ elapsed } ) {
 143         # remove the "s" from elapsed time
 144         $stat->{ elapsed } =~ s{s$}{};
 145     }
 146
 147     $self->{tree}->addChild( @_ );
 148 }
 149
 150 sub setNodeValue {
 151     my $self = shift;
 152     my $stat = $_[ 0 ];
 153
 154     # do we need to fake $stat->{ t } ?
 155     if( $stat->{ elapsed } ) {
 156         # remove the "s" from elapsed time
 157         $stat->{ elapsed } =~ s{s$}{};
 158     }
 159
 160     $self->{tree}->setNodeValue( @_ );
 161 }
 162
 163 sub getNodeValue {
 164     my $self = shift;
 165     $self->{tree}->getNodeValue( @_ )->{ t };
 166 }
 167
 168 sub traverse {
 169     my $self = shift;
 170     $self->{tree}->traverse( @_ );
 171 }
 172
 173 1;
 174
 175 __END__
 176
 177 =head1 NAME
 178
 179 Catalyst::Stats - Catalyst Timing Statistics Class
 180
 181 =head1 SYNOPSIS
 182
 183     $stats = $c->stats;
 184     $stats->enable(1);
 185     $stats->profile($comment);
 186     $stats->profile(begin => $block_name, comment =>$comment);
 187     $stats->profile(end => $block_name);
 188     $elapsed = $stats->elapsed;
 189     $report = $stats->report;
 190
 191 See L<Catalyst>.
 192
 193 =head1 DESCRIPTION
 194
 195 This module provides the default, simple timing stats collection functionality for Catalyst.
 196 If you want something different set C<< MyApp->stats_class >> in your application module,
 197 e.g.:
 198
 199     __PACKAGE__->stats_class( "My::Stats" );
 200
 201 If you write your own, your stats object is expected to provide the interface described here.
 202
 203 Catalyst uses this class to report timings of component actions.  You can add
 204 profiling points into your own code to get deeper insight. Typical usage might
 205 be like this:
 206
 207   sub mysub {
 208     my ($c, ...) = @_;
 209     $c->stats->profile(begin => "mysub");
 210     # code goes here
 211     ...
 212     $c->stats->profile("starting critical bit");
 213     # code here too
 214     ...
 215     $c->stats->profile("completed first part of critical bit");
 216     # more code
 217     ...
 218     $c->stats->profile("completed second part of critical bit");
 219     # more code
 220     ...
 221     $c->stats->profile(end => "mysub");
 222   }
 223
 224 Supposing mysub was called from the action "process" inside a Catalyst
 225 Controller called "service", then the reported timings for the above example
 226 might look something like this:
 227
 228   .----------------------------------------------------------------+-----------.
 229   | Action                                                         | Time      |
 230   +----------------------------------------------------------------+-----------+
 231   | /service/process                                               | 1.327702s |
 232   |  mysub                                                         | 0.555555s |
 233   |   - starting critical bit                                      | 0.111111s |
 234   |   - completed first part of critical bit                       | 0.333333s |
 235   |   - completed second part of critical bit                      | 0.111000s |
 236   | /end                                                           | 0.000160s |
 237   '----------------------------------------------------------------+-----------'
 238
 239 which means mysub took 0.555555s overall, it took 0.111111s to reach the
 240 critical bit, the first part of the critical bit took 0.333333s, and the second
 241 part 0.111s.
 242
 243
 244 =head1 METHODS
 245
 246 =head2 new
 247
 248 Constructor.
 249
 250     $stats = Catalyst::Stats->new;
 251
 252 =head2 enable
 253
 254     $stats->enable(0);
 255     $stats->enable(1);
 256
 257 Enable or disable stats collection.  By default, stats are enabled after object creation.
 258
 259 =head2 profile
 260
 261     $stats->profile($comment);
 262     $stats->profile(begin => $block_name, comment =>$comment);
 263     $stats->profile(end => $block_name);
 264
 265 Marks a profiling point.  These can appear in pairs, to time the block of code
 266 between the begin/end pairs, or by themselves, in which case the time of
 267 execution to the previous profiling point will be reported.
 268
 269 The argument may be either a single comment string or a list of name-value
 270 pairs.  Thus the following are equivalent:
 271
 272     $stats->profile($comment);
 273     $stats->profile(comment => $comment);
 274
 275 The following key names/values may be used:
 276
 277 =over 4
 278
 279 =item * begin => ACTION
 280
 281 Marks the beginning of a block.  The value is used in the description in the
 282 timing report.
 283
 284 =item * end => ACTION
 285
 286 Marks the end of the block.  The name given must match a previous 'begin'.
 287 Correct nesting is recommended, although this module is tolerant of blocks that
 288 are not correctly nested, and the reported timings should accurately reflect the
 289 time taken to execute the block whether properly nested or not.
 290
 291 =item * comment => COMMENT
 292
 293 Comment string; use this to describe the profiling point.  It is combined with
 294 the block action (if any) in the timing report description field.
 295
 296 =item * uid => UID
 297
 298 Assign a predefined unique ID.  This is useful if, for whatever reason, you wish
 299 to relate a profiling point to a different parent than in the natural execution
 300 sequence.
 301
 302 =item * parent => UID
 303
 304 Explicitly relate the profiling point back to the parent with the specified UID.
 305 The profiling point will be ignored if the UID has not been previously defined.
 306
 307 =back
 308
 309 Returns the UID of the current point in the profile tree.  The UID is
 310 automatically assigned if not explicitly given.
 311
 312 =head2 elapsed
 313
 314     $elapsed = $stats->elapsed
 315
 316 Get the total elapsed time (in seconds) since the object was created.
 317
 318 =head2 report
 319
 320     print $stats->report ."\n";
 321     $report = $stats->report;
 322     @report = $stats->report;
 323
 324 In scalar context, generates a textual report.  In array context, returns the
 325 array of results where each row comprises:
 326
 327     [ depth, description, time, rollup ]
 328
 329 The depth is the calling stack level of the profiling point.
 330
 331 The description is a combination of the block name and comment.
 332
 333 The time reported for each block is the total execution time for the block, and
 334 the time associated with each intermediate profiling point is the elapsed time
 335 from the previous profiling point.
 336
 337 The 'rollup' flag indicates whether the reported time is the rolled up time for
 338 the block, or the elapsed time from the previous profiling point.
 339
 340 =head1 COMPATABILITY METHODS
 341
 342 Some components might expect the stats object to be a regular Tree::Simple object.
 343 We've added some compatability methods to handle this scenario:
 344
 345 =head2 accept
 346
 347 =head2 addChild
 348
 349 =head2 setNodeValue
 350
 351 =head2 getNodeValue
 352
 353 =head2 traverse
 354
 355 =head1 SEE ALSO
 356
 357 L<Catalyst>.
 358
 359 =head1 AUTHOR
 360
 361 Jon Schutz
 362
 363 =head1 COPYRIGHT
 364
 365 This program is free software, you can redistribute it and/or modify
 366 it under the same terms as Perl itself.
 367
 368 =cut
 369
 370 1;