1package Catalyst::Stats; 2 3use Moose; 4use Time::HiRes qw/gettimeofday tv_interval/; 5use Text::SimpleTable (); 6use Catalyst::Utils; 7use Tree::Simple qw/use_weak_refs/; 8use Tree::Simple::Visitor::FindByUID; 9 10use namespace::clean -except => 'meta'; 11 12has enable => (is => 'rw', required => 1, default => sub{ 1 }); 13has tree => ( 14 is => 'ro', 15 required => 1, 16 default => sub{ Tree::Simple->new({t => [gettimeofday]}) }, 17 handles => [qw/ accept traverse /], 18 ); 19has stack => ( 20 is => 'ro', 21 required => 1, 22 lazy => 1, 23 default => sub { [ shift->tree ] } 24 ); 25 26sub 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 87sub created { 88 return @{ shift->{tree}->getNodeValue->{t} }; 89} 90 91sub elapsed { 92 return tv_interval(shift->{tree}->getNodeValue->{t}); 93} 94 95sub 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 130sub _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 139sub 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 154sub 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 167sub getNodeValue { 168 my $self = shift; 169 $self->tree->getNodeValue( @_ )->{ t }; 170} 171 172__PACKAGE__->meta->make_immutable(); 173 1741; 175 176__END__ 177 178=for stopwords addChild getNodeValue mysub rollup setNodeValue 179 180=head1 NAME 181 182Catalyst::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 194See L<Catalyst>. 195 196=head1 DESCRIPTION 197 198This module provides the default, simple timing stats collection functionality for Catalyst. 199If you want something different set C<< MyApp->stats_class >> in your application module, 200e.g.: 201 202 __PACKAGE__->stats_class( "My::Stats" ); 203 204If you write your own, your stats object is expected to provide the interface described here. 205 206Catalyst uses this class to report timings of component actions. You can add 207profiling points into your own code to get deeper insight. Typical usage might 208be 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 227Supposing mysub was called from the action "process" inside a Catalyst 228Controller called "service", then the reported timings for the above example 229might 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 242which means mysub took 0.555555s overall, it took 0.111111s to reach the 243critical bit, the first part of the critical bit took 0.333333s, and the second 244part 0.111s. 245 246 247=head1 METHODS 248 249=head2 new 250 251Constructor. 252 253 $stats = Catalyst::Stats->new; 254 255=head2 enable 256 257 $stats->enable(0); 258 $stats->enable(1); 259 260Enable 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 268Marks a profiling point. These can appear in pairs, to time the block of code 269between the begin/end pairs, or by themselves, in which case the time of 270execution to the previous profiling point will be reported. 271 272The argument may be either a single comment string or a list of name-value 273pairs. Thus the following are equivalent: 274 275 $stats->profile($comment); 276 $stats->profile(comment => $comment); 277 278The following key names/values may be used: 279 280=over 4 281 282=item * begin => ACTION 283 284Marks the beginning of a block. The value is used in the description in the 285timing report. 286 287=item * end => ACTION 288 289Marks the end of the block. The name given must match a previous 'begin'. 290Correct nesting is recommended, although this module is tolerant of blocks that 291are not correctly nested, and the reported timings should accurately reflect the 292time taken to execute the block whether properly nested or not. 293 294=item * comment => COMMENT 295 296Comment string; use this to describe the profiling point. It is combined with 297the block action (if any) in the timing report description field. 298 299=item * uid => UID 300 301Assign a predefined unique ID. This is useful if, for whatever reason, you wish 302to relate a profiling point to a different parent than in the natural execution 303sequence. 304 305=item * parent => UID 306 307Explicitly relate the profiling point back to the parent with the specified UID. 308The profiling point will be ignored if the UID has not been previously defined. 309 310=back 311 312Returns the UID of the current point in the profile tree. The UID is 313automatically assigned if not explicitly given. 314 315=head2 created 316 317 ($seconds, $microseconds) = $stats->created; 318 319Returns the time the object was created, in C<gettimeofday> format, with 320Unix epoch seconds followed by microseconds. 321 322=head2 elapsed 323 324 $elapsed = $stats->elapsed 325 326Get 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 334In scalar context, generates a textual report. In array context, returns the 335array of results where each row comprises: 336 337 [ depth, description, time, rollup ] 338 339The depth is the calling stack level of the profiling point. 340 341The description is a combination of the block name and comment. 342 343The time reported for each block is the total execution time for the block, and 344the time associated with each intermediate profiling point is the elapsed time 345from the previous profiling point. 346 347The 'rollup' flag indicates whether the reported time is the rolled up time for 348the block, or the elapsed time from the previous profiling point. 349 350=head1 COMPATIBILITY METHODS 351 352Some components might expect the stats object to be a regular Tree::Simple object. 353We'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 367L<Catalyst> 368 369=head1 AUTHORS 370 371Catalyst Contributors, see Catalyst.pm 372 373=head1 COPYRIGHT 374 375This library is free software. You can redistribute it and/or modify 376it under the same terms as Perl itself. 377 378=cut 379 380__PACKAGE__->meta->make_immutable; 381 3821; 383