1 files changed, 105 insertions, 0 deletions
diff --git a/t/41prof_dump.t b/t/41prof_dump.t
new file mode 100644
index 0000000..c921893
--- /dev/null
+++ b/t/41prof_dump.t
@@ -0,0 +1,105 @@
+#!perl -wl
+# Using -l to ensure ProfileDumper is isolated from changes to $/ and $\ and such
+
+$|=1;
+
+use strict;
+
+#
+# test script for DBI::ProfileDumper
+# 
+
+use DBI;
+use Config;
+use Test::More;
+
+BEGIN {
+    plan skip_all => 'profiling not supported for DBI::PurePerl'
+        if $DBI::PurePerl;
+
+    # clock instability on xen systems is a reasonably common cause of failure
+    # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html
+    # so we'll skip automated testing on those systems
+    plan skip_all => "skipping profile tests on xen (due to clock instability)"
+        if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64
+        and $ENV{AUTOMATED_TESTING};
+
+    plan tests => 15;
+}
+
+BEGIN {
+    use_ok( 'DBI' );
+    use_ok( 'DBI::ProfileDumper' );
+}
+
+my $prof_file   = "dbi$$.prof";
+my $prof_backup = $prof_file . ".prev";
+END { 1 while unlink $prof_file;
+      1 while unlink $prof_backup; }
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', 
+                       { RaiseError=>1, Profile=>"2/DBI::ProfileDumper/File:$prof_file" });
+isa_ok( $dbh, 'DBI::db' );
+isa_ok( $dbh->{Profile}, "DBI::ProfileDumper" );
+isa_ok( $dbh->{Profile}{Data}, 'HASH' );
+isa_ok( $dbh->{Profile}{Path}, 'ARRAY' );
+
+# do a little work
+my $sql = "select mode,size,name from ?";
+my $sth = $dbh->prepare($sql);
+isa_ok( $sth, 'DBI::st' );
+$sth->execute(".");
+
+# check that flush_to_disk doesn't change Path if Path is undef (it
+# did before 1.49)
+{ 
+    local $dbh->{Profile}->{Path} = undef;
+    $sth->{Profile}->flush_to_disk();
+    is($dbh->{Profile}->{Path}, undef);
+}
+
+$sth->{Profile}->flush_to_disk();
+while ( my $hash = $sth->fetchrow_hashref ) {}
+
+# force output
+undef $sth;
+$dbh->disconnect;
+undef $dbh;
+
+# wrote the profile to disk?
+ok( -s $prof_file, 'Profile is on disk and nonzero size' );
+
+# XXX We're breaking encapsulation here
+open(PROF, $prof_file) or die $!;
+my @prof = <PROF>;
+close PROF;
+
+print @prof;
+
+# has a header?
+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)
+$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');
+
+# check that expected key is there
+like(join('', @prof), qr/\+\s+1\s+\Q$sql\E/m);
+
+# unlink($prof_file); # now done by 'make clean'
+
+# should be able to load DBI::ProfileDumper::Apache outside apache
+# this also naturally checks for syntax errors etc.
+SKIP: {
+    skip "developer-only test", 1
+        unless (-d ".svn" || -d ".git") && -f "MANIFEST.SKIP";
+    skip "Apache module not installed", 1
+        unless eval { require Apache };
+    require_ok('DBI::ProfileDumper::Apache')
+}
+
+1;