view release on metacpan or  search on metacpan

t/50dbm_simple.t  view on Meta::CPAN

	    [ 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;f_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));