diff options
author | Lorry Tar Creator <lorry-tar-importer@baserock.org> | 2012-06-06 16:41:29 +0000 |
---|---|---|
committer | Lorry <lorry@roadtrain.codethink.co.uk> | 2012-09-26 13:46:50 +0000 |
commit | 7c48e67cf07ee41bfde7139a62bb232bd23a4a48 (patch) | |
tree | 6d7686b5075bd5cba253dabf2e6c302acb3a147c /t/40profile.t | |
download | perl-dbi-tarball-DBI-1.622.tar.gz |
Diffstat (limited to 't/40profile.t')
-rw-r--r-- | t/40profile.t | 485 |
1 files changed, 485 insertions, 0 deletions
diff --git a/t/40profile.t b/t/40profile.t new file mode 100644 index 0000000..5cb0023 --- /dev/null +++ b/t/40profile.t @@ -0,0 +1,485 @@ +#!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; +} |