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