diff options
Diffstat (limited to 't/41prof_dump.t')
-rw-r--r-- | t/41prof_dump.t | 105 |
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; |