1#!perl -w 2$|=1; 3 4use strict; 5 6use DBI; 7use Config; 8use Test::More; 9use Data::Dumper; 10 11BEGIN { 12 plan skip_all => 'profiling not supported for DBI::PurePerl' 13 if $DBI::PurePerl; 14 15 # clock instability on xen systems is a reasonably common cause of failure 16 # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html 17 # so we'll skip automated testing on those systems 18 plan skip_all => "skipping profile tests on xen (due to clock instability)" 19 if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64 20 and $ENV{AUTOMATED_TESTING}; 21 22 plan tests => 31; 23} 24 25BEGIN { 26 use_ok( 'DBI::ProfileDumper' ); 27 use_ok( 'DBI::ProfileData' ); 28} 29 30my $sql = "select mode,size,name from ?"; 31 32my $prof_file = "dbi$$.prof"; 33my $prof_backup = $prof_file . ".prev"; 34END { 1 while unlink $prof_file; 35 1 while unlink $prof_backup; } 36 37my $dbh = DBI->connect("dbi:ExampleP:", '', '', 38 { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" }); 39isa_ok( $dbh, 'DBI::db', 'Created connection' ); 40 41require DBI::Profile; 42DBI::Profile->import(qw(dbi_time)); 43 44# do enough work to avoid 0's on systems that are very fast or have low res timers 45my $t1 = dbi_time(); 46foreach (1..20) { 47 $dbh->do("set dummy=$_"); 48 my $sth = $dbh->prepare($sql); 49 for my $loop (1..90) { 50 $sth->execute("."); 51 $sth->fetchrow_hashref; 52 $sth->finish; 53 } 54 $sth->{Profile}->flush_to_disk(); 55} 56$dbh->disconnect; 57undef $dbh; 58my $t2 = dbi_time(); 59note sprintf "DBI work done in %fs (%f - %f)", $t2-$t1, $t2, $t1; 60 61 62# wrote the profile to disk? 63ok(-s $prof_file, "Profile written to disk, non-zero size" ); 64 65# load up 66my $prof = DBI::ProfileData->new( 67 File => $prof_file, 68 Filter => sub { 69 my ($path_ref, $data_ref) = @_; 70 $path_ref->[0] =~ s/set dummy=\d/set dummy=N/; 71 }, 72); 73isa_ok( $prof, 'DBI::ProfileData' ); 74cmp_ok( $prof->count, '>=', 3, 'At least 3 profile data items' ); 75 76# try a few sorts 77my $nodes = $prof->nodes; 78$prof->sort(field => "longest"); 79my $longest = $nodes->[0][4]; 80ok($longest); 81$prof->sort(field => "longest", reverse => 1); 82cmp_ok( $nodes->[0][4], '<', $longest ); 83 84$prof->sort(field => "count"); 85my $most = $nodes->[0]; 86ok($most); 87$prof->sort(field => "count", reverse => 1); 88cmp_ok( $nodes->[0][0], '<', $most->[0] ); 89 90# remove the top count and make sure it's gone 91my $clone = $prof->clone(); 92isa_ok( $clone, 'DBI::ProfileData' ); 93$clone->sort(field => "count"); 94ok($clone->exclude(key1 => $most->[7])); 95 96# compare keys of the new first element and the old one to make sure 97# exclude works 98ok($clone->nodes()->[0][7] ne $most->[7] && 99 $clone->nodes()->[0][8] ne $most->[8]); 100 101# there can only be one 102$clone = $prof->clone(); 103isa_ok( $clone, 'DBI::ProfileData' ); 104ok($clone->match(key1 => $clone->nodes->[0][7])); 105ok($clone->match(key2 => $clone->nodes->[0][8])); 106ok($clone->count == 1); 107 108# take a look through Data 109my $Data = $prof->Data; 110print "SQL: $_\n" for keys %$Data; 111ok(exists($Data->{$sql}), "Data for '$sql' should exist") 112 or print Dumper($Data); 113ok(exists($Data->{$sql}{execute}), "Data for '$sql'->{execute} should exist"); 114 115# did the Filter convert set dummy=1 (etc) into set dummy=N? 116ok(exists($Data->{"set dummy=N"})); 117 118# test escaping of \n and \r in keys 119$dbh = DBI->connect("dbi:ExampleP:", '', '', 120 { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" }); 121isa_ok( $dbh, 'DBI::db', 'Created connection' ); 122 123my $sql2 = 'select size from . where name = "LITERAL: \r\n"'; 124my $sql3 = "select size from . where name = \"EXPANDED: \r\n\""; 125 126# do a little work 127foreach (1,2,3) { 128 my $sth2 = $dbh->prepare($sql2); 129 isa_ok( $sth2, 'DBI::st' ); 130 $sth2->execute(); 131 $sth2->fetchrow_hashref; 132 $sth2->finish; 133 my $sth3 = $dbh->prepare($sql3); 134 isa_ok( $sth3, 'DBI::st' ); 135 $sth3->execute(); 136 $sth3->fetchrow_hashref; 137 $sth3->finish; 138} 139$dbh->disconnect; 140undef $dbh; 141 142# load dbi.prof 143$prof = DBI::ProfileData->new( File => $prof_file, DeleteFiles => 1 ); 144isa_ok( $prof, 'DBI::ProfileData' ); 145 146ok(not(-e $prof_file), "file should be deleted when DeleteFiles set" ); 147 148 149# make sure the keys didn't get garbled 150$Data = $prof->Data; 151ok(exists $Data->{$sql2}, "Data for '$sql2' should exist") 152 or print Dumper($Data); 153ok(exists $Data->{$sql3}, "Data for '$sql3' should exist") 154 or print Dumper($Data); 155 1561; 157