Author: timbo
Date: Tue Oct 19 14:21:34 2010
New Revision: 14502
Added:
dbi/trunk/xt/
dbi/trunk/xt/README
dbi/trunk/xt/dbixha-goperf.pl (contents, props changed)
dbi/trunk/xt/goferdemo.pl
dbi/trunk/xt/leak.pl
dbi/trunk/xt/tests.pl (contents, props changed)
Log:
Add xt directory with assorted stuff I had not checked in before
Added: dbi/trunk/xt/README
==============================================================================
--- (empty file)
+++ dbi/trunk/xt/README Tue Oct 19 14:21:34 2010
@@ -0,0 +1,2 @@
+This directory contains assorted 'extra tests' and random development stuff
+that doesn't have a better home. Feel free to ignore.
Added: dbi/trunk/xt/dbixha-goperf.pl
==============================================================================
--- (empty file)
+++ dbi/trunk/xt/dbixha-goperf.pl Tue Oct 19 14:21:34 2010
@@ -0,0 +1,166 @@
+#!perl -w
+# vim:sw=4:ts=8
+$|=1;
+
+use strict;
+use warnings;
+
+use Cwd;
+use Time::HiRes qw(time);
+use Data::Dumper;
+use Getopt::Long;
+
+use DBI;
+
+GetOptions(
+ 'c|count=i' => \(my $opt_count = 100),
+ 'dsn=s' => \(my $opt_dsn = "dbi:NullP:"),
+ 'timeout=i' => \(my $opt_timeout = 10),
+ 'p|policy=s' => \(my $opt_policy = "pedantic,classic,rush"),
+) or exit 1;
+
+if ($ENV{DBI_AUTOPROXY}) {
+ # this means we have DBD::Gofer => DBD::Gofer => DBD::DBM!
+ # rather than disable it we let it run because we're twisted
+ # and because it helps find more bugs (though debugging can be painful)
+ warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n";
+}
+
+# ensure subprocess (for pipeone and stream transport) will use the same
modules as us, ie ./blib
+local $ENV{PERL5LIB} = join ":", @INC;
+
+my %durations;
+my $username = eval { getpwuid($>) } || ''; # fails on windows
+my $can_ssh = ($username && $username eq 'timbo' && -d '.svn');
+my $perl = "$^X"; # ensure sameperl and our blib (note two spaces)
+ # ensure blib (note two spaces)
+ $perl .= sprintf " -Mblib=%s/blib", getcwd() if $ENV{PERL5LIB} =~
m{/blib/};
+
+my %trials = (
+ null => {},
+ pipeone => { perl=>$perl, timeout=>$opt_timeout },
+ stream => { perl=>$perl, timeout=>$opt_timeout },
+ stream_ssh => ($can_ssh)
+ ? { perl=>$perl, timeout=>$opt_timeout, url =>
"ssh:$userna...@localhost" }
+ : undef,
+ http => { url => "http://localhost:8001/gofer"; },
+);
+
+my $dbixha_attr = { RaiseError => 1 };
+$DATABASE::conf{'test'} = {
+ max_retries => 2,
+ db_stack => [
+ [ 'dbi:NullP:server=prod1;database=test', 'user1', 'password1',
$dbixha_attr ],
+ [ 'dbi:NullP:server=prod2;database=test', 'user2', 'password2',
$dbixha_attr ],
+ [ 'dbi:NullP:server=prod3;database=test', 'user3', 'password3',
$dbixha_attr ],
+ ],
+ pingtimeout => -1,
+ failoverlevel => 'application',
+ connecttimeout => 1,
+ executetimeout => 8,
+ callback_function => sub { 1 },
+};
+
+use DBIx::HA;
+DBIx::HA->initialize();
+my $dbixha_dbh = DBIx::HA->connect('test');
+run_tests('foo', 'bar', $dbixha_dbh);
+
+# to get baseline for comparisons
+my $d = connect_and_run_tests('no', {}, 'no')->clone;
+
+run_tests('no2', 'no2', $d);
+run_tests('no3', 'no3', $d);
+
+run_tests('foo2', 'bar2', $dbixha_dbh);
+
+for my $trial (@ARGV) {
+ (my $transport = $trial) =~ s/_.*//;
+ my $trans_attr = $trials{$trial} or do {
+ warn "No trial '$trial' defined - skipped";
+ next;
+ };
+
+ for my $policy_name (split /\s*,\s*/, $opt_policy) {
+ eval { connect_and_run_tests($transport, $trans_attr, $policy_name) };
+ warn $@ if $@;
+ }
+}
+
+while ( my ($activity, $stats_hash) = each %durations ) {
+ print "\n";
+ $stats_hash->{'~baseline~'} = delete $stats_hash->{"no+no"};
+ for my $perf_tag (reverse sort keys %$stats_hash) {
+ my $dur = $stats_hash->{$perf_tag};
+ printf " %6s %-16s: %.6fsec (%5d/sec)",
+ $activity, $perf_tag, $dur/$opt_count, $opt_count/$dur;
+ my $baseline_dur = $stats_hash->{'~baseline~'};
+ printf " %+6.2fms", (($dur-$baseline_dur)/$opt_count)*1000
+ unless $perf_tag eq '~baseline~';
+ print "\n";
+ }
+}
+
+
+sub connect_and_run_tests {
+ my ($transport, $trans_attr, $policy_name) = @_;
+
+ my $test_run_tag = "Testing $transport transport with $policy_name policy";
+ print "\n$test_run_tag\n";
+
+ my $dsn = $opt_dsn;
+ if ($policy_name ne 'no') {
+ my $driver_dsn = "transport=$transport;policy=$policy_name";
+ $driver_dsn .= join ";", '', map { "$_=$trans_attr->{$_}" } keys
%$trans_attr
+ if %$trans_attr;
+ $dsn = "dbi:Gofer:$driver_dsn;dsn=$opt_dsn";
+ }
+ print " $dsn\n";
+
+ my $dbh = DBI->connect($dsn, undef, undef, { RaiseError => 1 } );
+ run_tests($transport, $policy_name, $dbh);
+ $dbh->disconnect;
+ return $dbh;
+}
+
+sub run_tests {
+ my ($transport, $policy_name, $dbh) = @_;
+ $dbh->do("DROP TABLE IF EXISTS fruit");
+ $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))");
+ my $ins_sth = $dbh->prepare("INSERT INTO fruit VALUES (?,?)");
+ $ins_sth->execute(1, 'apples');
+ $ins_sth->execute(2, 'oranges');
+ $ins_sth->execute(3, 'lemons');
+ $ins_sth->execute(4, 'limes');
+
+ my $start = time();
+ $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit")
+ for (1000..1000+$opt_count);
+ $durations{select}{"$transport+$policy_name"} = time() - $start;
+
+ # insert some rows in to get a (*very* rough) idea of overheads
+ $start = time();
+ $ins_sth->execute($_, 'speed')
+ for (1000..1000+$opt_count);
+ $durations{insert}{"$transport+$policy_name"} = time() - $start;
+ $dbh->do("DROP TABLE fruit");
+}
+
+sub get_policy {
+ my ($policy_class) = @_;
+ $policy_class = "DBD::Gofer::Policy::$policy_class" unless $policy_class
=~ /::/;
+ _load_class($policy_class) or die $@;
+ return $policy_class->new();
+}
+
+sub _load_class { # return true or false+$@
+ my $class = shift;
+ (my $pm = $class) =~ s{::}{/}g;
+ $pm .= ".pm";
+ return 1 if eval { require $pm };
+ delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef
isn't enough
+ undef; # error in $@
+}
+
+
+1;
Added: dbi/trunk/xt/goferdemo.pl
==============================================================================
--- (empty file)
+++ dbi/trunk/xt/goferdemo.pl Tue Oct 19 14:21:34 2010
@@ -0,0 +1,48 @@
+#!perl -w
+$|=1;
+
+use strict;
+use File::Path;
+use File::Spec;
+use Cwd;
+
+use DBI;
+
+$ENV{DBI_SQL_NANO}=1;
+
+my $dir = File::Spec->catdir(getcwd(),'test_output');
+rmtree $dir;
+mkpath $dir;
+
+my $dtype = 'SDBM_File';
+
+my $dbh = DBI->connect( "dbi:DBM:dbm_type=$dtype;lockfile=0" );
+
+for my $sql ( split /\s*;\n/, join '',<DATA> ) {
+ $sql =~ s/\S*fruit/${dtype}_fruit/; # include dbm type in table name
+ $sql =~ s/;$//; # in case no final \n on last line of __DATA__
+ print " $sql\n";
+ my $sth = $dbh->prepare($sql) or die $dbh->errstr;
+ $sth->execute;
+ die $sth->errstr if $sth->err and $sql !~ /DROP/;
+ next unless $sql =~ /SELECT/;
+ while (my ($key, $value) = $sth->fetchrow_array) {
+ print "$key: $value\n";
+ }
+}
+$dbh->disconnect;
+
+rmtree $dir;
+exit 0;
+1;
+__DATA__
+DROP TABLE IF EXISTS fruit;
+CREATE TABLE fruit (dKey INT, dVal VARCHAR(10));
+INSERT INTO fruit VALUES (1,'oranges' );
+INSERT INTO fruit VALUES (2,'to_change' );
+INSERT INTO fruit VALUES (3, NULL );
+INSERT INTO fruit VALUES (4,'to delete' );
+UPDATE fruit SET dVal='apples' WHERE dKey=2;
+DELETE FROM fruit WHERE dVal='to delete';
+SELECT * FROM fruit;
+SELECT * FROM fruit;
Added: dbi/trunk/xt/leak.pl
==============================================================================
--- (empty file)
+++ dbi/trunk/xt/leak.pl Tue Oct 19 14:21:34 2010
@@ -0,0 +1,82 @@
+#!/usr/bin/env perl
+ use strict;
+ use warnings;
+ use DBI;
+ use Devel::Leak;
+ use Test::More;
+
+ # some dsn configuration
+ my %dsn = (
+ sqlite => [ 'dbi:SQLite:dbname=test.sql', '', '' ],
+ #mysql => [ 'dbi:mysql:test', '', '' ],
+ #csv => [ 'dbi:CSV:', '', '' ],
+ );
+
+ # generic SQL
+ my %SQL = (
+ drop => 'DROP TABLE IF EXISTS tok',
+ create => 'CREATE TABLE tok (kuk INT, zat INT, sob TEXT)',
+ insert => 'INSERT INTO tok (kuk, zat, sob) VALUES (?,?,?)',
+ select => 'SELECT kuk, zat, sob FROM tok',
+ );
+
+ my @tests = (
+ q{my $sanity = 1;}, # simple sanity test (eval "" doesn't leak)
+ q{my $s = $dbh->trace(0) },
+ q{my $s = $dbh->prepare($sql) },
+ q{my $s = $dbh->prepare($sql); $s->execute(); },
+ q{my $s = $dbh->prepare( $sql ); $s->execute(); 1 while
$s->fetchrow_arrayref(); $s->finish;},
+ q{my $s = $dbh->prepare_cached( $sql ); $s->execute(); 1 while
$s->fetchrow_arrayref(); $s->finish;},
+ q{my $c = $dbh->selectcol_arrayref( $sql, { Column => [1] } )},
+ q{my @a = $dbh->selectrow_array( $sql )},
+ q{my $a = $dbh->selectrow_arrayref( $sql )},
+ );
+
+ # plan
+ plan tests => @tests * keys %dsn;
+
+ my $empty = "";
+ for my $dbd ( sort keys %dsn ) {
+
+ SKIP: {
+
+ # connect to the test db
+ my $dbh =
+ eval { DBI->connect( @{ $dsn{$dbd} }, { RaiseError => 1 } ); };
+
+ skip "Connection to $dbd failed: $@", scalar @tests if !$dbh;
+
+ # initialize the table
+ $dbh->do( $SQL{drop} );
+ $dbh->do( $SQL{create} );
+
+ # fill in some data
+ my $sth;
+ $sth = $dbh->prepare( $SQL{insert} );
+ $sth->execute( $_, 100 - $_, 'x' x $_ ) for 1 .. 30;
+
+ # test each command
+ for my $cmd (@tests) {
+
+ # get the SQL statement
+ my $sql = $SQL{select};
+ $cmd = $cmd.q{; $dbh->{Statement}="";};
+
+ # run once, in case some internal structures get initialized
+ eval $cmd;
+
+ # now look for leakage
+ my $c1 = Devel::Leak::NoteSV( my $h );
+ {
+ eval $cmd;
+ }
+ my $c2 = Devel::Leak::CheckSV($h);
+ diag $@ if $@;
+
+ my $leak = $c2 - $c1;
+ is( $leak, 0, sprintf "\tleak=%2d for %-8s%s", $leak, $dbd,
$cmd );
+ }
+ warn
"##########################################################################\n";
+
+ }
+ }
Added: dbi/trunk/xt/tests.pl
==============================================================================
--- (empty file)
+++ dbi/trunk/xt/tests.pl Tue Oct 19 14:21:34 2010
@@ -0,0 +1,201 @@
+#!/usr/local/bin/perl -w
+
+# $Id: test.pl 6734 2006-07-30 22:42:07Z 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: 11.7 $}."\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] [-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->debug($::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:", '', ''); # old-style connect syntax
+$dbh->debug($::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 = 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=>5, 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 = 10_000;
+ 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)\n\n",
+ $count/$dur, $], $Config{archname},
+ $Config{gccversion} ? 'gcc' : $Config{cc},
+ (split / /, $Config{gccversion}||$Config{ccversion}||'')[0]||'',
+ $Config{optimize};
+
+ if (0) {
+ $null_dbh = DBI->connect('dbi:mysql:VC_log','','',{RaiseError=>1});
+ $null_sth = $null_dbh->prepare('select * from big');
+ $null_sth->execute();
+ $t1 = new Benchmark;
+ 1 while ($null_sth->fetchrow_hashref());
+ #1 while ($null_sth->fetchrow_arrayref());
+ $td = Benchmark::timediff(Benchmark->new, $t1);
+ $tds= Benchmark::timestr($td);
+ $dur = $td->cpu_a;
+ printf "$DBI::rows in $tds\n";
+ }
+}
+
+#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++ % 500) == 0);
+
+ my $dbh = $orig_dbh || DBI->connect(@$connect);
+ $dbh->{RaiseError} = 1;
+ my $cursor_a;
+
+ my ($dl_count, $dl_handle);
+ if ($$r_develleak++) {
+ $dbh->trace(2);
+ $dl_count = Devel::Leak::NoteSV($dl_handle);
+ }
+
+ $cursor_a = $dbh->prepare($select) if $level >= 2;
+ $cursor_a->execute(@$params) if $level >= 3;
+ $cursor_a->fetchrow_hashref() if $level >= 4;
+ my $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.
