#!perl -w
$|=1;
#
# test script for DBI::Profile
#
use strict;
use Config;
use DBI::Profile;
use DBI qw(dbi_time);
use Data::Dumper;
use File::Spec;
use Storable qw(dclone);
use Test::More;
BEGIN {
plan skip_all => "profiling not supported for DBI::PurePerl"
if $DBI::PurePerl;
# tie methods (STORE/FETCH etc) get called different number of times
plan skip_all => "test results assume perl >= 5.8.2"
if $] <= 5.008001;
# 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 => 60;
}
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
# log file to store profile results
my $LOG_FILE = "profile$$.log";
my $orig_dbi_debug = $DBI::dbi_debug;
DBI->trace($DBI::dbi_debug, $LOG_FILE);
END {
return if $orig_dbi_debug;
1 while unlink $LOG_FILE;
}
print "Test enabling the profile\n";
# make sure profiling starts disabled
my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
ok($dbh, 'connect');
ok(!$dbh->{Profile} && !$ENV{DBI_PROFILE}, 'Profile and DBI_PROFILE not set');
# can turn it on after the fact using a path number
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "4";
is_deeply sanitize_tree($dbh->{Profile}), bless {
'Path' => [ '!MethodName' ],
} => 'DBI::Profile';
# using a package name
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "/DBI::Profile";
is_deeply sanitize_tree($dbh->{Profile}), bless {
'Path' => [ ],
} => 'DBI::Profile';
# using a combined path and name
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "20/DBI::Profile";
is_deeply sanitize_tree($dbh->{Profile}), bless {
'Path' => [ '!MethodName', '!Caller2' ],
} => 'DBI::Profile';
my $t_file = __FILE__;
$dbh->do("set foo=1"); my $line = __LINE__;
my $expected_caller = "40profile.t line $line";
$expected_caller .= " via ${1}40profile.t line 4"
if $0 =~ /(zv\w+_)/;
print Dumper($dbh->{Profile});
is_deeply sanitize_tree($dbh->{Profile}), bless {
'Path' => [ '!MethodName', '!Caller2' ],
'Data' => { 'do' => {
$expected_caller => [ 1, 0, 0, 0, 0, 0, 0 ]
} }
} => 'DBI::Profile'
or warn Dumper $dbh->{Profile};
# can turn it on at connect
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>6 });
is_deeply $dbh->{Profile}{Path}, [ '!Statement', '!MethodName' ];
cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 1, 'on at connect, 1 key');
cmp_ok(keys %{ $dbh->{Profile}{Data}{""} }, '>=', 1, 'on at connect, 1 key'); # at least STORE
ok(ref $dbh->{Profile}{Data}{""}{STORE}, 'STORE is ref');
print "dbi_profile\n";
# Try to avoid rounding problem on double precision systems
# $got->[5] = '1150962858.01596498'
# $expected->[5] = '1150962858.015965'
# by treating as a string (because is_deeply stringifies)
my $t1 = DBI::dbi_time() . "";
my $dummy_statement = "Hi mom";
my $dummy_methname = "my_method_name";
my $leaf = dbi_profile($dbh, $dummy_statement, $dummy_methname, $t1, $t1 + 1);
print Dumper($dbh->{Profile});
cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 2, 'avoid rounding, 1 key');
cmp_ok(keys %{ $dbh->{Profile}{Data}{$dummy_statement} }, '==', 1,
'avoid rounding, 1 dummy statement');
is(ref($dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname}), 'ARRAY',
'dummy method name is array');
ok $leaf, "should return ref to leaf node";
is ref $leaf, 'ARRAY', "should return ref to leaf node";
my $mine = $dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname};
is $leaf, $mine, "should return ref to correct leaf node";
print "@$mine\n";
is_deeply $mine, [ 1, 1, 1, 1, 1, $t1, $t1 ];
my $t2 = DBI::dbi_time() . "";
dbi_profile($dbh, $dummy_statement, $dummy_methname, $t2, $t2 + 2);
print "@$mine\n";
is_deeply $mine, [ 2, 3, 1, 1, 2, $t1, $t2 ];
print "Test collected profile data\n";
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>2 });
# do a (hopefully) measurable amount of work
my $sql = "select mode,size,name from ?";
my $sth = $dbh->prepare($sql);
for my $loop (1..50) { # enough work for low-res timers or v.fast cpus
$sth->execute(".");
while ( my $hash = $sth->fetchrow_hashref ) {}
}
$dbh->do("set foo=1");
print Dumper($dbh->{Profile});
# check that the proper key was set in Data
my $data = $dbh->{Profile}{Data}{$sql};
ok($data, 'profile data');
is(ref $data, 'ARRAY', 'ARRAY ref');
ok(@$data == 7, '7 elements');
ok((grep { defined($_) } @$data) == 7, 'all 7 defined');
ok((grep { DBI::looks_like_number($_) } @$data) == 7, 'all 7 numeric');
my ($count, $total, $first, $shortest, $longest, $time1, $time2) = @$data;
ok($count > 3, 'count is 3');
ok($total > $first, ' total > first');
ok($total > $longest, 'total > longest') or
warn "total $total > longest $longest: failed\n";
ok($longest > 0, 'longest > 0') or
warn "longest $longest > 0: failed\n"; # XXX theoretically not reliable
ok($longest > $shortest, 'longest > shortest');
ok($time1 >= $^T, 'time1 later than start time');
ok($time2 >= $^T, 'time2 later than start time');
ok($time1 <= $time2, 'time1 <= time2');
my $next = int(dbi_time()) + 1;
ok($next > $time1, 'next > time1') or
warn "next $next > first $time1: failed\n";
ok($next > $time2, 'next > time2') or
warn "next $next > last $time2: failed\n";
if ($shortest < 0) {
my $sys = "$Config{archname} $Config{osvers}"; # ie sparc-linux 2.4.20-2.3sparcsmp
warn <<EOT;
Time went backwards at some point during the test on this $sys system!
Perhaps you have time sync software (like NTP) that adjusted the clock
by more than $shortest seconds during the test.
Also some multiprocessor systems, and some virtualization systems can exhibit
this kind of clock behaviour. Please retry.
EOT
# don't treat small negative values as failure
$shortest = 0 if $shortest > -0.008;
}
my $tmp = sanitize_tree($dbh->{Profile});
$tmp->{Data}{$sql}[0] = -1; # make test insensitive to local file count
is_deeply $tmp, (bless {
'Path' => [ '!Statement' ],
'Data' => {
'' => [ 6, 0, 0, 0, 0, 0, 0 ],
$sql => [ -1, 0, 0, 0, 0, 0, 0 ],
'set foo=1' => [ 1, 0, 0, 0, 0, 0, 0 ],
}
} => 'DBI::Profile'), 'profile';
print "Test profile format\n";
my $output = $dbh->{Profile}->format();
print "Profile Output\n$output";
# check that output was produced in the expected format
ok(length $output, 'non zero length');
ok($output =~ /^DBI::Profile:/, 'DBI::Profile');
ok($output =~ /\((\d+) calls\)/, 'some calls');
ok($1 >= $count, 'calls >= count');
# -----------------------------------------------------------------------------------
# try statement and method name and reference-to-scalar path
my $by_reference = 'foo';
$dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
RaiseError => 1,
Profile => { Path => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ] }
});
$sql = "select name from .";
$sth = $dbh->prepare($sql);
$sth->execute();
$sth->fetchrow_hashref;
$by_reference = 'bar';
$sth->finish;
undef $sth; # DESTROY
$tmp = sanitize_tree($dbh->{Profile});
ok $tmp->{Data}{usrnam}{""}{foo}{STORE}, 'username stored';
$tmp->{Data}{usrnam}{""}{foo} = {};
# make test insentitive to number of local files
#warn Dumper($tmp);
is_deeply $tmp, bless {
'Path' => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ],
'Data' => {
'' => { # because Profile was enabled by DBI just before Username was set
'' => {
'foo' => {
'STORE' => [ 3, 0, 0, 0, 0, 0, 0 ],
}
}
},
'usrnam' => {
'' => {
'foo' => { },
},
'select name from .' => {
'foo' => {
'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
},
'bar' => {
'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ],
'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
},
},
},
},
} => 'DBI::Profile';
$tmp = [ $dbh->{Profile}->as_node_path_list() ];
is @$tmp, 8, 'should have 8 nodes';
sanitize_profile_data_nodes($_->[0]) for @$tmp;
#warn Dumper($dbh->{Profile}->{Data});
is_deeply $tmp, [
[ [ 3, 0, 0, 0, 0, 0, 0 ], '', '', 'foo', 'STORE' ],
[ [ 2, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'STORE' ],
[ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'connected' ],
[ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'DESTROY' ],
[ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'finish' ],
[ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'execute' ],
[ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'fetchrow_hashref' ],
[ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'prepare' ]
];
print "testing '!File', '!Caller' and their variants in Path\n";
$dbh->{Profile}->{Path} = [ '!File', '!File2', '!Caller', '!Caller2' ];
$dbh->{Profile}->{Data} = undef;
my $file = (File::Spec->splitpath(__FILE__))[2]; # '40profile.t'
my ($line1, $line2);
sub a_sub {
$sth = $dbh->prepare("select name from ."); $line2 = __LINE__;
}
a_sub(); $line1 = __LINE__;
$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data});
#warn Dumper($tmp);
is_deeply $tmp, {
"$file" => {
"$file via $file" => {
"$file line $line2" => {
"$file line $line2 via $file line $line1" => [ 1, 0, 0, 0, 0, 0, 0 ]
}
}
}
};
print "testing '!Time' and variants in Path\n";
undef $sth;
my $factor = 1_000_000;
$dbh->{Profile}->{Path} = [ '!Time', "!Time~$factor", '!MethodName' ];
$dbh->{Profile}->{Data} = undef;
# give up a timeslice in the hope that the following few lines
# run in well under a second even of slow/overloaded systems
$t1 = int(dbi_time())+1; 1 while int(dbi_time()-0.01) < $t1; # spin till just after second starts
$t2 = int($t1/$factor)*$factor;
$sth = $dbh->prepare("select name from .");
$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data});
# if actual "!Time" recorded is 'close enough' then we'll pass
# the test - it's not worth failing just because a system is slow
$t1 = (keys %$tmp)[0] if (abs($t1 - (keys %$tmp)[0]) <= 5);
is_deeply $tmp, {
$t1 => { $t2 => { prepare => [ 1, 0, 0, 0, 0, 0, 0 ] }}
}, "!Time and !Time~$factor should work"
or warn Dumper([$t1, $t2, $tmp]);
print "testing &norm_std_n3 in Path\n";
$dbh->{Profile} = '&norm_std_n3'; # assign as string to get magic
is_deeply $dbh->{Profile}{Path}, [
\&DBI::ProfileSubs::norm_std_n3
];
$dbh->{Profile}->{Data} = undef;
$sql = qq{insert into foo20060726 (a,b) values (42,"foo")};
dbi_profile( { foo => $dbh, bar => undef }, $sql, 'mymethod', 100000000, 100000002);
$tmp = $dbh->{Profile}{Data};
#warn Dumper($tmp);
is_deeply $tmp, {
'insert into foo<N> (a,b) values (<N>,"<S>")' => [ 1, '2', '2', '2', '2', '100000000', '100000000' ]
}, '&norm_std_n3 should normalize statement';
# -----------------------------------------------------------------------------------
print "testing code ref in Path\n";
sub run_test1 {
my ($profile) = @_;
$dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
RaiseError => 1,
Profile => $profile,
});
$sql = "select name from .";
$sth = $dbh->prepare($sql);
$sth->execute();
$sth->fetchrow_hashref;
$sth->finish;
undef $sth; # DESTROY
my $data = sanitize_profile_data_nodes($dbh->{Profile}{Data}, 1);
return ($data, $dbh) if wantarray;
return $data;
}
$tmp = run_test1( { Path => [ 'foo', sub { 'bar' }, 'baz' ] });
is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 11, 0,0,0,0,0,0 ] } } };
$tmp = run_test1( { Path => [ 'foo', sub { 'ping','pong' } ] });
is_deeply $tmp, { 'foo' => { 'ping' => { 'pong' => [ 11, 0,0,0,0,0,0 ] } } };
$tmp = run_test1( { Path => [ 'foo', sub { \undef } ] });
is_deeply $tmp, { 'foo' => undef }, 'should be vetoed';
# check what code ref sees in $_
$tmp = run_test1( { Path => [ sub { $_ } ] });
is_deeply $tmp, {
'' => [ 6, 0, 0, 0, 0, 0, 0 ],
'select name from .' => [ 5, 0, 0, 0, 0, 0, 0 ]
}, '$_ should contain statement';
# check what code ref sees in @_
$tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return \undef if $method =~ /^[A-Z]+$/; return (ref $h, $method) } ] });
is_deeply $tmp, {
'DBI::db' => {
'connected' => [ 1, 0, 0, 0, 0, 0, 0 ],
'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
},
'DBI::st' => {
'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
},
}, 'should have @_ as keys';
# check we can filter by method
$tmp = run_test1( { Path => [ sub { return \undef unless $_[1] =~ /^fetch/; return $_[1] } ] });
#warn Dumper($tmp);
is_deeply $tmp, {
'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
}, 'should be able to filter by method';
DBI->trace(0, "STDOUT"); # close current log to flush it
ok(-s $LOG_FILE, 'output should go to log file');
# -----------------------------------------------------------------------------------
print "testing as_text\n";
# check %N$ indices
$dbh->{Profile}->{Data} = { P1 => { P2 => [ 100, 400, 42, 43, 44, 45, 46, 47 ] } };
my $as_text = $dbh->{Profile}->as_text({
path => [ 'top' ],
separator => ':',
format => '%1$s %2$d [ %10$d %11$d %12$d %13$d %14$d %15$d %16$d %17$d ]',
});
is($as_text, "top:P1:P2 4 [ 100 400 42 43 44 45 46 47 ]", 'as_text');
# test sortsub
$dbh->{Profile}->{Data} = {
A => { Z => [ 101, 1, 2, 3, 4, 5, 6, 7 ] },
B => { Y => [ 102, 1, 2, 3, 4, 5, 6, 7 ] },
};
$as_text = $dbh->{Profile}->as_text({
separator => ':',
format => '%1$s %10$d ',
sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary }
});
is($as_text, "B:Y 102 A:Z 101 ", 'as_text sortsub');
# general test, including defaults
($tmp, $dbh) = run_test1( { Path => [ 'foo', '!MethodName', 'baz' ] });
$as_text = $dbh->{Profile}->as_text();
$as_text =~ s/\.00+/.0/g;
#warn "[$as_text]";
is $as_text, q{foo > DESTROY > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > STORE > baz: 0.0s / 5 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > connected > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > execute > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > fetchrow_hashref > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > finish > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > prepare > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
}, 'as_text general';
# -----------------------------------------------------------------------------------
print "dbi_profile_merge_nodes\n";
my $total_time = dbi_profile_merge_nodes(
my $totals=[],
[ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
[ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
);
$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues
is("@$totals", "25.00 0.93 0.11 0.01 0.23 1023110000.00 1023110010.00",
'merged nodes');
is($total_time, 0.93, 'merged time');
$total_time = dbi_profile_merge_nodes(
$totals=[], {
foo => [ 10, 1.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
bar => [ 17, 1.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
}
);
$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues
is("@$totals", "27.00 2.93 0.11 0.01 0.23 1023110000.00 1023110010.00",
'merged time foo/bar');
is($total_time, 2.93, 'merged nodes foo/bar time');
exit 0;
sub sanitize_tree {
my $data = shift;
my $skip_clone = shift;
return $data unless ref $data;
$data = dclone($data) unless $skip_clone;
sanitize_profile_data_nodes($data->{Data}) if $data->{Data};
return $data;
}
sub sanitize_profile_data_nodes {
my $node = shift;
if (ref $node eq 'HASH') {
sanitize_profile_data_nodes($_) for values %$node;
}
elsif (ref $node eq 'ARRAY') {
if (@$node == 7 and DBI::looks_like_number($node->[0])) {
# sanitize the profile data node to simplify tests
$_ = 0 for @{$node}[1..@$node-1]; # not 0
}
}
return $node;
}