[Catalyst-commits] r7749 - in Catalyst-Runtime/5.70/trunk: .
lib/Catalyst t
bricas at dev.catalyst.perl.org
bricas at dev.catalyst.perl.org
Wed May 14 14:42:51 BST 2008
Author: bricas
Date: 2008-05-14 14:42:50 +0100 (Wed, 14 May 2008)
New Revision: 7749
Modified:
Catalyst-Runtime/5.70/trunk/Changes
Catalyst-Runtime/5.70/trunk/lib/Catalyst/Stats.pm
Catalyst-Runtime/5.70/trunk/t/unit_stats.t
Log:
Provide backwards compatability methods in Catalyst::Stats
Modified: Catalyst-Runtime/5.70/trunk/Changes
===================================================================
--- Catalyst-Runtime/5.70/trunk/Changes 2008-05-14 13:42:12 UTC (rev 7748)
+++ Catalyst-Runtime/5.70/trunk/Changes 2008-05-14 13:42:50 UTC (rev 7749)
@@ -1,6 +1,7 @@
# This file documents the revision history for Perl extension Catalyst.
5.7013
+ - Provide backwards compatability methods in Catalyst::Stats
- Fix subdirs for scripts that run in subdirs more than one level deep.
- Added test and updated docs for handling the Authorization header
under mod_fastcgi/mod_cgi.
Modified: Catalyst-Runtime/5.70/trunk/lib/Catalyst/Stats.pm
===================================================================
--- Catalyst-Runtime/5.70/trunk/lib/Catalyst/Stats.pm 2008-05-14 13:42:12 UTC (rev 7748)
+++ Catalyst-Runtime/5.70/trunk/lib/Catalyst/Stats.pm 2008-05-14 13:42:50 UTC (rev 7749)
@@ -126,6 +126,50 @@
return $visitor->getResult;
}
+
+sub accept {
+ my $self = shift;
+ $self->{tree}->accept( @_ );
+}
+
+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 };
+}
+
+sub traverse {
+ my $self = shift;
+ $self->{tree}->traverse( @_ );
+}
+
1;
__END__
@@ -293,7 +337,21 @@
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 COMPATABILITY METHODS
+Some components might expect the stats object to be a regular Tree::Simple object.
+We've added some compatability methods to handle this scenario:
+
+=head2 accept
+
+=head2 addChild
+
+=head2 setNodeValue
+
+=head2 getNodeValue
+
+=head2 traverse
+
=head1 SEE ALSO
L<Catalyst>.
Modified: Catalyst-Runtime/5.70/trunk/t/unit_stats.t
===================================================================
--- Catalyst-Runtime/5.70/trunk/t/unit_stats.t 2008-05-14 13:42:12 UTC (rev 7748)
+++ Catalyst-Runtime/5.70/trunk/t/unit_stats.t 2008-05-14 13:42:50 UTC (rev 7749)
@@ -3,8 +3,9 @@
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More tests => 12;
use Time::HiRes qw/gettimeofday/;
+use Tree::Simple;
my @fudge_t = ( 0, 0 );
BEGIN {
@@ -14,75 +15,141 @@
BEGIN { use_ok("Catalyst::Stats") };
+{
+ my $stats = Catalyst::Stats->new;
+ is (ref($stats), "Catalyst::Stats", "new");
-my $stats = Catalyst::Stats->new;
-is (ref($stats), "Catalyst::Stats", "new");
+ my @expected; # level, string, time
-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] = 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] = 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] = 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[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");
-$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);
-$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 ]);
-$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);
-$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] = 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] = 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] = 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] = 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] = 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[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");
-$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 ]);
-push(@expected, [ 2, "- attach to uid", 0.1, 0 ]);
+ my @report = $stats->report;
+ is_deeply(\@report, \@expected, "report");
-my @report = $stats->report;
-is_deeply(\@report, \@expected, "report");
+ is ($stats->elapsed, 14, "elapsed");
+}
-is ($stats->elapsed, 14, "elapsed");
+# COMPATABILITY METHODS
+# accept
+{
+ my $stats = Catalyst::Stats->new;
+ my $root = $stats->{tree};
+ my $uid = $root->getUID;
+
+ my $visitor = Tree::Simple::Visitor::FindByUID->new;
+ $visitor->includeTrunk(1); # needed for this test
+ $visitor->searchForUID($uid);
+ $stats->accept($visitor);
+ is( $visitor->getResult, $root, '[COMPAT] accept()' );
+
+}
+
+# addChild
+{
+ my $stats = Catalyst::Stats->new;
+ my $node = Tree::Simple->new(
+ {
+ action => 'test',
+ elapsed => '10s',
+ comment => "",
+ }
+ );
+
+ $stats->addChild( $node );
+
+ my $actual = $stats->{ tree }->{ _children }->[ 0 ];
+ is( $actual, $node, '[COMPAT] addChild()' );
+ is( $actual->getNodeValue->{ elapsed }, 10, '[COMPAT] addChild(), data munged' );
+}
+
+# setNodeValue
+{
+ my $stats = Catalyst::Stats->new;
+ my $stat = {
+ action => 'test',
+ elapsed => '10s',
+ comment => "",
+ };
+
+ $stats->setNodeValue( $stat );
+
+ is_deeply( $stats->{tree}->getNodeValue, { action => 'test', elapsed => 10, comment => '' } , '[COMPAT] setNodeValue(), data munged' );
+}
+
+# getNodeValue
+{
+ my $stats = Catalyst::Stats->new;
+ my $expected = $stats->{tree}->getNodeValue->{t};
+ is_deeply( $stats->getNodeValue, $expected, '[COMPAT] getNodeValue()' );
+}
+
+# traverse
+{
+ my $stats = Catalyst::Stats->new;
+ $stats->{tree}->addChild( Tree::Simple->new( { foo => 'bar' } ) );
+ my @value;
+ $stats->traverse( sub { push @value, shift->getNodeValue->{ foo }; } );
+
+ is_deeply( \@value, [ 'bar' ], '[COMPAT] traverse()' );
+}
+
More information about the Catalyst-commits
mailing list