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