1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
#!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 Test::More;
BEGIN {
if ($DBI::PurePerl) {
plan skip_all => 'profiling not supported for DBI::PurePerl';
}
else {
plan tests => 15;
}
}
BEGIN {
use_ok( 'DBI' );
use_ok( 'DBI::ProfileDumper' );
}
my $dbh = DBI->connect("dbi:ExampleP:", '', '',
{ RaiseError=>1, Profile=>"2/DBI::ProfileDumper" });
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 "dbi.prof", 'Profile is on disk and nonzero size' );
# XXX We're breaking encapsulation here
open(PROF, "dbi.prof") 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("dbi.prof"); # 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" && -f "MANIFEST.SKIP";
skip "Apache module not installed", 1
unless eval { require Apache };
require_ok('DBI::ProfileDumper::Apache')
}
1;
|
