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