__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!
Specifies log level.
+=head2 -Stats
+
+Enables statistics collection and reporting. You can also force this setting
+from the system environment with CATALYST_STATS or <MYAPP>_STATS. The
+environment settings override the application, with <MYAPP>_STATS having the
+highest priority.
+
+e.g.
+
+ use Catalyst qw/-Stats=1/
+
=head1 METHODS
=head2 INFORMATION ABOUT THE CURRENT REQUEST
$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} ) {
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 } );
}
}
- 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 );
$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;
}
);
+ $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 );
}
=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
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 <MYAPP>_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
--- /dev/null
+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<Catalyst>.
+
+=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<Catalyst>.
+
+=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;
--- /dev/null
+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, @_); }
--- /dev/null
+#!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');
+
+}
+
--- /dev/null
+#!/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");
+
projects / catagits/Catalyst-Runtime.git / commitdiff