diff options
Diffstat (limited to 't/85gofer.t')
| -rw-r--r-- | t/85gofer.t | 264 |
1 files changed, 264 insertions, 0 deletions
diff --git a/t/85gofer.t b/t/85gofer.t new file mode 100644 index 0000000..8208195 --- /dev/null +++ b/t/85gofer.t @@ -0,0 +1,264 @@ +#!perl -w # -*- perl -*- +# vim:sw=4:ts=8 +$|=1; + +use strict; +use warnings; + +use Cwd; +use Config; +use Data::Dumper; +use Test::More 0.84; +use Getopt::Long; + +use DBI qw(dbi_time); + +if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity + plan skip_all => "transport+policy tests skipped with non-gofer DBI_AUTOPROXY" + if $ap !~ /^dbi:Gofer/i; + plan skip_all => "transport+policy tests skipped with non-pedantic policy in DBI_AUTOPROXY" + if $ap !~ /policy=pedantic\b/i; +} + +do "t/lib.pl"; + +# 0=SQL::Statement if avail, 1=DBI::SQL::Nano +# next line forces use of Nano rather than default behaviour +# $ENV{DBI_SQL_NANO}=1; +# This is done in zvn_50dbm.t + +GetOptions( + 'c|count=i' => \(my $opt_count = (-t STDOUT ? 100 : 0)), + 'dbm=s' => \my $opt_dbm, + 'v|verbose!' => \my $opt_verbose, + 't|transport=s' => \my $opt_transport, + 'p|policy=s' => \my $opt_policy, +) or exit 1; + + +# so users can try others from the command line +if (!$opt_dbm) { + # pick first available, starting with SDBM_File + for (qw( SDBM_File GDBM_File DB_File BerkeleyDB )) { + if (eval { local $^W; require "$_.pm" }) { + $opt_dbm = ($_); + last; + } + } + plan skip_all => 'No DBM modules available' if !$opt_dbm; +} + +my @remote_dsns = DBI->data_sources( "dbi:DBM:", { + dbm_type => $opt_dbm, + f_lockfile => 0, + f_dir => test_dir() } ); +my $remote_dsn = $remote_dsns[0]; +( my $remote_driver_dsn = $remote_dsn ) =~ s/dbi:dbm://i; +# Long timeout for slow/overloaded systems (incl virtual machines with low priority) +my $timeout = 240; + +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" + unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t +} + +# ensure subprocess (for pipeone and stream transport) will use the same modules as us, ie ./blib +local $ENV{PERL5LIB} = join $Config{path_sep}, @INC; + +my %durations; +my $getcwd = getcwd(); +my $username = eval { getpwuid($>) } || ''; # fails on windows +my $can_ssh = ($username && $username eq 'timbo' && -d '.svn' + && system("sh -c 'echo > /dev/tcp/localhost/22' 2>/dev/null")==0 +); +my $perl = "$^X -Mblib=$getcwd/blib"; # ensure sameperl and our blib (note two spaces) + +my %trials = ( + null => {}, + pipeone => { perl=>$perl, timeout=>$timeout }, + stream => { perl=>$perl, timeout=>$timeout }, + stream_ssh => ($can_ssh) + ? { perl=>$perl, timeout=>$timeout, url => "ssh:$username\@localhost" } + : undef, + #http => { url => "http://localhost:8001/gofer" }, +); + +# too dependant on local config to make a standard test +delete $trials{http} unless $username eq 'timbo' && -d '.svn'; + +my @transports = ($opt_transport) ? ($opt_transport) : (sort keys %trials); +note("Transports: @transports"); +my @policies = ($opt_policy) ? ($opt_policy) : qw(pedantic classic rush); +note("Policies: @policies"); +note("Count: $opt_count"); + +for my $trial (@transports) { + (my $transport = $trial) =~ s/_.*//; + my $trans_attr = $trials{$trial} + or next; + + # XXX temporary restrictions, hopefully + if ( ($^O eq 'MSWin32') || ($^O eq 'VMS') ) { + # stream needs Fcntl macro F_GETFL for non-blocking + # and pipe seems to hang on some windows systems + next if $transport eq 'stream' or $transport eq 'pipeone'; + } + + for my $policy_name (@policies) { + + eval { run_tests($transport, $trans_attr, $policy_name) }; + ($@) ? fail("$trial: $@") : pass(); + + } +} + +# to get baseline for comparisons if doing performance testing +run_tests('no', {}, 'pedantic') if $opt_count; + +while ( my ($activity, $stats_hash) = each %durations ) { + note(""); + $stats_hash->{'~baseline~'} = delete $stats_hash->{"no+pedantic"}; + for my $perf_tag (reverse sort keys %$stats_hash) { + my $dur = $stats_hash->{$perf_tag} || 0.0000001; + note sprintf " %6s %-16s: %.6fsec (%5d/sec)", + $activity, $perf_tag, $dur/$opt_count, $opt_count/$dur; + my $baseline_dur = $stats_hash->{'~baseline~'}; + note sprintf " %+5.1fms", (($dur-$baseline_dur)/$opt_count)*1000 + unless $perf_tag eq '~baseline~'; + note ""; + } +} + + +sub run_tests { + my ($transport, $trans_attr, $policy_name) = @_; + + my $policy = get_policy($policy_name); + my $skip_gofer_checks = ($transport eq 'no'); + + + my $test_run_tag = "Testing $transport transport with $policy_name policy"; + note "============="; + note "$test_run_tag"; + + my $driver_dsn = "transport=$transport;policy=$policy_name"; + $driver_dsn .= join ";", '', map { "$_=$trans_attr->{$_}" } keys %$trans_attr + if %$trans_attr; + + my $dsn = "dbi:Gofer:$driver_dsn;dsn=$remote_dsn"; + $dsn = $remote_dsn if $transport eq 'no'; + note " $dsn"; + + my $dbh = DBI->connect($dsn, undef, undef, { RaiseError => 1, PrintError => 0, ShowErrorStatement => 1 } ); + die "$test_run_tag aborted: $DBI::errstr\n" unless $dbh; # no point continuing + ok $dbh, sprintf "should connect to %s", $dsn; + + is $dbh->{Name}, ($policy->skip_connect_check) + ? $driver_dsn + : $remote_driver_dsn; + + END { unlink glob "fruit.???" } + ok $dbh->do("DROP TABLE IF EXISTS fruit"); + ok $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))"); + die "$test_run_tag aborted ($DBI::errstr)\n" if $DBI::err; + + my $sth = do { + local $dbh->{RaiseError} = 0; + $dbh->prepare("complete non-sql gibberish"); + }; + ($policy->skip_prepare_check) + ? isa_ok $sth, 'DBI::st' + : is $sth, undef, 'should detect prepare failure'; + + ok my $ins_sth = $dbh->prepare("INSERT INTO fruit VALUES (?,?)"); + ok $ins_sth->execute(1, 'oranges'); + ok $ins_sth->execute(2, 'oranges'); + + my $rowset; + ok $rowset = $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit ORDER BY dKey"); + is_deeply($rowset, [ [ '1', 'oranges' ], [ '2', 'oranges' ] ]); + + ok $dbh->do("UPDATE fruit SET dVal='apples' WHERE dVal='oranges'"); + ok $dbh->{go_response}->executed_flag_set, 'go_response executed flag should be true' + unless $skip_gofer_checks && pass(); + + ok $sth = $dbh->prepare("SELECT dKey, dVal FROM fruit"); + ok $sth->execute; + ok $rowset = $sth->fetchall_hashref('dKey'); + is_deeply($rowset, { '1' => { dKey=>1, dVal=>'apples' }, 2 => { dKey=>2, dVal=>'apples' } }); + + if ($opt_count and $transport ne 'pipeone') { + note "performance check - $opt_count selects and inserts"; + my $start = dbi_time(); + $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit") + for (1000..1000+$opt_count); + $durations{select}{"$transport+$policy_name"} = dbi_time() - $start; + + # some rows in to get a (*very* rough) idea of overheads + $start = dbi_time(); + $ins_sth->execute($_, 'speed') + for (1000..1000+$opt_count); + $durations{insert}{"$transport+$policy_name"} = dbi_time() - $start; + } + + note "Testing go_request_count and caching of simple values"; + my $go_request_count = $dbh->{go_request_count}; + ok $go_request_count + unless $skip_gofer_checks && pass(); + + ok $dbh->do("DROP TABLE fruit"); + is ++$go_request_count, $dbh->{go_request_count} + unless $skip_gofer_checks && pass(); + + # tests go_request_count, caching, and skip_default_methods policy + my $use_remote = ($policy->skip_default_methods) ? 0 : 1; + note sprintf "use_remote=%s (policy=%s, transport=%s) %s", + $use_remote, $policy_name, $transport, $dbh->{dbi_default_methods}||''; + +SKIP: { + skip "skip_default_methods checking doesn't work with Gofer over Gofer", 3 + if $ENV{DBI_AUTOPROXY} or $skip_gofer_checks; + $dbh->data_sources({ foo_bar => $go_request_count }); + is $dbh->{go_request_count}, $go_request_count + 1*$use_remote; + $dbh->data_sources({ foo_bar => $go_request_count }); # should use cache + is $dbh->{go_request_count}, $go_request_count + 1*$use_remote; + @_=$dbh->data_sources({ foo_bar => $go_request_count }); # no cached yet due to wantarray + is $dbh->{go_request_count}, $go_request_count + 2*$use_remote; +} + +SKIP: { + skip "caching of metadata methods returning sth not yet implemented", 2; + note "Testing go_request_count and caching of sth"; + $go_request_count = $dbh->{go_request_count}; + my $sth_ti1 = $dbh->table_info("%", "%", "%", "TABLE", { foo_bar => $go_request_count }); + is $go_request_count + 1, $dbh->{go_request_count}; + + my $sth_ti2 = $dbh->table_info("%", "%", "%", "TABLE", { foo_bar => $go_request_count }); # should use cache + is $go_request_count + 1, $dbh->{go_request_count}; +} + + ok $dbh->disconnect; +} + +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 $@ +} + +done_testing; + +1; |