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