Author: timbo
Date: Tue May 22 02:45:49 2007
New Revision: 9581
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBI/Profile.pm
dbi/trunk/lib/DBI/ProfileData.pm
dbi/trunk/lib/DBI/ProfileDumper.pm
dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
dbi/trunk/t/41prof_dump.t
dbi/trunk/t/86gofer_fail.t
Log:
Added $profile->filename method to DBI::ProfileDumper
Allow filename to be a code ref.
Optimise flush_to_disk().
Write data with full precision (not %.6f)
Enable DBI_PROFILE_APACHE_LOG_DIR env var for mod_perl1 as well as mod_perl2.
Polish up and extend docs for DBI::ProfileDumper && DBI::ProfileDumper::Apache.
Add Quiet=>1 to DBI::ProfileDumper::Apache to not write to STDERR in
flush_to_disk.
Increase acceptable range of values in t/86gofer_fail.t.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue May 22 02:45:49 2007
@@ -8,6 +8,13 @@
Assorted TODO notes:
+Add to profile Path for 'self clocking' sample periods:
+ !Time - integer unix time GMT
+ !TimeN - integer(time/N)*N
+
+Add count of identical frozen_request (plus sum(results size)) to Gofer status
+Highlight those seen before.
+
Move post-request cleanup into separate method and enable hooks so
it can be done after the response has been sent
@@ -33,6 +40,10 @@
Add trace modules that just records the last N trace messages into an array
and prepends them to any error message.
+=head2 Changes in DBI 1.57 (svn rev XXX), XX May 2007
+
+ Fixed unused var warning thanks to JDHEDDEN.
+
=head2 Changes in DBI 1.56 (svn rev 9561), 13th May 2007
Fixed printf arg warnings thanks to JDHEDDEN.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Tue May 22 02:45:49 2007
@@ -9,7 +9,7 @@
require 5.006_00;
BEGIN {
-$DBI::VERSION = "1.56"; # ==> ALSO update the version in the pod text below!
+$DBI::VERSION = "1.57"; # ==> ALSO update the version in the pod text below!
}
=head1 NAME
@@ -120,7 +120,7 @@
=head2 NOTES
-This is the DBI specification that corresponds to the DBI version 1.56
+This is the DBI specification that corresponds to the DBI version 1.57
($Revision$).
The DBI is evolving at a steady pace, so it's good to check that
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue May 22 02:45:49 2007
@@ -4175,7 +4175,8 @@
if (!SvROK(dest) || SvTYPE(SvRV(dest)) != SVt_PVAV)
croak("dbi_profile_merge_nodes(%s,...) not an array reference",
neatsvpv(dest,0));
if (items <= 1) {
- (void)cv;
+ (void)cv; /* avoid unused var warnings */
+ (void)ix;
RETVAL = 0;
}
else {
Modified: dbi/trunk/lib/DBI/Profile.pm
==============================================================================
--- dbi/trunk/lib/DBI/Profile.pm (original)
+++ dbi/trunk/lib/DBI/Profile.pm Tue May 22 02:45:49 2007
@@ -709,10 +709,6 @@
unless UNIVERSAL::isa($thingy,'ARRAY');
push @$leaves, $thingy if $leaves;
- if (0) {
- use Data::Dumper;
- return Dumper($thingy);
- }
my ($count, $total_time, $first_time, $min, $max, $first_called,
$last_called) = @$thingy;
return sprintf "%s%fs\n", ($pad x $depth), $total_time
if $count <= 1;
Modified: dbi/trunk/lib/DBI/ProfileData.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileData.pm (original)
+++ dbi/trunk/lib/DBI/ProfileData.pm Tue May 22 02:45:49 2007
@@ -221,22 +221,19 @@
$path[$index] = $key; # place new key at end
}
- elsif (/^=/) {
+ elsif (s/^=\s+//) {
# it's data - file in the node array with the path in index 0
# (the optional minus is to make it more robust against systems
# with unstable high-res clocks - typically due to poor NTP config
# of kernel SMP behaviour, i.e. min time may be -0.000008))
- @data = /^=\s+(\d+)
- \s+(-?\d+\.?\d*)
- \s+(-?\d+\.?\d*)
- \s+(-?\d+\.?\d*)
- \s+(-?\d+\.?\d*)
- \s+(\d+\.?\d*)
- \s+(\d+\.?\d*)
- \s*$/x;
+
+ @data = split / /, $_;
# corrupt data?
- croak("Invalid data syntax format in $filename line $.: $_")
unless @data;
+ croak("Invalid number of fields in $filename line $.: $_")
+ unless @data == 7;
+ croak("Invalid leaf node characters $filename line $.: $_")
+ unless m/^[-+ 0-9eE\.]+$/;
# hook to enable pre-processing of the data - such as mangling SQL
# so that slightly different statements get treated as the same
Modified: dbi/trunk/lib/DBI/ProfileDumper.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper.pm Tue May 22 02:45:49 2007
@@ -34,8 +34,10 @@
File => 'dbi.prof' );
# using a custom path
- $dbh->{Profile} = DBI::ProfileDumper->new( Path => [ "foo", "bar" ],
- File => 'dbi.prof' );
+ $dbh->{Profile} = DBI::ProfileDumper->new(
+ Path => [ "foo", "bar" ],
+ File => 'dbi.prof',
+ );
=head1 DESCRIPTION
@@ -61,8 +63,9 @@
use DBI::Profile;
$dbh->{Profile} = DBI::ProfileDumper->new(
- Path => [ '!Statement' ]
- File => 'dbi.prof' );
+ Path => [ '!Statement' ],
+ File => 'dbi.prof'
+ );
The C<Path> option takes the same values as in
L<DBI::Profile>. The C<File> option gives the name of the
@@ -84,18 +87,29 @@
my $profile = $dbh->{Profile};
-=over 4
+=head2 flush_to_disk
-=item $profile->flush_to_disk()
+ $profile->flush_to_disk()
Flushes all collected profile data to disk and empties the Data hash.
This method may be called multiple times during a program run.
-=item $profile->empty()
+=head2 empty
+
+ $profile->empty()
Clears the Data hash without writing to disk.
-=back
+=head2 filename
+
+ $profile->empty($filename)
+ $filename = $profile->filename();
+
+Get or set the filename.
+
+The filename can be specified as a CODE reference, in which case the referenced
+code should return the filename to be used. The code will be called with the
+profile object as its first argument.
=head1 DATA FORMAT
@@ -104,7 +118,7 @@
a block of variable declarations describes the profile. After two
newlines, the profile data forms the body of the file. For example:
- DBI::ProfileDumper 1.0
+ DBI::ProfileDumper 2.003762
Path = [ '!Statement', '!MethodName' ]
Program = t/42profile_data.t
@@ -161,95 +175,109 @@
use Carp qw(croak);
use Symbol;
+my $program_header;
+
+
# validate params and setup default
sub new {
my $pkg = shift;
my $self = $pkg->SUPER::new(@_);
- # File defaults to dbi.prof
- $self->{File} = "dbi.prof" unless exists $self->{File};
+ # provide a default filename
+ $self->filename("dbi.prof") unless $self->filename;
return $self;
}
+
+# get/set filename to use
+sub filename {
+ my $self = shift;
+ $self->{File} = shift if @_;
+ my $filename = $self->{File};
+ $filename = $filename->($self) if ref($filename) eq 'CODE';
+ return $filename;
+}
+
+
# flush available data to disk
sub flush_to_disk {
my $self = shift;
- my $data = $self->{Data};
+ my $filename = $self->filename;
my $fh = gensym;
if ($self->{_wrote_header}) {
# append more data to the file
- open($fh, ">>$self->{File}")
- or croak("Unable to open '$self->{File}' for profile output: $!");
+ # XXX assumes that Path hasn't changed
+ open($fh, ">>$filename")
+ or croak("Unable to open '$filename' for profile output: $!");
} else {
- # create new file and write the header
- open($fh, ">$self->{File}")
- or croak("Unable to open '$self->{File}' for profile output: $!");
+ # create new file (overwrite existing) and write the header
+ open($fh, ">$filename")
+ or croak("Unable to open '$filename' for profile output: $!");
$self->write_header($fh);
$self->{_wrote_header} = 1;
}
$self->write_data($fh, $self->{Data}, 1);
- close($fh) or croak("Error closing '$self->{File}': $!");
+ close($fh) or croak("Error closing '$filename': $!");
$self->empty();
}
+
# empty out profile data
sub empty {
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) = @_;
+ # isolate us against globals which effect print
+ local($\, $,);
+
# 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;
- if ($self->{Path}) {
- foreach (@{$self->{Path}}) {
- push @path_words, $_;
- }
- }
- _print $fh, "Path = [ ", join(', ', @path_words), " ]\n";
+ # print out Path (may contain CODE refs etc)
+ my @path_words = map { escape_key($_) } @{ $self->{Path} || [] };
+ 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";
+ if (!$program_header) {
+ # XXX should really quote as well as escape
+ $program_header = "Program = "
+ . join(" ", map { escape_key($_) } $0, @ARGV)
+ . "\n";
+ }
+ print $fh $program_header;
# all done
- _print $fh, "\n";
+ print $fh "\n";
}
+
# write data in the proscribed format
sub write_data {
my ($self, $fh, $data, $level) = @_;
+ # XXX it's valid for $data to be an ARRAY ref, i.e., Path is empty.
# produce an empty profile for invalid $data
return unless $data and UNIVERSAL::isa($data,'HASH');
+ # isolate us against globals which affect print
+ local ($\, $,);
+
while (my ($key, $value) = each(%$data)) {
# output a key
- _print $fh, "+ ", $level, " ", quote_key($key), "\n";
+ print $fh "+ $level ". escape_key($key). "\n";
if (UNIVERSAL::isa($value,'ARRAY')) {
# output a data set for a leaf node
- _print $fh, sprintf "= %4d %.6f %.6f %.6f %.6f %.6f %.6f\n",
@$value;
+ print $fh "= ".join(' ', @$value)."\n";
} else {
# recurse through keys - this could be rewritten to use a
# stack for some small performance gain
@@ -258,8 +286,9 @@
}
}
-# quote a key for output
-sub quote_key {
+
+# escape a key for output
+sub escape_key {
my $key = shift;
$key =~ s!\\!\\\\!g;
$key =~ s!\n!\\n!g;
@@ -268,6 +297,7 @@
return $key;
}
+
# flush data to disk when profile object goes out of scope
sub on_destroy {
shift->flush_to_disk();
Modified: dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper/Apache.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper/Apache.pm Tue May 22 02:45:49 2007
@@ -10,33 +10,17 @@
PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
-Under mod_perl2 RC5+ you'll need to also add:
-
- PerlSetEnv DBI_PROFILE_APACHE_LOG_DIR /server_root/logs
-
-OR add
-
- PerlOptions +GlobalRequest
-
-to the gobal config section you're about test with DBI::ProfileDumper::Apache.
-If you don't do this, you'll see messages in your error_log similar to:
-
- DBI::ProfileDumper::Apache on_destroy failed: Global $r object is not
available. Set:
- PerlOptions +GlobalRequest in httpd.conf at
..../DBI/ProfileDumper/Apache.pm line 144
+(If you're using mod_perl2, see L</When using mod_perl2> for some additional
notes.)
Then restart your server. Access the code you wish to test using a
web browser, then shutdown your server. This will create a set of
-F<dbi.prof.*> files in your Apache log directory. Get a profiling
-report with L<dbiprof|dbiprof>:
-
- dbiprof /usr/local/apache/logs/dbi.prof.*
+F<dbi.prof.*> files in your Apache log directory.
-When you're ready to perform another profiling run, delete the old
-files
+Get a profiling report with L<dbiprof|dbiprof>:
- rm /usr/local/apache/logs/dbi.prof.*
+ dbiprof /path/to/your/apache/logs/dbi.prof.*
-and start again.
+When you're ready to perform another profiling run, delete the old files and
start again.
=head1 DESCRIPTION
@@ -44,7 +28,7 @@
this module you can collect profiling data from mod_perl applications.
It works by creating a DBI::ProfileDumper data file for each Apache
process. These files are created in your Apache log directory. You
-can then use dbiprof to analyze the profile files.
+can then use the dbiprof utility to analyze the profile files.
=head1 USAGE
@@ -55,17 +39,40 @@
PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
-If you want to use one of DBI::Profile's other Path settings, you can
-use a string like:
-
- PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
+The DBI will look after loading and using the module when the first DBI handle
+is created.
It's also possible to use this module by setting the Profile attribute
of any DBI handle:
$dbh->{Profile} = "2/DBI::ProfileDumper::Apache";
-See L<DBI::ProfileDumper> for more possibilities.
+See L<DBI::ProfileDumper> for more possibilities, and L<DBI::Profile> for full
+details of the DBI's profiling mechanism.
+
+=head2 WRITING PROFILE DATA
+
+The profile data files will be written to your Apache log directory by default.
+You can use the C<DBI_PROFILE_APACHE_LOG_DIR> env var to change that. For
example:
+
+ PerlSetEnv DBI_PROFILE_APACHE_LOG_DIR /server_root/logs
+
+=head3 When using mod_perl2
+
+Under mod_perl2 you'll need to either set the C<DBI_PROFILE_APACHE_LOG_DIR>
env var,
+or enable the mod_perl2 C<GlobalRequest> option, like this:
+
+ PerlOptions +GlobalRequest
+
+to the global config section you're about test with DBI::ProfileDumper::Apache.
+If you don't do one of those then you'll see messages in your error_log
similar to:
+
+ DBI::ProfileDumper::Apache on_destroy failed: Global $r object is not
available. Set:
+ PerlOptions +GlobalRequest in httpd.conf at
..../DBI/ProfileDumper/Apache.pm line 144
+
+=head3 Naming the files
+
+XXX
=head2 GATHERING PROFILE DATA
@@ -74,11 +81,11 @@
files will be produced when Apache exits and you'll see something like
this in your error_log:
- DBI::ProfileDumper::Apache writing to /usr/local/apache/logs/dbi.prof.2619
+ DBI::ProfileDumper::Apache writing to
/usr/local/apache/logs/dbi.prof.2604.2619
Now you can use dbiprof to examine the data:
- dbiprof /usr/local/apache/logs/dbi.prof.*
+ dbiprof /usr/local/apache/logs/dbi.prof.2604.*
By passing dbiprof a list of all generated files, dbiprof will
automatically merge them into one result set. You can also pass
@@ -89,22 +96,23 @@
Once you've made some code changes, you're ready to start again.
First, delete the old profile data files:
- rm /usr/local/apache/logs/dbi.prof.*
+ rm /usr/local/apache/logs/dbi.prof.
Then restart your server and get back to work.
=head1 MEMORY USAGE
-DBI::Profile can use a lot of memory for very active applications. It
-collects profiling data in memory for each distinct query your
-application runs. You can avoid this problem with a call like this:
+DBI::Profile can use a lot of memory for very active applications because it
+collects profiling data in memory for each distinct query run.
+Calling C<flush_to_disk()> will write the current data to disk and free the
+memory it's using. For example:
$dbh->{Profile}->flush_to_disk() if $dbh->{Profile};
-Calling C<flush_to_disk()> will clear out the profile data and write
-it to disk. Put this someplace where it will run on every request,
-like a CleanupHandler, and your memory troubles should go away. Well,
-at least the ones caused by DBI::Profile anyway.
+or, rather than flush every time, you could flush less often:
+
+ $dbh->{Profile}->flush_to_disk()
+ if $dbh->{Profile} and ++$i % 100;
=head1 AUTHOR
@@ -137,29 +145,33 @@
# setup File per process
my $path;
- if (MP2) {
- if ($ENV{DBI_PROFILE_APACHE_LOG_DIR}) {
- $path = $ENV{DBI_PROFILE_APACHE_LOG_DIR};
- }
- else {
+ if ($ENV{DBI_PROFILE_APACHE_LOG_DIR}) {
+ $path = $ENV{DBI_PROFILE_APACHE_LOG_DIR};
+ }
+ else {
+ if (MP2) {
require Apache2::RequestUtil;
require Apache2::ServerUtil;
$path =
Apache2::ServerUtil::server_root_relative(Apache2::RequestUtil->request()->pool,
"logs/")
}
+ else {
+ require Apache;
+ $path = Apache->server_root_relative("logs/");
+ }
}
- else {
- require Apache;
- $path = Apache->server_root_relative("logs/");
- }
- my $old_file = $self->{File};
- $self->{File} = File::Spec->catfile($path, "$old_file.$$");
+
+ # to be able to identify groups of profile files from the same set of
+ # apache processes, we include the parent pid in the file name.
+ my $parent_pid = getppid();
+
+ my $filename = $self->filename();
+ local $self->{File} = File::Spec->catfile($path,
"$filename.$parent_pid.$$");
+
+ print STDERR "DBI::ProfileDumper::Apache writing to $self->{File}\n"
+ unless $self->{Quiet};
# write out to disk
- print STDERR "DBI::ProfileDumper::Apache writing to $self->{File}\n";
- $self->SUPER::flush_to_disk(@_);
-
- # reset File to previous setting
- $self->{File} = $old_file;
+ return $self->SUPER::flush_to_disk(@_);
}
1;
Modified: dbi/trunk/t/41prof_dump.t
==============================================================================
--- dbi/trunk/t/41prof_dump.t (original)
+++ dbi/trunk/t/41prof_dump.t Tue May 22 02:45:49 2007
@@ -63,13 +63,15 @@
my @prof = <PROF>;
close PROF;
+print @prof;
+
# has a header?
-ok( $prof[0] =~ /^DBI::ProfileDumper\s+([\d.]+)/, 'Found a version number' );
-# Can't use like() because we need $1
+like( $prof[0], '/^DBI::ProfileDumper\s+([\d.]+)/', 'Found a version number' );
# 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' );
+$prof[0] =~ /^DBI::ProfileDumper\s+([\d.]+)/;
+is( $1, DBI::ProfileDumper->VERSION, "Version numbers match in $prof[0]" );
like( $prof[1], qr{^Path\s+=\s+\[\s+\]}, 'Found the Path');
ok( $prof[2] =~ m{^Program\s+=\s+(\S+)}, 'Found the Program');
Modified: dbi/trunk/t/86gofer_fail.t
==============================================================================
--- dbi/trunk/t/86gofer_fail.t (original)
+++ dbi/trunk/t/86gofer_fail.t Tue May 22 02:45:49 2007
@@ -90,7 +90,7 @@
ReadOnly => 1,
} );
between_ok precentage_exceptions(100, sub { $dbh_50r1ro->do("set foo=1") }),
- 15, 35, 'should fail ~25% (ie 50% with one retry)';
+ 10, 40, 'should fail ~25% (ie 50% with one retry)';
between_ok $dbh_50r1ro->{go_transport}->meta->{request_retry_count},
35, 65, 'transport request_retry_count should be around 50';
