diff options
Diffstat (limited to 'test.pl')
| -rwxr-xr-x | test.pl | 201 |
1 files changed, 201 insertions, 0 deletions
@@ -0,0 +1,201 @@ +#!/usr/local/bin/perl -w + +# $Id: test.pl 12537 2009-02-24 22:45:40Z timbo $ +# +# Copyright (c) 1994-1998 Tim Bunce +# +# See COPYRIGHT section in DBI.pm for usage and distribution rights. + + +# This is now mostly an empty shell I experiment with. +# The real tests have moved to t/*.t +# See t/*.t for more detailed tests. + + +BEGIN { + print "$0 @ARGV\n"; + print q{DBI test application $Revision: 12537 $}."\n"; + $| = 1; +} + +use blib; + +use DBI; + +use DBI::DBD; # simple test to make sure it's okay + +use Config; +use Getopt::Long; +use strict; + +our $has_devel_leak = eval { + local $^W = 0; # silence "Use of uninitialized value $DynaLoader::args[0] in subroutine entry"; + require Devel::Leak; +}; + +$::opt_d = 0; +$::opt_l = ''; +$::opt_h = 0; +$::opt_m = 0; # basic memory leak test: "perl test.pl -m NullP" +$::opt_t = 0; # thread test +$::opt_n = 0; # counter for other options + +GetOptions(qw(d=i h=i l=s m=i t=i n=i)) + or die "Usage: $0 [-d n] [-h n] [-m n] [-t n] [-n n] [drivername]\n"; + +my $count = 0; +my $ps = (-d '/proc') ? "ps -lp " : "ps -l"; +my $driver = $ARGV[0] || ($::opt_m ? 'NullP' : 'ExampleP'); + +# Now ask for some information from the DBI Switch +my $switch = DBI->internal; +$switch->trace($::opt_h); # 2=detailed handle trace + +DBI->trace($::opt_d, $::opt_l) if $::opt_d || $::opt_l; + +print "Switch: $switch->{'Attribution'}, $switch->{'Version'}\n"; + +print "Available Drivers: ",join(", ",DBI->available_drivers(1)),"\n"; + + +my $dbh = DBI->connect("dbi:$driver:", '', '', { RaiseError=>1 }) or die; +$dbh->trace($::opt_h); + +if (0) { + DBI->trace(3); + my $h = DBI->connect('dbi:NullP:','','', { RootClass=>'MyTestDBI', DbTypeSubclass=>'foo, bar' }); + DBI->trace(0); + { # only works after 5.004_04: + warn "RaiseError= '$h->{RaiseError}' (pre local)\n"; + local($h->{RaiseError});# = undef; + warn "RaiseError= '$h->{RaiseError}' (post local)\n"; + } + warn "RaiseError= '$h->{RaiseError}' (post local block)\n"; + exit 1; +} + +if ($::opt_m) { + #$dbh->trace(9); + my $level = $::opt_m; + my $cnt = $::opt_n || 10000; + + print "Using $driver, same dbh...\n"; + for (my $i=0; $i<$cnt; ++$i) { mem_test($dbh, undef, $level, undef, undef, undef) } + + print "Using NullP, reconnecting each time...\n"; + for (my $i=0; $i<$cnt; ++$i) { mem_test(undef, ['dbi:NullP:'], $level, undef, undef, undef) } + + print "Using ExampleP, reconnecting each time...\n"; + my $r_develleak = 0; + mem_test(undef, ['dbi:NullP:'], $level, undef, undef, \$r_develleak) while 1; + #mem_test(undef, ['dbi:mysql:VC'], $level, "select * from campaigns where length(?)>0", 0, undef) while 1; +} +elsif ($::opt_t) { + thread_test(); +} +else { + + # new experimental connect_test_perf method + DBI->connect_test_perf("dbi:$driver:", '', '', { + dbi_loops=>3, dbi_par=>20, dbi_verb=>1 + }); + + require Benchmark; + print "Testing handle creation speed...\n"; + my $null_dbh = DBI->connect('dbi:NullP:','',''); + my $null_sth = $null_dbh->prepare(''); # create one to warm up + $count = 20_000; + $count /= 10 if $ENV{DBI_AUTOPROXY}; + my $i = $count; + my $t1 = new Benchmark; + $null_dbh->prepare('') while $i--; + my $td = Benchmark::timediff(Benchmark->new, $t1); + my $tds= Benchmark::timestr($td); + my $dur = $td->cpu_a || (1/$count); # fudge if cpu_a==0 + + printf "%5d NullP sth/s perl %8s %s (%s %s %s) %fs\n\n", + $count/$dur, $], $Config{archname}, + $Config{gccversion} ? 'gcc' : $Config{cc}, + (split / /, $Config{gccversion}||$Config{ccversion}||'')[0]||'', + $Config{optimize}, + $dur/$count; + + $null_dbh->disconnect; +} + +$dbh->disconnect; + +#DBI->trace(4); +print "$0 done\n"; +exit 0; + + +sub mem_test { # harness to help find basic leaks + my ($orig_dbh, $connect, $level, $select, $params, $r_develleak) = @_; + $select ||= "select mode,ino,name from ?"; + $params ||= [ '.' ]; + + # this can be used to force a 'leak' to check memory use reporting + #$main::leak .= " " x 1000; + system("echo $count; $ps$$") if (($count++ % 2000) == 0); + + my $dbh = $orig_dbh || do { + my ($dsn, $u, $p, $attr) = @$connect; + $attr->{RaiseError} = 1; + DBI->connect($dsn, $u, $p, $attr); + }; + my $cursor_a; + + my ($dl_count, $dl_handle); + if ($has_devel_leak && $$r_develleak++) { + $dbh->trace(2); + $dl_count = Devel::Leak::NoteSV($dl_handle); + } + + my $rows; + $cursor_a = $dbh->prepare($select) if $level >= 2; + $cursor_a->execute(@$params) if $level >= 3; + $cursor_a->fetchrow_hashref() if $level >= 4; + $rows = $cursor_a->fetchall_arrayref({}) if $level >= 4; + $cursor_a->finish if $cursor_a && $cursor_a->{Active}; + undef $cursor_a; + + @{$dbh->{ChildHandles}} = (); + + die Devel::Leak::CheckSV($dl_handle)-$dl_count + if $dl_handle; + + $dbh->disconnect unless $orig_dbh; + undef $dbh; + +} + + +sub thread_test { + require Thread; + my $dbh = DBI->connect("dbi:ExampleP:.", "", "") || die $DBI::err; + #$dbh->trace(4); + my @t; + print "Starting $::opt_t threads:\n"; + foreach(1..$::opt_t) { + print "$_\n"; + push @t, Thread->new(\&thread_test_loop, $dbh, $::opt_n||99); + } + print "Small sleep to allow threads to progress\n"; + sleep 2; + print "Joining threads:\n"; + foreach(@t) { + print "$_\n"; + $_->join + } +} + +sub thread_test_loop { + my $dbh = shift; + my $i = shift || 10; + while($i-- > 0) { + $dbh->selectall_arrayref("select * from ?", undef, "."); + } +} + +# end. |