diff options
Diffstat (limited to 't/50dbm_simple.t')
| -rwxr-xr-x | t/50dbm_simple.t | 264 |
1 files changed, 264 insertions, 0 deletions
diff --git a/t/50dbm_simple.t b/t/50dbm_simple.t new file mode 100755 index 0000000..e176161 --- /dev/null +++ b/t/50dbm_simple.t @@ -0,0 +1,264 @@ +#!perl -w +$|=1; + +use strict; +use warnings; + +require DBD::DBM; + +use File::Path; +use File::Spec; +use Test::More; +use Cwd; +use Config qw(%Config); +use Storable qw(dclone); + +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i; + +use DBI; +use vars qw( @mldbm_types @dbm_types ); + +BEGIN { + + # 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 zv*n*_50dbm_simple.t + + push @mldbm_types, ''; + if (eval { require 'MLDBM.pm'; }) { + push @mldbm_types, qw(Data::Dumper Storable); # both in CORE + push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.pm' }; + push @mldbm_types, 'YAML' if eval { require MLDBM::Serializer::YAML; }; + push @mldbm_types, 'JSON' if eval { require MLDBM::Serializer::JSON; }; + } + + # Potential DBM modules in preference order (SDBM_File first) + # skip NDBM and ODBM as they don't support EXISTS + my @dbms = qw(SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File); + my @use_dbms = @ARGV; + if( !@use_dbms && $ENV{DBD_DBM_TEST_BACKENDS} ) { + @use_dbms = split ' ', $ENV{DBD_DBM_TEST_BACKENDS}; + } + + if (lc "@use_dbms" eq "all") { + # test with as many of the major DBM types as are available + @dbm_types = grep { eval { local $^W; require "$_.pm" } } @dbms; + } + elsif (@use_dbms) { + @dbm_types = @use_dbms; + } + else { + # we only test SDBM_File by default to avoid tripping up + # on any broken DBM's that may be installed in odd places. + # It's only DBD::DBM we're trying to test here. + # (However, if SDBM_File is not available, then use another.) + for my $dbm (@dbms) { + if (eval { local $^W; require "$dbm.pm" }) { + @dbm_types = ($dbm); + last; + } + } + } + + if( eval { require List::MoreUtils; } ) + { + List::MoreUtils->import("part"); + } + else + { + # XXX from PP part of List::MoreUtils + eval <<'EOP'; +sub part(&@) { + my ($code, @list) = @_; + my @parts; + push @{ $parts[$code->($_)] }, $_ for @list; + return @parts; +} +EOP + } +} + +my $dbi_sql_nano = not DBD::DBM::Statement->isa('SQL::Statement'); + +do "t/lib.pl"; + +my $dir = test_dir (); + +my %tests_statement_results = ( + 2 => [ + "DROP TABLE IF EXISTS fruit", -1, + "CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))", '0E0', + "INSERT INTO fruit VALUES (1,'oranges' )", 1, + "INSERT INTO fruit VALUES (2,'to_change' )", 1, + "INSERT INTO fruit VALUES (3, NULL )", 1, + "INSERT INTO fruit VALUES (4,'to delete' )", 1, + "INSERT INTO fruit VALUES (?,?); #5,via placeholders", 1, + "INSERT INTO fruit VALUES (6,'to delete' )", 1, + "INSERT INTO fruit VALUES (7,'to_delete' )", 1, + "DELETE FROM fruit WHERE dVal='to delete'", 2, + "UPDATE fruit SET dVal='apples' WHERE dKey=2", 1, + "DELETE FROM fruit WHERE dKey=7", 1, + "SELECT * FROM fruit ORDER BY dKey DESC", [ + [ 5, 'via placeholders' ], + [ 3, '' ], + [ 2, 'apples' ], + [ 1, 'oranges' ], + ], + "DELETE FROM fruit", 4, + $dbi_sql_nano ? () : ( "SELECT COUNT(*) FROM fruit", [ [ 0 ] ] ), + "DROP TABLE fruit", -1, + ], + 3 => [ + "DROP TABLE IF EXISTS multi_fruit", -1, + "CREATE TABLE multi_fruit (dKey INT, dVal VARCHAR(10), qux INT)", '0E0', + "INSERT INTO multi_fruit VALUES (1,'oranges' , 11 )", 1, + "INSERT INTO multi_fruit VALUES (2,'to_change', 0 )", 1, + "INSERT INTO multi_fruit VALUES (3, NULL , 13 )", 1, + "INSERT INTO multi_fruit VALUES (4,'to_delete', 14 )", 1, + "INSERT INTO multi_fruit VALUES (?,?,?); #5,via placeholders,15", 1, + "INSERT INTO multi_fruit VALUES (6,'to_delete', 16 )", 1, + "INSERT INTO multi_fruit VALUES (7,'to delete', 17 )", 1, + "INSERT INTO multi_fruit VALUES (8,'to remove', 18 )", 1, + "UPDATE multi_fruit SET dVal='apples', qux='12' WHERE dKey=2", 1, + "DELETE FROM multi_fruit WHERE dVal='to_delete'", 2, + "DELETE FROM multi_fruit WHERE qux=17", 1, + "DELETE FROM multi_fruit WHERE dKey=8", 1, + "SELECT * FROM multi_fruit ORDER BY dKey DESC", [ + [ 5, 'via placeholders', 15 ], + [ 3, undef, 13 ], + [ 2, 'apples', 12 ], + [ 1, 'oranges', 11 ], + ], + "DELETE FROM multi_fruit", 4, + $dbi_sql_nano ? () : ( "SELECT COUNT(*) FROM multi_fruit", [ [ 0 ] ] ), + "DROP TABLE multi_fruit", -1, + ], +); + +print "Using DBM modules: @dbm_types\n"; +print "Using MLDBM serializers: @mldbm_types\n" if @mldbm_types; + +my %test_statements; +my %expected_results; + +for my $columns ( 2 .. 3 ) +{ + my $i = 0; + my @tests = part { $i++ % 2 } @{ $tests_statement_results{$columns} }; + @{ $test_statements{$columns} } = @{$tests[0]}; + @{ $expected_results{$columns} } = @{$tests[1]}; +} + +unless (@dbm_types) { + plan skip_all => "No DBM modules available"; +} + +for my $mldbm ( @mldbm_types ) { + my $columns = ($mldbm) ? 3 : 2; + for my $dbm_type ( @dbm_types ) { + print "\n--- Using $dbm_type ($mldbm) ---\n"; + eval { do_test( $dbm_type, $mldbm, $columns) } + or warn $@; + } +} + +done_testing(); + +sub do_test { + my ($dtype, $mldbm, $columns) = @_; + + #diag ("Starting test: " . $starting_test_no); + + # The DBI can't test locking here, sadly, because of the risk it'll hang + # on systems with broken NFS locking daemons. + # (This test script doesn't test that locking actually works anyway.) + + # use f_lockfile in next release - use it here as test case only + my $dsn ="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;dbm_mldbm=$mldbm;dbm_lockfile=.lck"; + + if ($using_dbd_gofer) { + $dsn .= ";f_dir=$dir"; + } + + my $dbh = DBI->connect( $dsn ); + + my $dbm_versions; + if ($DBI::VERSION >= 1.37 # needed for install_method + && !$ENV{DBI_AUTOPROXY} # can't transparently proxy driver-private methods + ) { + $dbm_versions = $dbh->dbm_versions; + } + else { + $dbm_versions = $dbh->func('dbm_versions'); + } + note $dbm_versions; + ok($dbm_versions, 'dbm_versions'); + isa_ok($dbh, 'DBI::db'); + + # test if it correctly accepts valid $dbh attributes + SKIP: { + skip "Can't set attributes after connect using DBD::Gofer", 2 + if $using_dbd_gofer; + eval {$dbh->{f_dir}=$dir}; + ok(!$@); + eval {$dbh->{dbm_mldbm}=$mldbm}; + ok(!$@); + } + + # test if it correctly rejects invalid $dbh attributes + # + eval { + local $SIG{__WARN__} = sub { } if $using_dbd_gofer; + local $dbh->{RaiseError} = 1; + local $dbh->{PrintError} = 0; + $dbh->{dbm_bad_name}=1; + }; + ok($@); + + my @queries = @{$test_statements{$columns}}; + my @results = @{$expected_results{$columns}}; + + SKIP: + for my $idx ( 0 .. $#queries ) { + my $sql = $queries[$idx]; + $sql =~ s/\S*fruit/${dtype}_fruit/; # include dbm type in table name + $sql =~ s/;$//; + #diag($sql); + + # XXX FIX INSERT with NULL VALUE WHEN COLUMN NOT NULLABLE + $dtype eq 'BerkeleyDB' and !$mldbm and 0 == index($sql, 'INSERT') and $sql =~ s/NULL/''/; + + $sql =~ s/\s*;\s*(?:#(.*))//; + my $comment = $1; + + my $sth = $dbh->prepare($sql); + ok($sth, "prepare $sql") or diag($dbh->errstr || 'unknown error'); + + my @bind; + if($sth->{NUM_OF_PARAMS}) + { + @bind = split /,/, $comment; + } + # if execute errors we will handle it, not PrintError: + $sth->{PrintError} = 0; + my $n = $sth->execute(@bind); + ok($n, 'execute') or diag($sth->errstr || 'unknown error'); + next if (!defined($n)); + + is( $n, $results[$idx], $sql ) unless( 'ARRAY' eq ref $results[$idx] ); + TODO: { + local $TODO = "AUTOPROXY drivers might throw away sth->rows()" if($ENV{DBI_AUTOPROXY}); + is( $n, $sth->rows, '$sth->execute(' . $sql . ') == $sth->rows' ) if( $sql =~ m/^(?:UPDATE|DELETE)/ ); + } + next unless $sql =~ /SELECT/; + my $results=''; + my $allrows = $sth->fetchall_arrayref(); + my $expected_rows = $results[$idx]; + is( $sth->rows, scalar( @{$expected_rows} ), $sql ); + is_deeply( $allrows, $expected_rows, 'SELECT results' ); + } + $dbh->disconnect; + return 1; +} +1; |