Author: REHSACK
Date: Sun May 23 09:33:32 2010
New Revision: 14014
Modified:
dbi/trunk/t/50dbm_simple.t
Log:
refactor DBD::DBM simple tests to prove each executed statement
Modified: dbi/trunk/t/50dbm_simple.t
==============================================================================
--- dbi/trunk/t/50dbm_simple.t (original)
+++ dbi/trunk/t/50dbm_simple.t Sun May 23 09:33:32 2010
@@ -7,20 +7,15 @@
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 );
-my $tests_in_group;
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;
@@ -28,14 +23,13 @@
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' };
+ push @mldbm_types, qw(Data::Dumper Storable); # both in CORE
push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.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 NDBM_File ODBM_File GDBM_File DB_File BerkeleyDB);
+ 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};
@@ -60,21 +54,6 @@
}
}
}
-
- print "Using DBM modules: @dbm_types\n";
- print "Using MLDBM serializers: @mldbm_types\n" if @mldbm_types;
-
- $tests_in_group = 15;
- 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');
@@ -82,11 +61,76 @@
rmtree $dir;
mkpath $dir;
-my( $two_col_sql,$three_col_sql ) = split /\n\n/,join '',<DATA>;
+my %expected_results = (
+ 2 => [
+ "DROP TABLE IF EXISTS fruit", undef,
+ "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' ],
+ ],
+ "DROP TABLE fruit", -1,
+ ],
+ 3 => [
+ "DROP TABLE IF EXISTS multi_fruit", undef,
+ "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 ],
+ ],
+ "DROP TABLE multi_fruit", -1,
+ ],
+);
+
+print "Using DBM modules: @dbm_types\n";
+print "Using MLDBM serializers: @mldbm_types\n" if @mldbm_types;
+
+my $tests_offsets_group = 5;
+my $ndbm_types = scalar @dbm_types;
+my $nmldbm_types = scalar @mldbm_types;
+my $tests_without_mldbm = $tests_offsets_group + scalar(@{$expected_results{2}}) / 2 + 1;
+my $tests_with_mldbm = ( $nmldbm_types - 1 ) * ($tests_offsets_group + scalar(@{$expected_results{3}})/2 + 1);
+my $num_tests = $ndbm_types * ( $tests_without_mldbm + $tests_with_mldbm );
+printf "Test count: %d x ( ( %d + %d ) + %d x ( %d + %d ) ) = %d\n",
+ scalar $ndbm_types, $tests_offsets_group, scalar(@{$expected_results{2}}) / 2 + 1,
+ $nmldbm_types - 1, $tests_offsets_group, scalar(@{$expected_results{3}})/2 + 1,
+ $num_tests;
+
+if (!$num_tests) {
+ plan skip_all => "No DBM modules available";
+}
+else {
+ plan tests => $num_tests;
+}
for my $mldbm ( @mldbm_types ) {
- my $sql = ($mldbm) ? $three_col_sql : $two_col_sql;
- my @sql = split /\n/, $sql;
+ my @sql = ($mldbm) ? @{$expected_results{3}} : @{$expected_results{2}};
for my $dbm_type ( @dbm_types ) {
print "\n--- Using $dbm_type ($mldbm) ---\n";
eval { do_test( $dbm_type, $mldbm, @sql) }
@@ -95,8 +139,16 @@
}
rmtree $dir;
+# XXX from PP part of List::MoreUtils
+sub part(&@) {
+ my ($code, @list) = @_;
+ my @parts;
+ push @{ $parts[$code->($_)] }, $_ for @list;
+ return @parts;
+}
+
sub do_test {
- my ($dtype, $mldbm, @sql) = @_;
+ my ($dtype, $mldbm, @sqltests) = @_;
my $test_builder = Test::More->builder;
my $starting_test_no = $test_builder->current_test;
@@ -106,7 +158,7 @@
# 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";
+ my $dsn ="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;dbm_mldbm=$mldbm;dbm_lockfile=1";
if ($using_dbd_gofer) {
$dsn .= ";f_dir=$dir";
@@ -147,87 +199,49 @@
};
ok($@);
+ # XXX I would prefer use List::Moreutils::part ...
+ my $i = 0;
+ my @tests = part { $i++ % 2 } @sqltests;
+ my @queries = @{$tests[0]};
+ my @results = @{dclone $tests[1]};
+
SKIP:
- for my $sql ( @sql ) {
+ for my $idx ( 0 .. $#queries ) {
+ my $sql = $queries[$idx];
$sql =~ s/\S*fruit/${dtype}_fruit/; # include dbm type in table name
- $sql =~ s/;$//; # in case no final \n on last line of __DATA__
+ $sql =~ s/;$//;
#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 ...";
+ # 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) or die $dbh->errstr;
- my @bind;
- @bind = split /,/, $comment if $sth->{NUM_OF_PARAMS};
+ my $sth = $dbh->prepare($sql);
+ unless( $sth ) {
+ skip "prepare failed: " . $dbh->errstr || 'unknown error',
+ ($sql =~ /SELECT/) ? 2 : 1;
+ }
+ my @bind = split /,/, $comment if $sth->{NUM_OF_PARAMS};
# if execute errors we will handle it, not PrintError:
$sth->{PrintError} = 0;
my $n = $sth->execute(@bind);
- print DBI::neat($n), "\n"; # execute might fail
- if ($sth->err and $sql !~ /DROP/) {
+ if ($sth->err and $sql !~ /^DROP/ ) {
skip "execute failed: " . $sth->errstr || 'unknown error',
- ($starting_test_no + $tests_in_group - $test_builder->current_test);
- die $sth->errstr if $sth->err and $sql !~ /DROP/;
+ ($sql =~ /SELECT/) ? 2 : 1;
}
+ is( $n, $results[$idx], $sql ) unless( 'ARRAY' eq ref $results[$idx] );
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.
- my @key_order;
- while (my ($key, $value) = $sth->fetchrow_array) {
- ok exists $expected_results->{$key};
- is $value, $expected_results->{$key};
- push @key_order, $key;
- }
- is $DBI::rows, keys %$expected_results;
- is_deeply( \@key_order, [ 5, 3, 2, 1 ], 'select result order' );
+ my $allrows = $sth->fetchall_arrayref();
+ my $expected_rows = $results[$idx];
+ is( $DBI::rows, scalar( @{$expected_rows} ), $sql );
+ is_deeply( $allrows, $expected_rows, 'SELECT 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
-INSERT INTO fruit VALUES (6,'to delete' );
-INSERT INTO fruit VALUES (7,'to_delete' );
-DELETE FROM fruit WHERE dVal='to delete';
-UPDATE fruit SET dVal='apples' WHERE dKey=2;
-DELETE FROM fruit WHERE dKey=7;
-SELECT * FROM fruit ORDER BY dKey DESC;
-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,'to_change', 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
-INSERT INTO multi_fruit VALUES (6,'to_delete', 16 );
-INSERT INTO multi_fruit VALUES (7,'to delete', 17 );
-INSERT INTO multi_fruit VALUES (8,'to remove', 18 );
-UPDATE multi_fruit SET dVal='apples', qux='12' WHERE dKey=2;
-DELETE FROM multi_fruit WHERE dVal='to_delete';
-DELETE FROM multi_fruit WHERE qux=17;
-DELETE FROM multi_fruit WHERE dKey=8;
-SELECT dKey,qux FROM multi_fruit ORDER BY dKey DESC;
-DROP TABLE multi_fruit;
lmpx.com only provides a reader for public news (NNTP) servers. It is not
affiliated with the servers or forums shown here and is not responsible for
the content of articles, which is written by their respective authors.