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