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