lib/Catalyst/Stats.pm

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