lib/Catalyst/Stats.pm

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