Author: timbo
Date: Tue Jan 8 07:54:15 2008
New Revision: 10494
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBI/Profile.pm
dbi/trunk/t/40profile.t
Log:
Fixed avg in DBI::Profile as_text() thanks to Abe Ingersoll.
Added tests and improved docs.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Jan 8 07:54:15 2008
@@ -45,6 +45,7 @@
Fixed potential coredump if stack reallocated while calling back
into perl from XS code. Thanks to John Gardiner Myers.
Fixed DBI::Util::CacheMemory->new to not clear the cache.
+ Fixed avg in DBI::Profile as_text() thanks to Abe Ingersoll.
Expanded DBI::DBD docs for driver authors thanks to Martin Evans.
Enhanced t/80proxy.t test script.
Enhanced t/85gofer.t test script thanks to Stig.
Modified: dbi/trunk/lib/DBI/Profile.pm
==============================================================================
--- dbi/trunk/lib/DBI/Profile.pm (original)
+++ dbi/trunk/lib/DBI/Profile.pm Tue Jan 8 07:54:15 2008
@@ -500,7 +500,12 @@
The C<separator> argument is used to join the elemets of the path for each
leaf node.
The C<sortsub> argument is used to pass in a ref to a sub that will order the
list.
-The subroutine will be passed a reference to the array returned by
as_node_path_list().
+The subroutine will be passed a reference to the array returned by
+as_node_path_list() and should sort the contents of the array in place.
+The return value from the sub is ignored. For example, to sort the nodes by the
+second level key you could use:
+
+ sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary }
The C<format> argument is a C<sprintf> format string that specifies the format
to use for each leaf node. It uses the explicit format parameter index
@@ -508,11 +513,11 @@
The arguments to sprintf are:
1: path to node, joined with the separator
- 2: average duration (total/count)
+ 2: average duration (total duration/count)
(3 thru 9 are currently unused)
10: count
11: total duration
- 12: first_duration
+ 12: first duration
13: smallest duration
14: largest duration
15: time of first call
@@ -818,6 +823,7 @@
my $separator_re = eval($eval) || quotemeta($separator);
#warn "[$eval] = [$separator_re]";
my @text;
+ my @spare_slots = (undef) x 7;
for my $node_path (@node_path_list) {
my ($node, @path) = @$node_path;
my $idx = 0;
@@ -828,8 +834,8 @@
}
push @text, sprintf $format,
join($separator, @path), # 1=path
- ($node->[0] ? $node->[4]/$node->[0] : 0), # 2=avg
- (undef) x 7, # spare slots
+ ($node->[0] ? $node->[1]/$node->[0] : 0), # 2=avg
+ @spare_slots,
@$node; # 10=count, 11=dur, 12=first_dur, 13=min, 14=max,
15=first_called, 16=last_called
}
return @text if wantarray;
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Tue Jan 8 07:54:15 2008
@@ -22,7 +22,7 @@
# tie methods (STORE/FETCH etc) get called different number of times
plan skip_all => "test results assume perl >= 5.8.2"
if $] <= 5.008001;
- plan tests => 58;
+ plan tests => 60;
}
$Data::Dumper::Indent = 1;
@@ -379,8 +379,30 @@
print "testing as_text\n";
+# check %N$ indices
+$dbh->{Profile}->{Data} = { P1 => { P2 => [ 100, 400, 42, 43, 44, 45, 46, 47 ]
} };
+my $as_text = $dbh->{Profile}->as_text({
+ path => [ 'top' ],
+ separator => ':',
+ format => '%1$s %2$d [ %10$d %11$d %12$d %13$d %14$d %15$d %16$d %17$d
]',
+});
+is($as_text, "top:P1:P2 4 [ 100 400 42 43 44 45 46 47 ]");
+
+# test sortsub
+$dbh->{Profile}->{Data} = {
+ A => { Z => [ 101, 1, 2, 3, 4, 5, 6, 7 ] },
+ B => { Y => [ 102, 1, 2, 3, 4, 5, 6, 7 ] },
+};
+$as_text = $dbh->{Profile}->as_text({
+ separator => ':',
+ format => '%1$s %10$d ',
+ sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] }
@$ary }
+});
+is($as_text, "B:Y 102 A:Z 101 ");
+
+# general test, including defaults
($tmp, $dbh) = run_test1( { Path => [ 'foo', '!MethodName', 'baz' ] });
-my $as_text = $dbh->{Profile}->as_text();
+$as_text = $dbh->{Profile}->as_text();
$as_text =~ s/\.00+/.0/g;
#warn "[$as_text]";
is $as_text, q{foo > DESTROY > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s,
max 0.0s)
