Author: timbo
Date: Mon Feb 19 08:29:40 2007
New Revision: 9137
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBI/ProfileDumper.pm
dbi/trunk/t/41prof_dump.t
Log:
Fixed DBI::ProfileDumper to not be affected by changes to $/ and $, thanks to
Michael Schwern
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Feb 19 08:29:40 2007
@@ -31,6 +31,8 @@
Fixed to work for bleadperl (r29544) thanks to Nicholas Clark.
Users of Perl >= 5.9.5 will require DBI >= 1.54.
Fixed rare error when profiling access to $DBI::err etc tied variables.
+ Fixed DBI::ProfileDumper to not be affected by changes to $/ and $,
+ thanks to Michael Schwern.
Changed t/40profile.t to skip tests for perl < 5.8.0.
Changed setting trace file to no longer write "Trace file set" to new file.
Modified: dbi/trunk/lib/DBI/ProfileDumper.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper.pm Mon Feb 19 08:29:40 2007
@@ -202,12 +202,22 @@
shift->{Data} = {};
}
+sub _print {
+ my($fh) = shift;
+
+ # isolate us against globals which effect print
+ local($\, $,);
+
+ print $fh @_;
+}
+
+
# write header to a filehandle
sub write_header {
my ($self, $fh) = @_;
# module name and version number
- print $fh ref($self), " ", $self->VERSION, "\n";
+ _print $fh, ref($self), " ", $self->VERSION, "\n";
# print out Path
my @path_words;
@@ -216,15 +226,15 @@
push @path_words, $_;
}
}
- print $fh "Path = [ ", join(', ', @path_words), " ]\n";
+ _print $fh, "Path = [ ", join(', ', @path_words), " ]\n";
# print out $0 and @ARGV
- print $fh "Program = $0";
- print $fh " ", join(", ", @ARGV) if @ARGV;
- print $fh "\n";
+ _print $fh, "Program = $0";
+ _print $fh, " ", join(", ", @ARGV) if @ARGV;
+ _print $fh, "\n";
# all done
- print $fh "\n";
+ _print $fh, "\n";
}
# write data in the proscribed format
@@ -236,10 +246,10 @@
while (my ($key, $value) = each(%$data)) {
# output a key
- print $fh "+ ", $level, " ", quote_key($key), "\n";
+ _print $fh, "+ ", $level, " ", quote_key($key), "\n";
if (UNIVERSAL::isa($value,'ARRAY')) {
# output a data set for a leaf node
- printf $fh "= %4d %.6f %.6f %.6f %.6f %.6f %.6f\n", @$value;
+ _print $fh, sprintf "= %4d %.6f %.6f %.6f %.6f %.6f %.6f\n",
@$value;
} else {
# recurse through keys - this could be rewritten to use a
# stack for some small performance gain
Modified: dbi/trunk/t/41prof_dump.t
==============================================================================
--- dbi/trunk/t/41prof_dump.t (original)
+++ dbi/trunk/t/41prof_dump.t Mon Feb 19 08:29:40 2007
@@ -1,4 +1,6 @@
-#!perl -w
+#!perl -wl
+# Using -l to ensure ProfileDumper is isolated from changes to $/ and $\ and
such
+
$|=1;
use strict;
@@ -16,7 +18,7 @@
plan skip_all => 'profiling not supported for DBI::PurePerl';
}
else {
- plan tests => 12;
+ plan tests => 15;
}
}
@@ -58,19 +60,24 @@
ok( -s "dbi.prof", 'Profile is on disk and nonzero size' );
open(PROF, "dbi.prof") or die $!;
-my $prof = join('', <PROF>);
+my @prof = <PROF>;
close PROF;
# has a header?
-ok( $prof =~ /^DBI::ProfileDumper\s+([\d.]+)/, 'Found a version number' );
+ok( $prof[0] =~ /^DBI::ProfileDumper\s+([\d.]+)/, 'Found a version number' );
# Can't use like() because we need $1
# version matches VERSION? (DBI::ProfileDumper uses $self->VERSION so
# it's a stringified version object that looks like N.N.N)
is( $1, DBI::ProfileDumper->VERSION, 'Version numbers match' );
+like( $prof[1], qr{^Path\s+=\s+\[\s+\]}, 'Found the Path');
+ok( $prof[2] =~ m{^Program\s+=\s+(\S+)}, 'Found the Program');
+
+is( $1, $0, 'Program matches' );
+
# check that expected key is there
-like($prof, qr/\+\s+1\s+\Q$sql\E/m);
+like(join('', @prof), qr/\+\s+1\s+\Q$sql\E/m);
# unlink("dbi.prof"); # now done by 'make clean'
