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