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