#!perl -w
$|=1;
use strict;
use File::Path;
use File::Spec;
use Test::More;
use Cwd;
use Config qw(%Config);
my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i;
use DBI;
use vars qw( @mldbm_types @dbm_types );
BEGIN {
# Be conservative about what modules we use here.
# We don't want to be tripped up by a badly installed module
# so we remove from @INC any version-specific dirs that don't
# also have an arch-specific dir. Plus, for 5.8 remove any <=5.7
# 0=SQL::Statement if avail, 1=DBI::SQL::Nano
# next line forces use of Nano rather than default behaviour
$ENV{DBI_SQL_NANO}=1;
push @mldbm_types, '';
if (eval { require 'MLDBM.pm'; }) {
push @mldbm_types, 'Data::Dumper' if eval { require 'Data/Dumper.pm' };
push @mldbm_types, 'Storable' if eval { require 'Storable.pm' };
}
# 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);
if ("@ARGV" eq "all") {
# test with as many of the major DBM types as are available
@dbm_types = grep { eval { local $^W; require "$_.pm" } } @dbms;
}
elsif (@ARGV) {
@dbm_types = @ARGV;
}
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;
}
}
}
print "Using DBM modules: @dbm_types\n";
print "Using MLDBM serializers: @mldbm_types\n" if @mldbm_types;
my $tests_in_group = 14;
my $num_tests = @dbm_types * @mldbm_types * $tests_in_group;
printf "Test count: %d x %d x %d = %d\n",
scalar @dbm_types, 0+@mldbm_types, $tests_in_group, $num_tests;
if (!$num_tests) {
plan skip_all => "No DBM modules available";
}
else {
plan tests => $num_tests;
}
}
my $dir = File::Spec->catdir(getcwd(),'test_output');
rmtree $dir;
mkpath $dir;
my( $two_col_sql,$three_col_sql ) = split /\n\n/,join '',<DATA>;
for my $mldbm ( @mldbm_types ) {
my $sql = ($mldbm) ? $three_col_sql : $two_col_sql;
my @sql = split /\n/, $sql;
for my $dbm_type ( @dbm_types ) {
print "\n--- Using $dbm_type ($mldbm) ---\n";
eval { do_test( $dbm_type, \@sql, $mldbm ) }
or warn $@;
}
}
rmtree $dir;
sub do_test {
my $dtype = shift;
my $stmts = shift;
my $mldbm = shift;
# 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.)
my $dsn ="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;mldbm=$mldbm;lockfile=0";
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');
}
print $dbm_versions;
ok($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($@);
for my $sql ( @$stmts ) {
$sql =~ s/\S*fruit/${dtype}_fruit/; # include dbm type in table name
$sql =~ s/;$//; # in case no final \n on last line of __DATA__
#diag($sql);
my $null = '';
my $expected_results = {
1 => 'oranges',
2 => 'apples',
3 => $null,
5 => 'via placeholders',
};
$expected_results = {
1 => '11',
2 => '12',
3 => '13',
5 => '15',
} if $mldbm;
print " $sql\n";
$sql =~ s/\s*;\s*(?:#(.*))//;
my $comment = $1;
my $sth = $dbh->prepare($sql) or die $dbh->errstr;
my @bind;
@bind = split /,/, $comment if $sth->{NUM_OF_PARAMS};
$sth->execute(@bind);
die $sth->errstr if $sth->err and $sql !~ /DROP/;
next unless $sql =~ /SELECT/;
my $results='';
# Note that we can't rely on the order here, it's not portable,
# different DBMs (or versions) will return different orders.
while (my ($key, $value) = $sth->fetchrow_array) {
ok exists $expected_results->{$key};
is $value, $expected_results->{$key};
}
is $DBI::rows, keys %$expected_results;
}
$dbh->disconnect;
return 1;
}
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' );
INSERT INTO fruit VALUES (?,?); #5,via placeholders
UPDATE fruit SET dVal='apples' WHERE dKey=2;
DELETE FROM fruit WHERE dVal='to delete';
SELECT * FROM fruit;
DROP TABLE fruit;
DROP TABLE IF EXISTS multi_fruit;
CREATE TABLE multi_fruit (dKey INT, dVal VARCHAR(10), qux INT);
INSERT INTO multi_fruit VALUES (1,'oranges' , 11 );
INSERT INTO multi_fruit VALUES (2,'apples' , 0 );
INSERT INTO multi_fruit VALUES (3, NULL , 13 );
INSERT INTO multi_fruit VALUES (4,'to_delete', 14 );
INSERT INTO multi_fruit VALUES (?,?,?); #5,via placeholders,15
UPDATE multi_fruit SET qux='12' WHERE dKey=2;
DELETE FROM multi_fruit WHERE dKey=4;
SELECT dKey,qux FROM multi_fruit;
DROP TABLE multi_fruit;