develooper Front page | perl.dbi.dev | Postings from October 2002

[PATCH] DBI::ProfileDumper and friends

Thread Next
From:
Sam Tregar
Date:
October 16, 2002 12:09
Subject:
[PATCH] DBI::ProfileDumper and friends
Message ID:
Pine.LNX.4.44.0210161432300.4139-200000@airtrout.tregar.com
diff -Naur DBI-1.30/Makefile.PL DBI/Makefile.PL
--- DBI-1.30/Makefile.PL	Mon Jul 15 07:19:23 2002
+++ DBI/Makefile.PL	Wed Oct 16 14:45:47 2002
@@ -1,6 +1,6 @@
 # -*- perl -*-
 #
-# $Id: Makefile.PL,v 11.8 2002/07/15 11:18:57 timbo Exp $
+# $Id: Makefile.PL,v 1.1.1.1 2002/10/04 01:45:58 sam Exp $
 #
 #  Copyright (c) 1994-2002  Tim Bunce  England
 #
@@ -106,11 +106,11 @@
 my %opts = (
     NAME=> 'DBI',
     VERSION_FROM=> 'DBI.pm',
-    EXE_FILES => [ "dbish$ext_pl", "dbiproxy$ext_pl" ],
+    EXE_FILES => [ "dbish$ext_pl", "dbiproxy$ext_pl", "dbi_prof$ext_pl" ],
     DIR => [],
     dynamic_lib => { OTHERLDFLAGS => "$::opt_g" },
     clean => { FILES=> "\$(DISTVNAME) Perl.xsi "
-			."dbish$ext_pl dbiproxy$ext_pl ndtest.prt" },
+			."dbish$ext_pl dbiproxy$ext_pl dbi_prof$ext_pl ndtest.prt" },
     dist  => {
 	DIST_DEFAULT=> 'clean distcheck disttest ci tardist',
 	PREOP => '$(MAKE) -f Makefile.old distdir',
diff -Naur DBI-1.30/dbi_prof.PL DBI/dbi_prof.PL
--- DBI-1.30/dbi_prof.PL	Wed Dec 31 19:00:00 1969
+++ DBI/dbi_prof.PL	Wed Oct 16 14:16:27 2002
@@ -0,0 +1,221 @@
+# -*- perl -*-
+
+my $file = 'dbi_prof';
+
+my $script = <<'SCRIPT';
+~startperl~
+
+use strict;
+
+my $VERSION = "1.0";
+
+use DBI::ProfileData;
+use Getopt::Long;
+
+# default options
+my $number         = 10;
+my $sort           = 'total';
+my $filename       = 'dbi.prof';
+my $reverse        = 0;
+my $case_sensitive = 0;
+my (%match, %exclude);
+
+# get options from command line
+GetOptions(
+           'version'        => sub { die "dbi_prof $VERSION\n"; },
+           'number=i'       => \$number,
+           'sort=s'         => \$sort,
+           'reverse'        => \$reverse,
+           'match=s'        => \%match,
+           'exclude=s'      => \%exclude,
+           'case-sensitive' => \$case_sensitive,
+          );
+
+# list of files defaults to dbi.prof
+my @files = @ARGV ? @ARGV : ('dbi.prof');
+
+
+# instantiate ProfileData object
+my $prof;
+eval { $prof = DBI::ProfileData->new(Files => \@files) };
+die "Unable to load profile data: $@\n" if $@;
+
+# handle matches
+while (my ($key, $val) = each %match) {
+    if ($val =~ m!^/(.+)/$!) {
+        $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+    } 
+    $prof->match($key, $val, case_sensitive => $case_sensitive);
+}
+
+# handle excludes
+while (my ($key, $val) = each %exclude) {
+    if ($val =~ m!^/(.+)/$!) {
+        $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+    } 
+    $prof->exclude($key, $val, case_sensitive => $case_sensitive);
+}
+
+# sort the data
+$prof->sort(field => $sort, reverse => $reverse);
+
+# all done, print it out
+print $prof->report(number => $number);
+exit 0;
+
+__END__
+
+=head1 NAME
+
+dbi_prof - command-line client for DBI::ProfileData
+
+=head1 SYNOPSIS
+
+See a report of the ten queries with the longest total runtime in the
+profile dump file F<prof1.out>:
+
+ dbi_prof prof1.out
+
+See the top 10 most frequently run queries in the profile file
+F<dbi.prof> (the default):
+
+  dbi_prof --sort count
+
+See the same report with 15 entries:
+
+  dbi_prof --sort count --number 15
+
+=head1 DESCRIPTION
+
+This tool is a command-line client for the DBI::ProfileData.  It
+allows you to analyze the profile data file produced by
+DBI::ProfileDumper and produce various useful reports.
+
+=head1 OPTIONS
+
+This program accepts the following options:
+
+=over 4
+
+=item --number N
+
+Produce this many items in the report.  Defaults to 10.  If set to
+"all" then all results are shown.
+
+=item --sort field
+
+Sort results by the given field.  The available sort fields are:
+
+=over 4
+
+=item total
+
+Sorts by total time run time across all runs.  This is the default
+sort.
+
+=item longest
+
+Sorts by the longest single run.
+
+=item count
+
+Sorts by total number of runs.
+
+=item first
+
+Sorts by the time taken in the first run.
+
+=item shortest
+
+Sorts by the shortest single run.
+
+=back
+
+=item --reverse
+
+Reverses the selected sort.  For example, to see a report of the
+shortest overall time:
+
+  dbi_prof --sort total --reverse
+
+=item --match keyN=value
+
+Consider only items where the specified key matches the given value.
+Keys are numbered from 1.  For example, let's say you used a
+DBI::Profile Path of:
+
+  [ DBIprofile_Statement, DBIprofile_Methodname ]
+
+And called dbi_prof as in:
+
+  dbi_prof --match key2=execute
+
+Your report would only show execute queries, leaving out prepares,
+fetches, etc.
+
+If the value given starts and ends with slashes (C</>) then it will be
+treated as a regular expression.  For example, to only include SELECT
+queries where key1 is the statement:
+
+  dbi_prof --match key1=/^SELECT/
+
+By default the match expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --exclude keyN=value
+
+Remove items for where the specified key matches the given value.  For
+example, to exclude all prepare entries where key2 is the method name:
+
+  dbi_prof --exclude key2=prepare
+
+Like C<--match>, If the value given starts and ends with slashes
+(C</>) then it will be treated as a regular expression.  For example,
+to exclude UPDATE queries where key1 is the statement:
+
+  dbi_prof --match key1=/^UPDATE/
+
+By default the exclude expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --case-sensitive
+
+Using this option causes --match and --exclude to work
+case-sensitively.  Defaults to off.
+
+=item --version
+
+Print the dbi_prof version number and exit.
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=head1 SEE ALSO
+
+L<DBI::ProfileDumper|DBI::ProfileDumper>,
+L<DBI::Profile|DBI::Profile>, L<DBI|DBI>.
+
+=cut
+
+SCRIPT
+
+
+require Config;
+my $config = {};
+$config->{'startperl'} = $Config::Config{'startperl'};
+
+$script =~ s/\~(\w+)\~/$config->{$1}/eg;
+if (!(open(FILE, ">$file"))  ||
+    !(print FILE $script)  ||
+    !(close(FILE))) {
+    die "Error while writing $file: $!\n";
+}
+print "Extracted $file from ",__FILE__," with variable substitutions.\n";
diff -Naur DBI-1.30/lib/DBI/Profile.pm DBI/lib/DBI/Profile.pm
--- DBI-1.30/lib/DBI/Profile.pm	Wed Oct 16 14:34:09 2002
+++ DBI/lib/DBI/Profile.pm	Wed Oct 16 14:26:38 2002
@@ -6,9 +6,18 @@
 
 =head1 SYNOPSIS
 
-  use DBI;
+The easiest way to enable DBI profiling is to set the DBI_PROFILE
+environment variable to 2 and then run your code as usual:
 
-  $h->{Profile} = ... ;
+  DBI_PROFILE=2 prog.pl
+
+This will profile your program and then output a textual summary
+grouped by query.  You can also enable profiling by setting the
+Profile attribute of any DBI handle:
+
+  $dbh->{Profile} = 2;
+
+Other values are possible - see L<"ENABLING A PROFILE"> below.
 
 =head1 DESCRIPTION
 
@@ -17,6 +26,11 @@
 The DBI::Profile module provides a simple interface to collect and
 report performance and benchmarking data from the DBI.
 
+For a more elaborate interface, suitable for larger programs, see
+L<DBI::ProfileDumper|DBI::ProfileDumper> and L<dbi_prof|dbi_prof>.
+For Apache/mod_perl applications see
+L<DBI::ProfileDumper::Apache|DBI::ProfileDumper::Apache>.
+
 =head1 OVERVIEW
 
 Performance data collection for the DBI is built around several
@@ -449,7 +463,7 @@
 
 use DBI qw(dbi_time dbi_profile dbi_profile_merge);
 
-$VERSION = sprintf "%d.%02d", '$Revision: 1.2 $ ' =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", '$Revision: 1.4 $ ' =~ /(\d+)\.(\d+)/;
 
 @ISA = qw(Exporter);
 @EXPORT = qw(
@@ -603,15 +617,18 @@
 }
 
 
+sub on_destroy {
+    my $self = shift;
+    my $detail = $self->format() if $self->{Data};
+    DBI->trace_msg($detail, 0) if $detail;
+}
+
 sub DESTROY {
     my $self = shift;
-    eval {
-	my $detail = $self->format() if $self->{Data};
-	DBI->trace_msg($detail, 0);
-    };
+    eval { $self->on_destroy };
     if ($@) {
-	my $class = ref($self) || $self;
-	DBI->trace_msg("$class format failed: $@", 0);
+        my $class = ref($self) || $self;
+        DBI->trace_msg("$class on_destroy failed: $@", 0);
     }
 }
 
diff -Naur DBI-1.30/lib/DBI/ProfileData.pm DBI/lib/DBI/ProfileData.pm
--- DBI-1.30/lib/DBI/ProfileData.pm	Wed Dec 31 19:00:00 1969
+++ DBI/lib/DBI/ProfileData.pm	Wed Oct 16 14:16:27 2002
@@ -0,0 +1,631 @@
+package DBI::ProfileData;
+use strict;
+
+=head1 NAME
+
+DBI::ProfileData - manipulate DBI::ProfileDumper data dumps
+
+=head1 SYNOPSIS
+
+The easiest way to use this module is through the dbi_prof frontend
+(see L<dbi_prof> for details):
+
+  dbi_prof --number 15 --sort count
+
+This module can also be used to roll your own profile analysis:
+
+  # load data from dbi.prof
+  $prof = DBI::ProfileData->new(File => "dbi.prof");
+
+  # get a count of the records in the data set
+  $count = $prof->count();
+
+  # sort by longest overall time
+  $prof->sort(field => "longest");
+
+  # sort by longest overall time, least to greatest
+  $prof->sort(field => "longest", reverse => 1);
+
+  # exclude records with key2 eq 'disconnect'
+  $prof->exclude(key2 => 'disconnect');
+
+  # exclude records with key1 matching /^UPDATE/i
+  $prof->exclude(key1 => qr/^UPDATE/i);
+
+  # remove all records except those where key1 matches /^SELECT/i
+  $prof->match(key1 => qr/^SELECT/i);
+
+  # produce a formatted report with the given number of items
+  $report = $prof->report(number => 10); 
+
+  # clone the profile data set
+  $clone = $prof->clone();
+
+  # get access to hash of header values
+  $header = $prof->header();
+
+  # get access to sorted array of nodes
+  $nodes = $prof->nodes();
+
+  # format a single node in the same style as report()
+  $text = $prof->format($nodes->[0]);
+
+  # get access to Data hash in DBI::Profile format
+  $Data = $prof->Data();
+
+=head1 DESCRIPTION
+
+This module offers the ability to read, manipulate and format
+DBI::ProfileDumper profile data.  
+
+Conceptually, a profile consists of a series of records, or nodes,
+each of each has a set of statistics and set of keys.  Each record
+must have a unique set of keys, but there is no requirement that every
+record have the same number of keys.
+
+=head1 METHODS
+
+The following methods are supported by DBI::ProfileData objects.
+
+=over 4
+
+=cut
+
+use vars qw($VERSION);
+$VERSION = "1.0";
+
+use Carp qw(croak);
+
+# some constants for use with node data arrays
+sub COUNT     () { 0 };
+sub TOTAL     () { 1 };
+sub FIRST     () { 2 };
+sub SHORTEST  () { 3 };
+sub LONGEST   () { 4 };
+sub FIRST_AT  () { 5 };
+sub LAST_AT   () { 6 };
+sub PATH      () { 7 };
+
+=item $prof = DBI::ProfileData->new(File => "dbi.prof")
+
+=item $prof = DBI::ProfileData->new(Files => [ "dbi.prof.1", "dbi.prof.2" ])
+
+Creates a a new DBI::ProfileData object.  Takes either a single file
+through the File option or a list of Files in an array ref.  If
+multiple files are specified then the header data from the first file
+is used.
+
+=cut
+
+sub new {
+    my $pkg = shift;
+    my $self = {                
+                Files        => [ "dbi.prof" ],
+                _header      => {},
+                _nodes       => [],
+                _node_lookup => {},
+                @_
+               };
+    bless $self, $pkg;
+    
+    # File overrides Files
+    $self->{Files} = [ $self->{File} ] if exists $self->{File};
+
+    $self->_read_files();
+    return $self;
+}
+
+# read files into _header and _nodes
+sub _read_files {
+    my $self = shift;
+    my $files = $self->{Files};
+    my $read_header = 0;
+    
+    foreach my $filename (@$files) {
+        open(my $fh, $filename)
+          or croak("Unable to read profile file '$filename': $!");
+        
+        $self->_read_header($fh, $filename, $read_header ? 0 : 1);
+        $read_header = 1;
+        $self->_read_body($fh, $filename);
+        close($fh);
+    }
+    
+    # discard node_lookup now that all files are read
+    delete $self->{_node_lookup};
+}
+
+# read the header from the given $fh named $filename.  Discards the
+# data unless $keep.
+sub _read_header {
+    my ($self, $fh, $filename, $keep) = @_;
+
+    # get profiler module id
+    my $first = <$fh>;
+    chomp $first;
+    $self->{_profiler} = $first if $keep;
+
+    # collect variables from the header
+    while (<$fh>) {
+        chomp;
+        last unless length $_;
+        /^(\S+)\s*=\s*(.*)/
+          or croak("Syntax error in profile file '$filename': line $.");
+        $self->{_header}{$1} = $2 if $keep;
+    }
+}
+
+# reads the body of the profile data
+sub _read_body {
+    my ($self, $fh, $filename) = @_;
+    my $nodes = $self->{_nodes};
+    my $lookup = $self->{_node_lookup};
+
+    # build up node array
+    my @path = ("");
+    my (@data, $index, $key, $path_key);
+    while (<$fh>) {
+        chomp;
+        if (/^\+\s+(\d+)\s(.*)/) {
+            # it's a key
+            ($key, $index) = ($2, $1 - 1);
+
+            # unmangle key
+            $key =~ s/\\n/\n/g;
+            $key =~ s/\\r/\r/g;
+            $key =~ s/\\\\/\\/g;
+
+            $#path = $index;      # truncate path to new length
+            $path[$index] = $key; # place new key at end
+
+        } else {
+            # it's data - file in the node array with the path in index 0
+            @data = /^=\s+(\d+)
+                       \s+(\d+\.\d+)
+                       \s+(\d+\.\d+)
+                       \s+(\d+\.\d+)
+                       \s+(\d+\.\d+)
+                       \s+(\d+\.\d+)
+                       \s+(\d+\.\d+)
+                       \s*$/x;
+
+            # no data?
+            croak("Syntax error in $filename : line $.") unless @data;
+
+            # elements of @path can't have NULLs in them, so this
+            # forms a unique string per @path.  If there's some way I
+            # can get this without arbitrarily stripping out a
+            # character I'd be happy to hear it!
+            $path_key = join("\0",@path);
+
+            # look for previous entry
+            if (exists $lookup->{$path_key}) {
+                # merge in the new data
+                $self->_merge_data($nodes->[$lookup->{$path_key}], \@data);
+            } else {
+                # insert a new node - nodes are arrays with data in 0-6
+                # and path data after that
+                push(@$nodes, [ @data, @path ]);
+
+                # record node in %seen
+                $lookup->{$path_key} = $#$nodes;
+            }
+        }
+    }
+}
+
+# takes an existing node and merges in new data points
+sub _merge_data {
+    my ($self, $node, $data) = @_;
+
+    # add counts and total duration
+    $node->[COUNT] += $data->[COUNT];
+    $node->[TOTAL] += $data->[TOTAL];
+    
+    # first duration untouched
+
+    # take new shortest duration if shorter
+    $node->[SHORTEST] = $data->[SHORTEST]
+      if $data->[SHORTEST] < $node->[SHORTEST];
+
+    # take new longest duration if longer
+    $node->[LONGEST] = $data->[LONGEST]
+      if $data->[LONGEST] > $node->[LONGEST];
+
+    # time of first event untouched
+
+    # take time of last event
+    $node->[LAST_AT] = $data->[LAST_AT];
+}
+
+
+
+=item $copy = $prof->clone();
+
+Clone a profile data set creating a new object.
+
+=cut
+
+sub clone {
+    my $self = shift;
+
+    # start with a simple copy
+    my $clone = bless { %$self }, ref($self);
+
+    # deep copy nodes
+    $clone->{_nodes}  = [ map { [ @$_ ] } @{$self->{_nodes}} ];
+
+    # deep copy header
+    $clone->{_header} = { %{$self->{_header}} };
+
+    return $clone;
+}
+
+=item $header = $prof->header();
+
+Returns a reference to a hash of header values.  These are the key
+value pairs included in the header section of the DBI::ProfileDumper
+data format.  For example:
+
+  $header = {
+              Path    => '[ DBIprofile_Statement, DBIprofile_MethodName ]',
+              Program => 't/42profile_data.t',
+            };
+
+Note that modifying this hash will modify the header data stored
+inside the profile object.
+
+=cut
+
+sub header { shift->{_header} }
+
+
+=item $nodes = $prof->nodes()
+
+Returns a reference the sorted nodes array.  Each element in the array
+is a single record in the data set.  The first seven elements are the
+same as the elements provided by DBI::Profile.  After that each key is
+in a separate element.  For example:
+
+ $nodes = [
+            [
+              2,                      # 0, count
+              0.0312958955764771,     # 1, total duration
+              0.000490069389343262,   # 2, first duration
+              0.000176072120666504,   # 3, shortest duration
+              0.00140702724456787,    # 4, longest duration
+              1023115819.83019,       # 5, time of first event
+              1023115819.86576,       # 6, time of last event
+              'SELECT foo FROM bar'   # 7, key1
+              'execute'               # 8, key2
+                                      # 6+N, keyN
+            ],
+                                      # ...
+          ];
+
+Note that modifying this array will modify the node data stored inside
+the profile object.
+
+=cut
+
+sub nodes { shift->{_nodes} }
+
+=item $count = $prof->count()
+
+Returns the number of items in the profile data set.
+
+=cut
+
+sub count { scalar @{shift->{_nodes}} }
+
+=item $prof->sort(field => "field")
+
+=item $prof->sort(field => "field", reverse => 1)
+
+Sorts data by the given field.  Available fields are:
+
+  longest
+  total
+  count
+  shortest
+
+The default sort is greatest to smallest, which is the opposite of the
+normal Perl meaning.  This, however, matches the expected behavior of
+the dbi_prof frontend.
+
+=cut
+
+
+# sorts data by one of the available fields
+{
+    my %FIELDS = (
+                  longest  => LONGEST,
+                  total    => TOTAL,
+                  count    => COUNT,
+                  shortest => SHORTEST,
+                 );
+    sub sort {
+        my $self = shift;
+        my $nodes = $self->{_nodes};
+        my %opt = @_;
+        
+        croak("Missing required field option.") unless $opt{field};
+
+        my $index = $FIELDS{$opt{field}};
+        
+        croak("Unrecognized sort field '$opt{field}'.")
+          unless defined $index;
+
+        # sort over index
+        if ($opt{reverse}) {
+            @$nodes = sort { 
+                $a->[$index] <=> $b->[$index] 
+            } @$nodes;
+        } else {
+            @$nodes = sort { 
+                $b->[$index] <=> $a->[$index] 
+            } @$nodes;
+        }
+
+        # remember how we're sorted
+        $self->{_sort} = $opt{field};
+
+        return $self;
+    }
+}
+
+=item $count = $prof->exclude(key2 => "disconnect")
+
+=item $count = $prof->exclude(key2 => "disconnect", case_sensitive => 1)
+
+=item $count = $prof->exclude(key1 => qr/^SELECT/i)
+
+Removes records from the data set that match the given string or
+regular expression.  This method modifies the data in a permanent
+fashion - use clone() first to maintain the original data after
+exclude().  Returns the number of nodes left in the profile data set.
+
+=cut
+
+sub exclude {
+    my $self = shift;
+    my $nodes = $self->{_nodes};
+    my %opt = @_;
+
+    # find key index number
+    my ($index, $val);
+    foreach (keys %opt) {
+        if (/^key(\d+)$/) {
+            $index   = PATH + $1 - 1;
+            $val     = $opt{$_};
+            last;
+        }
+    }
+    croak("Missing required keyN option.") unless $index;
+
+    if (UNIVERSAL::isa($val,"Regexp")) {
+        # regex match
+        @$nodes = grep {
+            $#$_ < $index or $_->[$index] !~ /$val/ 
+        } @$nodes;
+    } else {
+        if ($opt{case_sensitive}) {
+            @$nodes = grep { 
+                $#$_ < $index or $_->[$index] ne $val;
+            } @$nodes;
+        } else {
+            $val = lc $val;
+            @$nodes = grep { 
+                $#$_ < $index or lc($_->[$index]) ne $val;
+            } @$nodes;
+        }
+    }
+
+    return scalar @$nodes;
+}
+
+
+=item $count = $prof->match(key2 => "disconnect")
+
+=item $count = $prof->match(key2 => "disconnect", case_sensitive => 1)
+
+=item $count = $prof->match(key1 => qr/^SELECT/i)
+
+Removes records from the data set that do not match the given string
+or regular expression.  This method modifies the data in a permanent
+fashion - use clone() first to maintain the original data after
+match().  Returns the number of nodes left in the profile data set.
+
+=cut
+
+sub match {
+    my $self = shift;
+    my $nodes = $self->{_nodes};
+    my %opt = @_;
+
+    # find key index number
+    my ($index, $val);
+    foreach (keys %opt) {
+        if (/^key(\d+)$/) {
+            $index   = PATH + $1 - 1;
+            $val     = $opt{$_};
+            last;
+        }
+    }
+    croak("Missing required keyN option.") unless $index;
+
+    if (UNIVERSAL::isa($val,"Regexp")) {
+        # regex match
+        @$nodes = grep {
+            $#$_ >= $index and $_->[$index] =~ /$val/ 
+        } @$nodes;
+    } else {
+        if ($opt{case_sensitive}) {
+            @$nodes = grep { 
+                $#$_ >= $index and $_->[$index] eq $val;
+            } @$nodes;
+        } else {
+            $val = lc $val;
+            @$nodes = grep { 
+                $#$_ >= $index and lc($_->[$index]) eq $val;
+            } @$nodes;
+        }
+    }
+
+    return scalar @$nodes;
+}
+
+=item $Data = $prof->Data()
+
+Returns the same Data hash structure as seen in DBI::Profile.  This
+structure is not sorted.  The nodes() structure probably makes more
+sense for most analysis.
+
+=cut
+
+sub Data {
+    my $self = shift;
+    my (%Data, @data, $ptr);
+
+    foreach my $node (@{$self->{_nodes}}) {
+        # traverse to key location
+        $ptr = \%Data;
+        foreach my $key (@{$node}[PATH .. $#$node - 1]) {
+            $ptr->{$key} = {} unless exists $ptr->{$key};
+            $ptr = $ptr->{$key};
+        }
+
+        # slice out node data
+        $ptr->{$node->[-1]} = [ @{$node}[0 .. 6] ];
+    }
+
+    return \%Data;
+}
+
+=item $text = $prof->format($nodes->[0])
+
+Formats a single node into a human-readable block of text.
+
+=cut
+
+sub format {
+    my ($self, $node) = @_;
+    my $format;
+    
+    # setup keys
+    my $keys = "";
+    for (my $i = PATH; $i <= $#$node; $i++) {
+        my $key = $node->[$i];
+        
+        # remove leading and trailing space
+        $key =~ s/^\s+//;
+        $key =~ s/\s+$//;
+
+        # if key has newlines or is long take special precautions
+        if (length($key) > 72 or $key =~ /\n/) {
+            $keys .= "  Key " . ($i - PATH + 1) . "         :\n\n$key\n\n";
+        } else {
+            $keys .= "  Key " . ($i - PATH + 1) . "         : $key\n";
+        }
+    }
+
+    # nodes with multiple runs get the long entry format, nodes with
+    # just one run get a single count.
+    if ($node->[COUNT] > 1) {
+        $format = <<END;
+  Count         : %d
+  Total Time    : %3.6f seconds
+  Longest Time  : %3.6f seconds
+  Shortest Time : %3.6f seconds
+  Average Time  : %3.6f seconds
+END
+        return sprintf($format, @{$node}[COUNT,TOTAL,LONGEST,SHORTEST], 
+                       $node->[TOTAL] / $node->[COUNT]) . $keys;
+    } else {
+        $format = <<END;
+  Count         : %d
+  Time          : %3.6f seconds
+END
+
+        return sprintf($format, @{$node}[COUNT,TOTAL]) . $keys;
+
+    }
+}
+
+=item $text = $prof->report(number => 10)
+
+Produces a report with the given number of items.
+
+=cut
+
+sub report {
+    my $self  = shift;
+    my $nodes = $self->{_nodes};
+    my %opt   = @_;
+
+    croak("Missing required number option") unless exists $opt{number};
+
+    $opt{number} = @$nodes if @$nodes < $opt{number};
+
+    my $report = $self->_report_header($opt{number});
+    for (0 .. $opt{number} - 1) {
+        $report .= sprintf("#" x 5  . "[ %d ]". "#" x 59 . "\n", 
+                           $_ + 1);
+        $report .= $self->format($nodes->[$_]);
+        $report .= "\n";
+    }
+    return $report;
+}
+
+# format the header for report()
+sub _report_header {
+    my ($self, $number) = @_;
+    my $nodes = $self->{_nodes};
+    my $node_count = @$nodes;
+
+    # find total runtime and method count
+    my ($time, $count) = (0,0);
+    foreach my $node (@$nodes) {
+        $time  += $node->[TOTAL];
+        $count += $node->[COUNT];
+    }
+
+    my $header = <<END;
+
+DBI Profile Data ($self->{_profiler})
+
+END
+
+    # output header fields
+    while (my ($key, $value) = each %{$self->{_header}}) {
+        $header .= sprintf("  %-13s : %s\n", $key, $value);
+    }
+
+    # output summary data fields
+    $header .= sprintf(<<END, $node_count, $number, $self->{_sort}, $count, $time);
+  Total Records : %d (showing %d, sorted by %s)
+  Total Count   : %d
+  Total Runtime : %3.6f seconds  
+
+END
+
+    return $header;
+}
+
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=cut
diff -Naur DBI-1.30/lib/DBI/ProfileDumper/Apache.pm DBI/lib/DBI/ProfileDumper/Apache.pm
--- DBI-1.30/lib/DBI/ProfileDumper/Apache.pm	Wed Dec 31 19:00:00 1969
+++ DBI/lib/DBI/ProfileDumper/Apache.pm	Wed Oct 16 14:16:27 2002
@@ -0,0 +1,135 @@
+package DBI::ProfileDumper::Apache;
+
+=head1 NAME
+
+DBI::ProfileDumper::Apache - capture DBI profiling data from Apache/mod_perl
+
+=head1 SYNOPSIS
+
+Add this line to your F<httpd.conf>:
+
+  PerlSetEnv DBI_PROFILE DBI::ProfileDumper::Apache
+
+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<dbi_prof|dbi_prof>:
+
+  dbi_prof /usr/local/apache/logs/dbi.prof.*
+
+When you're ready to perform another profiling run, delete the old
+files
+
+  rm /usr/local/apache/logs/dbi.prof.*
+
+and start again.
+
+=head1 DESCRIPTION
+
+This module interfaces DBI::ProfileDumper to Apache/mod_perl.  Using
+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 dbi_prof to analyze the profile files.
+
+=head1 USAGE
+
+=head2 LOADING THE MODULE
+
+The easiest way to use this module is just to set the DBI_PROFILE
+environment variable in your F<httpd.conf>:
+
+  PerlSetEnv DBI_PROFILE 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
+
+It's also possible to use this module by setting the Profile attribute
+of any DBI handle:
+
+  $dbh->{Profile} = "DBI::ProfileDumper::Apache";
+
+See L<DBI::ProfileDumper> for more possibilities.
+
+=head2 GATHERING PROFILE DATA
+
+Once you have the module loaded, use your application as you normally
+would.  Stop the webserver when your tests are complete.  Profile data
+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
+
+Now you can use dbi_prof to examine the data:
+
+  dbi_prof /usr/local/apache/logs/dbi.prof.*
+
+By passing dbi_prof a list of all generated files, dbi_prof will
+automatically merge them into one result set.  You can also pass
+dbi_prof sorting and querying options, see L<dbi_prof> for details.
+
+=head2 CLEANING UP
+
+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.* 
+
+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:
+
+  $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.
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=cut
+
+use vars qw($VERSION @ISA);
+$VERSION = "1.0";
+@ISA = qw(DBI::ProfileDumper);
+use DBI::ProfileDumper;
+use Apache;
+use File::Spec;
+
+# Override flush_to_disk() to setup File just in time for output.
+# Overriding new() would work unless the user creates a DBI handle
+# during server startup, in which case all the children would try to
+# write to the same file.
+sub flush_to_disk {
+    my $self = shift;
+    
+    # setup File per process
+    my $path = Apache->server_root_relative("logs/");
+    my $old_file = $self->{File};
+    $self->{File} = File::Spec->catfile($path, "$old_file.$$");
+
+    # 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;    
+}
+
+1;
diff -Naur DBI-1.30/lib/DBI/ProfileDumper.pm DBI/lib/DBI/ProfileDumper.pm
--- DBI-1.30/lib/DBI/ProfileDumper.pm	Wed Dec 31 19:00:00 1969
+++ DBI/lib/DBI/ProfileDumper.pm	Wed Oct 16 14:16:27 2002
@@ -0,0 +1,270 @@
+package DBI::ProfileDumper;
+use strict;
+
+=head1 NAME
+
+DBI::ProfileDumper - profile DBI usage and output data to a file
+
+=head1 SYNOPSIS
+
+To profile an existing program using DBI::ProfileDumper, set the
+DBI_PROFILE environment variable and run your program as usual.  For
+example, using bash:
+
+  DBI_PROFILE=DBI::ProfileDumper program.pl
+
+Then analyze the generated file (F<dbi.prof>) with L<dbi_prof|dbi_prof>:
+
+  dbi_prof
+
+You can also activate DBI::ProfileDumper from within your code:
+
+  use DBI;
+
+  # profile with default path (2) and output file (dbi.prof)
+  $dbh->{Profile} = "DBI::ProfileDumper";
+
+  # same thing, spelled out
+  $dbh->{Profile} = "2/DBI::ProfileDumper/File/dbi.prof";
+
+  # another way to say it
+  use DBI::Profile qw(DBIprofile_Statement);
+  $dbh->{Profile} = DBI::ProfileDumper->new(
+                      { Path => [ DBIprofile_Statement ]
+                        File => 'dbi.prof' });
+
+  # using a custom path
+  $dbh->{Profile} = DBI::ProfileDumper->new({ Path => [ "foo", "bar" ],
+                                              File => 'dbi.prof' });
+
+
+=head1 DESCRIPTION
+
+DBI::ProfileDumper is a subclass of L<DBI::Profile|DBI::Profile> which
+dumps profile data to disk instead of printing a summary to your
+screen.  You can then use L<dbi_prof|dbi_prof> to analyze the data in
+a number of interesting ways, or you can roll your own analysis using
+L<DBI::ProfileData|DBI::ProfileData>.
+
+B<NOTE:> For Apache/mod_perl applications, use
+L<DBI::ProfileDumper::Apache|DBI::ProfileDumper::Apache>.
+
+=head1 USAGE
+
+One way to use this module is just to enable it in your C<$dbh>:
+
+  $dbh->{Profile} = "DBI::ProfileDumper";
+
+This will write out profile data by statement into a file called
+F<dbi.prof>.  If you want to modify either of these properties, you
+can construct the DBI::ProfileDumper object yourself:
+
+  use DBI::Profile qw(DBIprofile_Statement);
+  $dbh->{Profile} = DBI::ProfileDumper->new(
+                      { Path => [ DBIprofile_Statement ]
+                        File => 'dbi.prof' });
+
+The C<Path> option takes the same values as in
+L<DBI::Profile|DBI:Profile>.  The C<File> option gives the name of the
+file where results will be collected.  If it already exists it will be
+overwritten.
+
+You can also activate this module by setting the DBI_PROFILE
+environment variable:
+
+  $ENV{DBI_PROFILE} = "DBI::ProfileDumper";
+
+This will cause all DBI handles to share the same profiling object.
+
+=head1 METHODS
+
+The following methods are available to be called using the profile
+object.  You can get access to the profile object from the Profile key
+in any DBI handle:
+
+  my $profile = $dbh->{Profile};
+
+=over 4
+
+=item $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()
+
+Clears the Data hash without writing to disk.
+
+=back
+
+=head1 DATA FORMAT
+
+The data format written by DBI::ProfileDumper starts with a header
+containing the version number of the module used to generate it.  Then
+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
+  Path = [ DBIprofile_Statement, DBIprofile_MethodName ]
+  Program = t/42profile_data.t
+  
+  + 1 SELECT name FROM users WHERE id = ?
+  + 2 prepare
+  = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+  + 2 execute
+  1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+  + 2 fetchrow_hashref
+  = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+  + 1 UPDATE users SET name = ? WHERE id = ?
+  + 2 prepare
+  = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+  + 2 execute
+  = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
+
+The lines beginning with C<+> signs signify keys.  The number after
+the C<+> sign shows the nesting level of the key.  Lines beginning
+with C<=> are the actual profile data, in the same order as
+in DBI::Profile.
+
+Note that the same path may be present multiple times in the data file
+since C<format()> may be called more than once.  When read by
+DBI::ProfileData the data points will be merged to produce a single
+data set for each distinct path.
+
+The key strings are transformed in three ways.  First, all backslashes
+are doubled.  Then all newlines and carriage-returns are transformed
+into C<\n> and C<\r> respectively.  Finally, any NULL bytes (C<\0>)
+are entirely removed.  When DBI::ProfileData reads the file the first
+two transformations will be reversed, but NULL bytes will not be
+restored.
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=cut
+
+# inherit from DBI::Profile
+use DBI::Profile;
+use vars qw(@ISA $VERSION);
+@ISA = ("DBI::Profile");
+$VERSION = "1.0";
+
+use Carp qw(croak);
+
+# 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};
+
+    return $self;
+}
+
+# flush available data to disk
+sub flush_to_disk {
+    my $self = shift;
+    my $data = $self->{Data};
+
+    my $fh;
+    if ($self->{_wrote_header}) {
+        # append more data to the file
+        open($fh, ">>$self->{File}") 
+          or croak("Unable to open '$self->{File}' 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: $!");
+        $self->write_header($fh);
+        $self->{_wrote_header} = 1;
+    }
+
+    $self->write_data($fh, $self->{Data}, 1);
+
+    close($fh) or croak("Unable to close '$self->{File}': $!");
+
+    $self->empty();
+}
+
+# empty out profile data
+sub empty {
+    shift->{Data} = {};
+}
+
+# write header to a filehandle
+sub write_header {
+    my ($self, $fh) = @_;
+
+    # module name and version number
+    print $fh ref($self), " ", $self->VERSION, "\n";
+
+    # print out Path
+    my @path_words;
+    foreach (@{$self->{Path}}) {
+        if ($_ eq DBI::Profile::DBIprofile_Statement) {
+            push @path_words, "DBIprofile_Statement";
+        } elsif ($_ eq DBI::Profile::DBIprofile_MethodName) {
+            push @path_words, "DBIprofile_MethodName";
+        } elsif ($_ eq DBI::Profile::DBIprofile_MethodClass) {
+            push @path_words, "DBIprofile_MethodClass";
+        } else {
+            push @path_words, $_;
+        }
+    }
+    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";
+
+    # all done
+    print $fh "\n";
+}
+
+# write data in the proscribed format
+sub write_data {
+    my ($self, $fh, $data, $level) = @_;
+
+    # produce an empty profile for invalid $data
+    return unless $data and UNIVERSAL::isa($data,'HASH');
+    
+    while (my ($key, $value) = each(%$data)) {
+        # output a key
+        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;
+        } else {
+            # recurse through keys - this could be rewritten to use a
+            # stack for some small performance gain
+            $self->write_data($fh, $value, $level + 1);
+        }
+    }
+}
+
+# quote a key for output
+sub quote_key {
+    my $key = shift;
+    $key =~ s!\\!\\\\!g;
+    $key =~ s!\n!\\n!g;
+    $key =~ s!\r!\\r!g;
+    $key =~ s!\0!!g;
+    return $key;
+}
+
+# flush data to disk when profile object goes out of scope
+sub on_destroy {
+    shift->flush_to_disk();
+}
+
+1;
diff -Naur DBI-1.30/t/40profile.t DBI/t/40profile.t
--- DBI-1.30/t/40profile.t	Thu Jun 13 08:28:28 2002
+++ DBI/t/40profile.t	Wed Oct  9 14:56:48 2002
@@ -1,61 +1,190 @@
 #!perl -w
-
 use strict;
-use Test;
+
+#
+# test script for DBI::Profile
+# 
+# TODO:
+#
+# - fix dbi_profile, see below for test that produces a warning
+#   and doesn't work as expected
+# 
+# - add tests for the undocumented dbi_profile_merge
+#
 
 use DBI;
 use DBI::Profile;
 
 BEGIN {
-
     if ($DBI::PurePerl) {
 	print "1..0 # Skipped: profiling not supported for DBI::PurePerl\n";
 	exit 0;
     }
-
-    plan tests => 6;
 }
 
-#
-#	XXX These tests are very poor!
-#
+use Test;
+BEGIN { plan tests => 54; }
 
 use Data::Dumper;
 $Data::Dumper::Indent = 1;
 $Data::Dumper::Terse = 1;
 
-my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, AutoCommit=>1, });
-ok($dbh);
+# log file to store profile results 
+my $LOG_FILE = "profile.log";
+DBI->trace(0, $LOG_FILE);
+END { unlink $LOG_FILE; }
 
+# make sure profiling starts disabled
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+ok($dbh);
 ok(!$dbh->{Profile} && !$ENV{DBI_PROFILE});
+undef $dbh;
 
+# can turn it on after the fact using a path number
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
 $dbh->{Profile} = "4";
-my $profile = $dbh->{Profile};
+ok(ref $dbh->{Profile}, "DBI::Profile");
+ok(ref $dbh->{Profile}{Data}, 'HASH');
+ok(ref $dbh->{Profile}{Path}, 'ARRAY');
+undef $dbh;
 
+# using a package name
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+$dbh->{Profile} = "DBI::Profile";
 ok(ref $dbh->{Profile}, "DBI::Profile");
-ok(ref $profile->{Data}, 'HASH');
-ok(ref $profile->{Path}, 'ARRAY');
+ok(ref $dbh->{Profile}{Data}, 'HASH');
+ok(ref $dbh->{Profile}{Path}, 'ARRAY');
+undef $dbh;
 
-#warn Dumper($profile);
+# using a combined path and name
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+$dbh->{Profile} = "2/DBI::Profile";
+ok(ref $dbh->{Profile}, "DBI::Profile");
+ok(ref $dbh->{Profile}{Data}, 'HASH');
+ok(ref $dbh->{Profile}{Path}, 'ARRAY');
+undef $dbh;
+
+# can turn it on at connect
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>2 });
+ok(ref $dbh->{Profile}, "DBI::Profile");
+ok(ref $dbh->{Profile}{Data}, 'HASH');
+ok(ref $dbh->{Profile}{Path}, 'ARRAY');
 
-my $sth = $dbh->prepare("select mode,size,name from ?");
+# do a little work
+my $sql = "select mode,size,name from ?";
+my $sth = $dbh->prepare($sql);
 $sth->execute(".");
-#$profile->{Path} = [ "foo", DBIprofile_Statement, DBIprofile_MethodName ];
-while ( my $hash = $sth->fetchrow_hashref ) {
-}
-#warn Dumper($profile);
+while ( my $hash = $sth->fetchrow_hashref ) {}
 
-my $logfile = "profile.log";
-unlink $logfile;
-DBI->trace(0, $logfile);
-
-# --- force DESTROY to force output of profile results
-undef $profile;
-undef $sth;
-undef $dbh;
-DBI->trace(0, undef); # force close of log file for Windows
+print Dumper($dbh->{Profile});
+
+# check that the proper key was set in Data
+my $data = $dbh->{Profile}{Data}{$sql};
+ok($data);
+ok(ref $data, 'ARRAY');
+ok(@$data == 7);
+my ($count, $total, $first, $shortest, $longest, $time1, $time2) = @$data;
+ok($count > 3);
+ok($total > 0);
+ok($first > 0);
+ok($shortest > 0);
+ok($longest > 0);
+ok($longest > $shortest);
+ok($time1 > 0);
+ok($time2 > 0);
+ok(time + 1 > $time1);
+ok(time + 1 > $time2);
+ok($time1 <= $time2);
+
+# collect output
+my $output = $dbh->{Profile}->format();
+print "Profile Output\n\n$output";
+
+# check that output was produced in the expected format
+ok(length $output);
+ok($output =~ /^DBI::Profile:/);
+ok($output =~ /\((\d+) method calls\)/);
+ok($1 >= $count);
+
+# try statement and method name path
+$dbh = DBI->connect("dbi:ExampleP:", '', '', 
+                    { RaiseError => 1, 
+                      Profile    => 6 });
+ok(ref $dbh->{Profile}, "DBI::Profile");
+ok(ref $dbh->{Profile}{Data}, 'HASH');
+ok(ref $dbh->{Profile}{Path}, 'ARRAY');
+
+# do a little work
+$sql = "select name from .";
+$sth = $dbh->prepare($sql);
+$sth->execute();
+while ( my $hash = $sth->fetchrow_hashref ) {}
+
+# check that the resulting tree fits the expected layout
+$data = $dbh->{Profile}{Data};
+ok($data);
+ok(exists $data->{$sql});
+ok(keys %{$data->{$sql}} == 3);
+ok(exists $data->{$sql}{prepare});
+ok(exists $data->{$sql}{execute});
+ok(exists $data->{$sql}{fetchrow_hashref});
+
+
+
+# try a custom path
+$dbh = DBI->connect("dbi:ExampleP:", '', '', 
+                    { RaiseError=>1, 
+                      Profile=> { Path => [ 'foo',
+                                            DBIprofile_Statement, 
+                                            DBIprofile_MethodName, 
+                                            'bar' ]}});
+ok(ref $dbh->{Profile}, "DBI::Profile");
+ok(ref $dbh->{Profile}{Data}, 'HASH');
+ok(ref $dbh->{Profile}{Path}, 'ARRAY');
+
+# do a little work
+$sql = "select name from .";
+$sth = $dbh->prepare($sql);
+$sth->execute();
+while ( my $hash = $sth->fetchrow_hashref ) {}
+
+# check that the resulting tree fits the expected layout
+$data = $dbh->{Profile}{Data};
+ok($data);
+ok(exists $data->{foo});
+ok(exists $data->{foo}{$sql});
+ok(exists $data->{foo}{$sql}{prepare});
+ok(exists $data->{foo}{$sql}{execute});
+ok(exists $data->{foo}{$sql}{fetchrow_hashref});
+ok(exists $data->{foo}{$sql}{prepare}{bar});
+ok(ref $data->{foo}{$sql}{prepare}{bar}, 'ARRAY');
+ok(@{$data->{foo}{$sql}{prepare}{bar}} == 7);
+
+
+
+##########################################################################
+#
+# FIXME 
+#
+# This test produces the warning:
+#
+#   Profile attribute isn't a hash ref (DBI::Profile=HASH(0x831046c),7)
+#   at t/40profile.t line 130.
+#
+# It seems that $dbh->{Profile} is not an SVt_PVHV as DBI.xs expects
+# at line 1828.
+#
+#
+##########################################################################
+
+if (0) {
+    use Time::HiRes qw(gettimeofday);
+    my $t1 = gettimeofday;
+    dbi_profile($dbh, "Hi, mom", "fetchhash_bang", $t1, $t1 + 1);
+    ok(exists $data->{foo}{"Hi, mom"});
+}
 
-ok(-s $logfile);
-unlink $logfile;
+# check that output went into the log file
+ok(-s $LOG_FILE);
 
 exit 0;
diff -Naur DBI-1.30/t/41profile_dumper.t DBI/t/41profile_dumper.t
--- DBI-1.30/t/41profile_dumper.t	Wed Dec 31 19:00:00 1969
+++ DBI/t/41profile_dumper.t	Fri Oct 11 01:16:10 2002
@@ -0,0 +1,60 @@
+#!perl -w
+use strict;
+
+#
+# test script for DBI::ProfileDumper
+# 
+
+use DBI;
+use DBI::ProfileDumper;
+
+BEGIN {
+    if ($DBI::PurePerl) {
+	print "1..0 # Skipped: profiling not supported for DBI::PurePerl\n";
+	exit 0;
+    }
+}
+
+use Test;
+BEGIN { plan tests => 7; }
+
+use Data::Dumper;
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Terse = 1;
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', 
+                       { RaiseError=>1, Profile=>"DBI::ProfileDumper" });
+ok(ref $dbh->{Profile}, "DBI::ProfileDumper");
+ok(ref $dbh->{Profile}{Data}, 'HASH');
+ok(ref $dbh->{Profile}{Path}, 'ARRAY');
+
+# do a little work
+my $sql = "select mode,size,name from ?";
+my $sth = $dbh->prepare($sql);
+$sth->execute(".");
+
+$sth->{Profile}->flush_to_disk();
+while ( my $hash = $sth->fetchrow_hashref ) {}
+
+# force output
+undef $sth;
+undef $dbh;
+
+# wrote the profile to disk?
+ok(-s "dbi.prof");
+
+open(PROF, "dbi.prof") or die $!;
+my $prof = join('', <PROF>);
+close PROF;
+
+# has a header?
+ok($prof =~ /^DBI::ProfileDumper\s+([\d.]+)/);
+
+# version matches VERSION?
+ok($1, $DBI::ProfileDumper::VERSION);
+
+# check that expected key is there
+ok($prof =~ /\+\s+1\s+\Q$sql\E/m);
+
+unlink("dbi.prof");
+
diff -Naur DBI-1.30/t/42profile_data.t DBI/t/42profile_data.t
--- DBI-1.30/t/42profile_data.t	Wed Dec 31 19:00:00 1969
+++ DBI/t/42profile_data.t	Wed Oct 16 14:16:28 2002
@@ -0,0 +1,82 @@
+#!perl -w
+use strict;
+
+#
+# test script for DBI::ProfileData
+# 
+
+use DBI;
+use DBI::ProfileDumper;
+use DBI::ProfileData;
+
+BEGIN {
+    if ($DBI::PurePerl) {
+	print "1..0 # Skipped: profiling not supported for DBI::PurePerl\n";
+	exit 0;
+    }
+}
+
+use Test;
+BEGIN { plan tests => 15; }
+
+use Data::Dumper;
+$Data::Dumper::Indent = 1;
+$Data::Dumper::Terse = 1;
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', 
+                       { RaiseError=>1, Profile=>"6/DBI::ProfileDumper" });
+
+# do a little work
+my $sql = "select mode,size,name from ?";
+my $sth = $dbh->prepare($sql);
+$sth->execute(".");
+while ( my $hash = $sth->fetchrow_hashref ) {}
+
+# force output
+undef $sth;
+undef $dbh;
+
+# wrote the profile to disk?
+ok(-s "dbi.prof");
+
+# load up
+my $prof = DBI::ProfileData->new();
+ok($prof);
+ok(ref $prof eq 'DBI::ProfileData');
+
+ok($prof->count() >= 3);
+
+# try a few sorts
+my $nodes = $prof->nodes;
+$prof->sort(field => "longest");
+my $longest = $nodes->[0][4];
+ok($longest);
+$prof->sort(field => "longest", reverse => 1);
+ok($nodes->[0][4] < $longest);
+
+$prof->sort(field => "count");
+my $most = $nodes->[0];
+ok($most);
+$prof->sort(field => "count", reverse => 1);
+ok($nodes->[0][0] < $most->[0]);
+
+# remove the top count and make sure it's gone
+my $clone = $prof->clone();
+$clone->sort(field => "count");
+ok($clone->exclude(key1 => $most->[7]));
+ok($clone->nodes()->[0][0] != $most->[0]);
+
+# there can only be one
+$clone = $prof->clone();
+ok($clone->match(key1 => $clone->nodes->[0][7]));
+ok($clone->match(key2 => $clone->nodes->[0][8]));
+ok($clone->count == 1);
+
+# take a look through Data
+my $Data = $prof->Data;
+ok(exists($Data->{$sql}));
+ok(exists($Data->{$sql}{execute}));
+
+# cleanup
+unlink("dbi.prof");
+

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About