From: Jonathan Rockway Date: Fri, 19 Oct 2007 04:26:34 +0000 (+0000) Subject: merge the stats patch against .10 into trunk X-Git-Tag: 5.7099_04~121 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=dc5f035ee51a9833b5340e3ee597f5722263042f merge the stats patch against .10 into trunk --- diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 53cf386..e63fb98 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -54,12 +54,14 @@ our $DETACH = "catalyst_detach\n"; __PACKAGE__->mk_classdata($_) for qw/components arguments dispatcher engine log dispatcher_class - engine_class context_class request_class response_class setup_finished/; + engine_class context_class request_class response_class stats_class + setup_finished/; __PACKAGE__->dispatcher_class('Catalyst::Dispatcher'); __PACKAGE__->engine_class('Catalyst::Engine::CGI'); __PACKAGE__->request_class('Catalyst::Request'); __PACKAGE__->response_class('Catalyst::Response'); +__PACKAGE__->stats_class('Catalyst::Stats'); # Remember to update this in Catalyst::Runtime as well! @@ -240,6 +242,17 @@ MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used. Specifies log level. +=head2 -Stats + +Enables statistics collection and reporting. You can also force this setting +from the system environment with CATALYST_STATS or _STATS. The +environment settings override the application, with _STATS having the +highest priority. + +e.g. + + use Catalyst qw/-Stats=1/ + =head1 METHODS =head2 INFORMATION ABOUT THE CURRENT REQUEST @@ -813,6 +826,7 @@ sub setup { $class->setup_plugins( delete $flags->{plugins} ); $class->setup_dispatcher( delete $flags->{dispatcher} ); $class->setup_engine( delete $flags->{engine} ); + $class->setup_stats( delete $flags->{stats} ); for my $flag ( sort keys %{$flags} ) { @@ -1198,13 +1212,13 @@ sub execute { return $c->state; } - my $stats_info = $c->_stats_start_execute( $code ) if $c->debug; + my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats; push( @{ $c->stack }, $code ); eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }; - $c->_stats_finish_execute( $stats_info ) if $c->debug and $stats_info; + $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info; my $last = pop( @{ $c->stack } ); @@ -1252,51 +1266,32 @@ sub _stats_start_execute { } } - my $node = Tree::Simple->new( - { - action => $action, - elapsed => undef, # to be filled in later - comment => "", - } - ); - $node->setUID( "$code" . $c->counter->{"$code"} ); - # is this a root-level call or a forwarded call? if ( $callsub =~ /forward$/ ) { # forward, locate the caller if ( my $parent = $c->stack->[-1] ) { - my $visitor = Tree::Simple::Visitor::FindByUID->new; - $visitor->searchForUID( - "$parent" . $c->counter->{"$parent"} ); - $c->stats->accept($visitor); - if ( my $result = $visitor->getResult ) { - $result->addChild($node); - } + $c->stats->profile(begin => $action, + parent => "$parent" . $c->counter->{"$parent"}); } else { # forward with no caller may come from a plugin - $c->stats->addChild($node); + $c->stats->profile(begin => $action); } } else { # root-level call - $c->stats->addChild($node); + $c->stats->profile(begin => $action); } + return $action; - return { - start => [gettimeofday], - node => $node, - }; } sub _stats_finish_execute { my ( $c, $info ) = @_; - my $elapsed = tv_interval $info->{start}; - my $value = $info->{node}->getNodeValue; - $value->{elapsed} = sprintf( '%fs', $elapsed ); + $c->stats->profile(end => $info); } =head2 $c->_localize_fields( sub { }, \%keys ); @@ -1352,22 +1347,11 @@ sub finalize { $c->finalize_body; } - if ($c->debug) { + if ($c->use_stats) { my $elapsed = tv_interval($c->stats->getNodeValue); my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed; - - my $t = Text::SimpleTable->new( [ 62, 'Action' ], [ 9, 'Time' ] ); - $c->stats->traverse( - sub { - my $action = shift; - my $stat = $action->getNodeValue; - $t->row( ( q{ } x $action->getDepth ) . $stat->{action} . $stat->{comment}, - $stat->{elapsed} || '??' ); - } - ); - $c->log->info( - "Request took ${elapsed}s ($av/s)\n" . $t->draw . "\n" ); + "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" ); } return $c->response->status; @@ -1567,8 +1551,8 @@ sub prepare { } ); + $c->stats($class->stats_class->new)->enable($c->use_stats); if ( $c->debug ) { - $c->stats(Tree::Simple->new([gettimeofday])); $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION ); } @@ -2125,6 +2109,26 @@ Sets up plugins. =cut +=head2 $c->setup_stats + +Sets up timing statistics class. + +=cut + +sub setup_stats { + my ( $class, $stats ) = @_; + + Catalyst::Utils::ensure_class_loaded($class->stats_class); + + my $env = Catalyst::Utils::env_value( $class, 'STATS' ); + if ( defined($env) ? $env : ($stats || $class->debug ) ) { + no strict 'refs'; + *{"$class\::use_stats"} = sub { 1 }; + $class->log->debug('Statistics enabled'); + } +} + + =head2 $c->registered_plugins Returns a sorted list of the plugins which have either been stated in the @@ -2188,6 +2192,24 @@ the plugin name does not begin with C. Returns an arrayref of the internal execution stack (actions that are currently executing). +=head2 $c->stats_class + +Returns or sets the stats (timing statistics) class. + +=head2 $c->use_stats + +Returns 1 when stats collection is enabled. Stats collection is enabled +when the -Stats options is set, debug is on or when the _STATS +environment variable is set. + +Note that this is a static method, not an accessor and should be overloaded +by declaring "sub use_stats { 1 }" in your MyApp.pm, not by calling $c->use_stats(1). + +=cut + +sub use_stats { 0 } + + =head2 $c->write( $data ) Writes $data to the output stream. When using this method directly, you diff --git a/lib/Catalyst/Stats.pm b/lib/Catalyst/Stats.pm new file mode 100644 index 0000000..e47954f --- /dev/null +++ b/lib/Catalyst/Stats.pm @@ -0,0 +1,312 @@ +package Catalyst::Stats; + +use strict; +use warnings; +use Time::HiRes qw/gettimeofday tv_interval/; +use Text::SimpleTable (); +use Tree::Simple qw/use_weak_refs/; +use Tree::Simple::Visitor::FindByUID; + +sub new { + my $class = shift; + + my $root = Tree::Simple->new({t => [gettimeofday]}); + bless { + enabled => 1, + stack => [ $root ], + tree => $root, + }, ref $class || $class; +} + +sub enable { + my ($self, $enable) = @_; + + $self->{enabled} = $enable; +} + +sub profile { + my $self = shift; + + return unless $self->{enabled}; + + my %params; + if (@_ <= 1) { + $params{comment} = shift || ""; + } + elsif (@_ % 2 != 0) { + die "profile() requires a single comment parameter or a list of name-value pairs; found " + . (scalar @_) . " values: " . join(", ", @_); + } + else { + (%params) = @_; + $params{comment} ||= ""; + } + + my $parent; + my $prev; + my $t = [ gettimeofday ]; + + if ($params{end}) { + # parent is on stack; search for matching block and splice out + for (my $i = $#{$self->{stack}}; $i > 0; $i--) { + if ($self->{stack}->[$i]->getNodeValue->{action} eq $params{end}) { + my $node = $self->{stack}->[$i]; + splice(@{$self->{stack}}, $i, 1); + # Adjust elapsed on partner node + my $v = $node->getNodeValue; + $v->{elapsed} = tv_interval($v->{t}, $t); + return $node->getUID; + } + } + # if partner not found, fall through to treat as non-closing call + } + if ($params{parent}) { + # parent is explicitly defined + $prev = $parent = $self->_get_uid($params{parent}) or return undef; + } + if (!$parent) { + # Find previous node, which is either previous sibling or parent, for ref time. + $prev = $parent = $self->{stack}->[-1] or return undef; + my $n = $parent->getChildCount; + $prev = $parent->getChild($n - 1) if $n > 0; + } + + my $node = Tree::Simple->new({ + action => $params{begin} || "", + t => $t, + elapsed => tv_interval($prev->getNodeValue->{t}, $t), + comment => $params{comment}, + }); + $node->setUID($params{uid}) if $params{uid}; + + $parent->addChild($node); + push(@{$self->{stack}}, $node) if $params{begin}; + + return $node->getUID; +} + +sub elapsed { + return tv_interval(shift->{tree}->getNodeValue->{t}); +} + +sub report { + my $self = shift; + +# close any remaining open nodes + for (my $i = $#{$self->{stack}}; $i > 0; $i--) { + $self->profile(end => $self->{stack}->[$i]->getNodeValue->{action}); + } + + my $t = Text::SimpleTable->new( [ 62, 'Action' ], [ 9, 'Time' ] ); + my @results; + $self->{tree}->traverse( + sub { + my $action = shift; + my $stat = $action->getNodeValue; + my @r = ( $action->getDepth, + ($stat->{action} || "") . + ($stat->{action} && $stat->{comment} ? " " : "") . ($stat->{comment} ? '- ' . $stat->{comment} : ""), + $stat->{elapsed}, + $stat->{action} ? 1 : 0, + ); + $t->row( ( q{ } x $r[0] ) . $r[1], + defined $r[2] ? sprintf("%fs", $r[2]) : '??'); + push(@results, \@r); + } + ); + return wantarray ? @results : $t->draw; +} + +sub _get_uid { + my ($self, $uid) = @_; + + my $visitor = Tree::Simple::Visitor::FindByUID->new; + $visitor->searchForUID($uid); + $self->{tree}->accept($visitor); + return $visitor->getResult; +} + +1; + +__END__ + +=head1 NAME + +Catalyst::Stats - Catalyst Timing Statistics Class + +=head1 SYNOPSIS + + $stats = $c->stats; + $stats->enable(1); + $stats->profile($comment); + $stats->profile(begin => $block_name, comment =>$comment); + $stats->profile(end => $block_name); + $elapsed = $stats->elapsed; + $report = $stats->report; + +See L. + +=head1 DESCRIPTION + +This module provides the default, simple timing stats collection functionality for Catalyst. +If you want something different set C<< MyApp->stats_class >> in your application module, +e.g.: + + __PACKAGE__->stats_class( "My::Stats" ); + +If you write your own, your stats object is expected to provide the interface described here. + +Catalyst uses this class to report timings of component actions. You can add +profiling points into your own code to get deeper insight. Typical usage might +be like this: + + sub mysub { + my ($c, ...) = @_; + $c->stats->profile(begin => "mysub"); + # code goes here + ... + $c->stats->profile("starting critical bit"); + # code here too + ... + $c->stats->profile("completed first part of critical bit"); + # more code + ... + $c->stats->profile("completed second part of critical bit"); + # more code + ... + $c->stats->profile(end => "mysub"); + } + +Supposing mysub was called from the action "process" inside a Catalyst +Controller called "service", then the reported timings for the above example +might look something like this: + + .----------------------------------------------------------------+-----------. + | Action | Time | + +----------------------------------------------------------------+-----------+ + | /service/process | 1.327702s | + | mysub | 0.555555s | + | - starting critical bit | 0.111111s | + | - completed first part of critical bit | 0.333333s | + | - completed second part of critical bit | 0.111000s | + | /end | 0.000160s | + '----------------------------------------------------------------+-----------' + +which means mysub took 0.555555s overall, it took 0.111111s to reach the +critical bit, the first part of the critical bit took 0.333333s, and the second +part 0.111s. + + +=head1 METHODS + +=head2 new + +Constructor. + + $stats = Catalyst::Stats->new; + +=head2 enable + + $stats->enable(0); + $stats->enable(1); + +Enable or disable stats collection. By default, stats are enabled after object creation. + +=head2 profile + + $stats->profile($comment); + $stats->profile(begin => $block_name, comment =>$comment); + $stats->profile(end => $block_name); + +Marks a profiling point. These can appear in pairs, to time the block of code +between the begin/end pairs, or by themselves, in which case the time of +execution to the previous profiling point will be reported. + +The argument may be either a single comment string or a list of name-value +pairs. Thus the following are equivalent: + + $stats->profile($comment); + $stats->profile(comment => $comment); + +The following key names/values may be used: + +=over 4 + +=item * begin => ACTION + +Marks the beginning of a block. The value is used in the description in the +timing report. + +=item * end => ACTION + +Marks the end of the block. The name given must match a previous 'begin'. +Correct nesting is recommended, although this module is tolerant of blocks that +are not correctly nested, and the reported timings should accurately reflect the +time taken to execute the block whether properly nested or not. + +=item * comment => COMMENT + +Comment string; use this to describe the profiling point. It is combined with +the block action (if any) in the timing report description field. + +=item * uid => UID + +Assign a predefined unique ID. This is useful if, for whatever reason, you wish +to relate a profiling point to a different parent than in the natural execution +sequence. + +=item * parent => UID + +Explicitly relate the profiling point back to the parent with the specified UID. +The profiling point will be ignored if the UID has not been previously defined. + +=back + +Returns the UID of the current point in the profile tree. The UID is +automatically assigned if not explicitly given. + +=head2 elapsed + + $elapsed = $stats->elapsed + +Get the total elapsed time (in seconds) since the object was created. + +=head2 report + + print $stats->report ."\n"; + $report = $stats->report; + @report = $stats->report; + +In scalar context, generates a textual report. In array context, returns the +array of results where each row comprises: + + [ depth, description, time, rollup ] + +The depth is the calling stack level of the profiling point. + +The description is a combination of the block name and comment. + +The time reported for each block is the total execution time for the block, and +the time associated with each intermediate profiling point is the elapsed time +from the previous profiling point. + +The 'rollup' flag indicates whether the reported time is the rolled up time for +the block, or the elapsed time from the previous profiling point. + + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Jon Schutz + +=head1 COPYRIGHT + +This program is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/t/lib/TestAppStats.pm b/t/lib/TestAppStats.pm new file mode 100644 index 0000000..bfc1340 --- /dev/null +++ b/t/lib/TestAppStats.pm @@ -0,0 +1,31 @@ +use strict; +use warnings; + +package TestAppStats; + +use Catalyst qw/ + -Stats=1 +/; + +our $VERSION = '0.01'; +our @log_messages; + +__PACKAGE__->config( name => 'TestAppStats', root => '/some/dir' ); + +__PACKAGE__->log(TestAppStats::Log->new); + +__PACKAGE__->setup; + +# Return log messages from previous request +sub default : Private { + my ( $self, $c ) = @_; + $c->stats->profile("test"); + $c->res->body(join("\n", @log_messages)); + @log_messages = (); +} + +package TestAppStats::Log; +use base qw/Catalyst::Log/; + +sub info { push(@log_messages, @_); } +sub debug { push(@log_messages, @_); } diff --git a/t/live_stats.t b/t/live_stats.t new file mode 100644 index 0000000..ff7fca8 --- /dev/null +++ b/t/live_stats.t @@ -0,0 +1,22 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/lib"; + +use Test::More tests => 5; +use Catalyst::Test 'TestAppStats'; + +{ + ok( my $response = request('http://localhost/'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); +} +{ + ok( my $response = request('http://localhost/'), 'Request' ); + ok( $response->is_success, 'Response Successful 2xx' ); + ok( $response->content =~ m/\/default.*?[\d.]+s.*- test.*[\d.]+s/s, 'Stats report'); + +} + diff --git a/t/unit_stats.t b/t/unit_stats.t new file mode 100644 index 0000000..35d1646 --- /dev/null +++ b/t/unit_stats.t @@ -0,0 +1,88 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 6; +use Time::HiRes qw/gettimeofday/; + +my @fudge_t = ( 0, 0 ); +BEGIN { + no warnings; + *Time::HiRes::gettimeofday = sub () { return @fudge_t }; +} + +BEGIN { use_ok("Catalyst::Stats") }; + + +my $stats = Catalyst::Stats->new; +is (ref($stats), "Catalyst::Stats", "new"); + +my @expected; # level, string, time + +$fudge_t[0] = 1; +ok($stats->profile("single comment arg"), "profile"); +push(@expected, [ 0, "- single comment arg", 1, 0 ]); + +$fudge_t[0] = 3; +$stats->profile(comment => "hash comment arg"); +push(@expected, [ 0, "- hash comment arg", 2, 0 ]); + +$fudge_t[0] = 10; +$stats->profile(begin => "block", comment => "start block"); +push(@expected, [ 0, "block - start block", 4, 1 ]); + + +$fudge_t[0] = 11; +$stats->profile("inside block"); +push(@expected, [ 1, "- inside block", 1, 0 ]); + +$fudge_t[1] = 100000; +my $uid = $stats->profile(begin => "nested block", uid => "boo"); +push(@expected, [ 1, "nested block", 0.7, 1 ]); +is ($uid, "boo", "set UID"); + +$stats->enable(0); +$fudge_t[1] = 150000; +$stats->profile("this shouldn't appear"); +$stats->enable(1); + +$fudge_t[1] = 200000; +$stats->profile(begin => "double nested block 1"); +push(@expected, [ 2, "double nested block 1", 0.2, 1 ]); + +$stats->profile(comment => "attach to uid", parent => $uid); + +$fudge_t[1] = 250000; +$stats->profile(begin => "badly nested block 1"); +push(@expected, [ 3, "badly nested block 1", 0.35, 1 ]); + +$fudge_t[1] = 300000; +$stats->profile(comment => "interleave 1"); +push(@expected, [ 4, "- interleave 1", 0.05, 0 ]); + +$fudge_t[1] = 400000; # end double nested block time +$stats->profile(end => "double nested block 1"); + +$fudge_t[1] = 500000; +$stats->profile(comment => "interleave 2"); +push(@expected, [ 4, "- interleave 2", 0.2, 0 ]); + +$fudge_t[1] = 600000; # end badly nested block time +$stats->profile(end => "badly nested block 1"); + +$fudge_t[1] = 800000; # end nested block time +$stats->profile(end => "nested block"); + +$fudge_t[0] = 14; # end block time +$fudge_t[1] = 0; +$stats->profile(end => "block", comment => "end block"); + +push(@expected, [ 2, "- attach to uid", 0.1, 0 ]); + + +my @report = $stats->report; +is_deeply(\@report, \@expected, "report"); + +is ($stats->elapsed, 14, "elapsed"); +