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 1;
 124
 125 __END__
 126
 127 =head1 NAME
 128
 129 Catalyst::Stats - Catalyst Timing Statistics Class
 130
 131 =head1 SYNOPSIS
 132
 133     $stats = $c->stats;
 134     $stats->enable(1);
 135     $stats->profile($comment);
 136     $stats->profile(begin => $block_name, comment =>$comment);
 137     $stats->profile(end => $block_name);
 138     $elapsed = $stats->elapsed;
 139     $report = $stats->report;
 140
 141 See L<Catalyst>.
 142
 143 =head1 DESCRIPTION
 144
 145 This module provides the default, simple timing stats collection functionality for Catalyst.
 146 If you want something different set C<< MyApp->stats_class >> in your application module,
 147 e.g.:
 148
 149     __PACKAGE__->stats_class( "My::Stats" );
 150
 151 If you write your own, your stats object is expected to provide the interface described here.
 152
 153 Catalyst uses this class to report timings of component actions.  You can add
 154 profiling points into your own code to get deeper insight. Typical usage might
 155 be like this:
 156
 157   sub mysub {
 158     my ($c, ...) = @_;
 159     $c->stats->profile(begin => "mysub");
 160     # code goes here
 161     ...
 162     $c->stats->profile("starting critical bit");
 163     # code here too
 164     ...
 165     $c->stats->profile("completed first part of critical bit");
 166     # more code
 167     ...
 168     $c->stats->profile("completed second part of critical bit");
 169     # more code
 170     ...
 171     $c->stats->profile(end => "mysub");
 172   }
 173
 174 Supposing mysub was called from the action "process" inside a Catalyst
 175 Controller called "service", then the reported timings for the above example
 176 might look something like this:
 177
 178   .----------------------------------------------------------------+-----------.
 179   | Action                                                         | Time      |
 180   +----------------------------------------------------------------+-----------+
 181   | /service/process                                               | 1.327702s |
 182   |  mysub                                                         | 0.555555s |
 183   |   - starting critical bit                                      | 0.111111s |
 184   |   - completed first part of critical bit                       | 0.333333s |
 185   |   - completed second part of critical bit                      | 0.111000s |
 186   | /end                                                           | 0.000160s |
 187   '----------------------------------------------------------------+-----------'
 188
 189 which means mysub took 0.555555s overall, it took 0.111111s to reach the
 190 critical bit, the first part of the critical bit took 0.333333s, and the second
 191 part 0.111s.
 192
 193
 194 =head1 METHODS
 195
 196 =head2 new
 197
 198 Constructor.
 199
 200     $stats = Catalyst::Stats->new;
 201
 202 =head2 enable
 203
 204     $stats->enable(0);
 205     $stats->enable(1);
 206
 207 Enable or disable stats collection.  By default, stats are enabled after object creation.
 208
 209 =head2 profile
 210
 211     $stats->profile($comment);
 212     $stats->profile(begin => $block_name, comment =>$comment);
 213     $stats->profile(end => $block_name);
 214
 215 Marks a profiling point.  These can appear in pairs, to time the block of code
 216 between the begin/end pairs, or by themselves, in which case the time of
 217 execution to the previous profiling point will be reported.
 218
 219 The argument may be either a single comment string or a list of name-value
 220 pairs.  Thus the following are equivalent:
 221
 222     $stats->profile($comment);
 223     $stats->profile(comment => $comment);
 224
 225 The following key names/values may be used:
 226
 227 =over 4
 228
 229 =item * begin => ACTION
 230
 231 Marks the beginning of a block.  The value is used in the description in the
 232 timing report.
 233
 234 =item * end => ACTION
 235
 236 Marks the end of the block.  The name given must match a previous 'begin'.
 237 Correct nesting is recommended, although this module is tolerant of blocks that
 238 are not correctly nested, and the reported timings should accurately reflect the
 239 time taken to execute the block whether properly nested or not.
 240
 241 =item * comment => COMMENT
 242
 243 Comment string; use this to describe the profiling point.  It is combined with
 244 the block action (if any) in the timing report description field.
 245
 246 =item * uid => UID
 247
 248 Assign a predefined unique ID.  This is useful if, for whatever reason, you wish
 249 to relate a profiling point to a different parent than in the natural execution
 250 sequence.
 251
 252 =item * parent => UID
 253
 254 Explicitly relate the profiling point back to the parent with the specified UID.
 255 The profiling point will be ignored if the UID has not been previously defined.
 256
 257 =back
 258
 259 Returns the UID of the current point in the profile tree.  The UID is
 260 automatically assigned if not explicitly given.
 261
 262 =head2 elapsed
 263
 264     $elapsed = $stats->elapsed
 265
 266 Get the total elapsed time (in seconds) since the object was created.
 267
 268 =head2 report
 269
 270     print $stats->report ."\n";
 271     $report = $stats->report;
 272     @report = $stats->report;
 273
 274 In scalar context, generates a textual report.  In array context, returns the
 275 array of results where each row comprises:
 276
 277     [ depth, description, time, rollup ]
 278
 279 The depth is the calling stack level of the profiling point.
 280
 281 The description is a combination of the block name and comment.
 282
 283 The time reported for each block is the total execution time for the block, and
 284 the time associated with each intermediate profiling point is the elapsed time
 285 from the previous profiling point.
 286
 287 The 'rollup' flag indicates whether the reported time is the rolled up time for
 288 the block, or the elapsed time from the previous profiling point.
 289
 290
 291 =head1 SEE ALSO
 292
 293 L<Catalyst>.
 294
 295 =head1 AUTHOR
 296
 297 Jon Schutz
 298
 299 =head1 COPYRIGHT
 300
 301 This program is free software, you can redistribute it and/or modify
 302 it under the same terms as Perl itself.
 303
 304 =cut
 305
 306 __PACKAGE__->meta->make_immutable;
 307
 308 1;