X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FStats.pm;h=1987205fcad7268359fa85c30b8070dde22d17d3;hp=66e9a40ede27fee04eb898ec91ac261868831537;hb=807303a1658f895c41417beba24d24ff9b71c194;hpb=b01f0c69c9821968a297b36d64eed9193287455a diff --git a/lib/Catalyst/Stats.pm b/lib/Catalyst/Stats.pm index 66e9a40..1987205 100644 --- a/lib/Catalyst/Stats.pm +++ b/lib/Catalyst/Stats.pm @@ -1,90 +1,93 @@ package Catalyst::Stats; -use strict; -use warnings; +use Moose; use Time::HiRes qw/gettimeofday tv_interval/; use Text::SimpleTable (); +use Catalyst::Utils; use Tree::Simple qw/use_weak_refs/; use Tree::Simple::Visitor::FindByUID; -sub new { - my $class = shift; +use namespace::clean -except => 'meta'; - 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; -} +has enable => (is => 'rw', required => 1, default => sub{ 1 }); +has tree => ( + is => 'ro', + required => 1, + default => sub{ Tree::Simple->new({t => [gettimeofday]}) }, + handles => [qw/ accept traverse /], + ); +has stack => ( + is => 'ro', + required => 1, + lazy => 1, + default => sub { [ shift->tree ] } + ); sub profile { my $self = shift; - return unless $self->{enabled}; + return unless $self->enable; my %params; if (@_ <= 1) { - $params{comment} = shift || ""; + $params{comment} = shift || ""; } elsif (@_ % 2 != 0) { - die "profile() requires a single comment parameter or a list of name-value pairs; found " - . (scalar @_) . " values: " . join(", ", @_); + die "profile() requires a single comment parameter or a list of name-value pairs; found " + . (scalar @_) . " values: " . join(", ", @_); } else { - (%params) = @_; - $params{comment} ||= ""; + (%params) = @_; + $params{comment} ||= ""; } my $parent; my $prev; my $t = [ gettimeofday ]; + my $stack = $self->stack; 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; + # parent is on stack; search for matching block and splice out + for (my $i = $#{$stack}; $i > 0; $i--) { + if ($stack->[$i]->getNodeValue->{action} eq $params{end}) { + my ($node) = splice(@{$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; + # parent is explicitly defined + $prev = $parent = $self->_get_uid($params{parent}); } 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; + # Find previous node, which is either previous sibling or parent, for ref time. + $prev = $parent = $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}, + 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}; + push(@{$stack}, $node) if $params{begin}; return $node->getUID; } +sub created { + return @{ shift->{tree}->getNodeValue->{t} }; +} + sub elapsed { return tv_interval(shift->{tree}->getNodeValue->{t}); } @@ -92,14 +95,10 @@ sub elapsed { 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 $column_width = Catalyst::Utils::term_width() - 9 - 13; + my $t = Text::SimpleTable->new( [ $column_width, 'Action' ], [ 9, 'Time' ] ); my @results; - $self->{tree}->traverse( + $self->traverse( sub { my $action = shift; my $stat = $action->getNodeValue; @@ -109,8 +108,10 @@ sub report { $stat->{elapsed}, $stat->{action} ? 1 : 0, ); - $t->row( ( q{ } x $r[0] ) . $r[1], - defined $r[2] ? sprintf("%fs", $r[2]) : '??'); + # Trim down any times >= 10 to avoid ugly Text::Simple line wrapping + my $elapsed = substr(sprintf("%f", $stat->{elapsed}), 0, 8) . "s"; + $t->row( ( q{ } x $r[0] ) . $r[1], + defined $r[2] ? $elapsed : '??'); push(@results, \@r); } ); @@ -122,14 +123,51 @@ sub _get_uid { my $visitor = Tree::Simple::Visitor::FindByUID->new; $visitor->searchForUID($uid); - $self->{tree}->accept($visitor); + $self->accept($visitor); return $visitor->getResult; -} +} + +sub addChild { + my $self = shift; + my $node = $_[ 0 ]; + + my $stat = $node->getNodeValue; + + # do we need to fake $stat->{ t } ? + if( $stat->{ elapsed } ) { + # remove the "s" from elapsed time + $stat->{ elapsed } =~ s{s$}{}; + } + + $self->tree->addChild( @_ ); +} + +sub setNodeValue { + my $self = shift; + my $stat = $_[ 0 ]; + + # do we need to fake $stat->{ t } ? + if( $stat->{ elapsed } ) { + # remove the "s" from elapsed time + $stat->{ elapsed } =~ s{s$}{}; + } + + $self->tree->setNodeValue( @_ ); +} + +sub getNodeValue { + my $self = shift; + $self->tree->getNodeValue( @_ )->{ t }; +} + +__PACKAGE__->meta->make_immutable(); 1; __END__ +=for stopwords addChild getNodeValue mysub rollup setNodeValue + =head1 NAME Catalyst::Stats - Catalyst Timing Statistics Class @@ -174,7 +212,7 @@ be like this: $c->stats->profile("completed second part of critical bit"); # more code ... - $c->stats->profile(end => "mysub"); + $c->stats->profile(end => "mysub"); } Supposing mysub was called from the action "process" inside a Catalyst @@ -201,7 +239,7 @@ part 0.111s. =head2 new -Constructor. +Constructor. $stats = Catalyst::Stats->new; @@ -220,7 +258,7 @@ Enable or disable stats collection. By default, stats are enabled after object 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. +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: @@ -265,6 +303,13 @@ The profiling point will be ignored if the UID has not been previously defined. Returns the UID of the current point in the profile tree. The UID is automatically assigned if not explicitly given. +=head2 created + + ($seconds, $microseconds) = $stats->created; + +Returns the time the object was created, in C format, with +Unix epoch seconds followed by microseconds. + =head2 elapsed $elapsed = $stats->elapsed @@ -293,20 +338,36 @@ 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 COMPATIBILITY METHODS + +Some components might expect the stats object to be a regular Tree::Simple object. +We've added some compatibility methods to handle this scenario: + +=head2 accept + +=head2 addChild + +=head2 setNodeValue + +=head2 getNodeValue + +=head2 traverse =head1 SEE ALSO -L. +L -=head1 AUTHOR +=head1 AUTHORS -Jon Schutz +Catalyst Contributors, see Catalyst.pm =head1 COPYRIGHT -This program is free software, you can redistribute it and/or modify +This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1;