#!perl -w
$|=1;
use strict;
use Test::More tests => 55;
## ----------------------------------------------------------------------------
## 15array.t
## ----------------------------------------------------------------------------
#
## ----------------------------------------------------------------------------
BEGIN {
use_ok('DBI');
}
# create a database handle
my $dbh = DBI->connect("dbi:Sponge:dummy", '', '', {
RaiseError => 1,
ShowErrorStatement => 1,
AutoCommit => 1
});
# check that our db handle is good
isa_ok($dbh, "DBI::db");
my $rv;
my $rows = [];
my $tuple_status = [];
my $dumped;
my $sth = $dbh->prepare("insert", {
rows => $rows, # where to 'insert' (push) the rows
NUM_OF_PARAMS => 4,
execute_hook => sub { # DBD::Sponge hook to make certain data trigger an error for that row
local $^W;
return $_[0]->set_err(1,"errmsg") if grep { $_ and $_ eq "B" } @_;
return 1;
}
});
isa_ok($sth, "DBI::st");
cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
# -----------------------------------------------
ok(! eval {
local $sth->{PrintError} = 0;
$sth->execute_array(
{
ArrayTupleStatus => $tuple_status
},
[ 1, 2, 3 ], # array of integers
42, # scalar 42 treated as array of 42's
undef, # scalar undef treated as array of undef's
[ qw(A B C) ], # array of strings
) },
'... execute_array should return false'
);
ok $@, 'execute_array failure with RaiseError should have died';
like $sth->errstr, '/executing 3 generated 1 errors/';
cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows');
cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
ok(eq_array(
$rows,
[ [1, 42, undef, 'A'], [3, 42, undef, 'C'] ]
),
'... our rows are as expected');
ok(eq_array(
$tuple_status,
[1, [1, 'errmsg', 'S1000'], 1]
),
'... our tuple_status is as expected');
# -----------------------------------------------
# --- change one param and re-execute
@$rows = ();
ok( $sth->bind_param_array(4, [ qw(a b c) ]), '... bind_param_array should return true');
ok( $sth->execute_array({ ArrayTupleStatus => $tuple_status }), '... execute_array should return true');
cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows');
cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
ok(eq_array(
$rows,
[ [1, 42, undef, 'a'], [2, 42, undef, 'b'], [3, 42, undef, 'c'] ]
),
'... our rows are as expected');
ok(eq_array(
$tuple_status,
[1, 1, 1]
),
'... our tuple_status is as expected');
# -----------------------------------------------
# --- call execute_array in array context to get executed AND affected
@$rows = ();
my ($executed, $affected) = $sth->execute_array({ ArrayTupleStatus => $tuple_status });
ok($executed, '... execute_array should return true');
cmp_ok($executed, '==', 3, '... we should have executed 3 rows');
cmp_ok($affected, '==', 3, '... we should have affected 3 rows');
# -----------------------------------------------
# --- with no values for bind params, should execute zero times
@$rows = ();
$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [], [], [], []);
ok($rv, '... execute_array should return true');
ok(!($rv+0), '... execute_array should return 0 (but true)');
cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status');
# -----------------------------------------------
# --- with only scalar values for bind params, should execute just once
@$rows = ();
$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 5, 6, 7, 8);
cmp_ok($rv, '==', 1, '... execute_array should return 1');
cmp_ok(scalar @{$rows}, '==', 1, '... we should have 1 rows');
ok(eq_array( $rows, [ [5,6,7,8] ]), '... our rows are as expected');
cmp_ok(scalar @{$tuple_status}, '==', 1,'... we should have 1 tuple_status');
ok(eq_array( $tuple_status, [1]), '... our tuple_status is as expected');
# -----------------------------------------------
# --- with mix of scalar values and arrays only arrays control tuples
@$rows = ();
$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 5, [], 7, 8);
cmp_ok($rv, '==', 0, '... execute_array should return 0');
cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status');
# -----------------------------------------------
# --- catch 'undefined value' bug with zero bind values
@$rows = ();
my $sth_other = $dbh->prepare("insert", {
rows => $rows, # where to 'insert' (push) the rows
NUM_OF_PARAMS => 1,
});
isa_ok($sth_other, "DBI::st");
$rv = $sth_other->execute_array( {}, [] );
ok($rv, '... execute_array should return true');
ok(!($rv+0), '... execute_array should return 0 (but true)');
# no ArrayTupleStatus
cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
# -----------------------------------------------
# --- ArrayTupleFetch code-ref tests ---
my $index = 0;
my $fetchrow = sub { # generate 5 rows of two integer values
return if $index >= 2;
$index +=1;
# There doesn't seem any reliable way to force $index to be
# treated as a string (and so dumped as such). We just have to
# make the test case allow either 1 or '1'.
return [ $index, 'a','b','c' ];
};
@$rows = ();
ok( $sth->execute_array({
ArrayTupleFetch => $fetchrow,
ArrayTupleStatus => $tuple_status
}), '... execute_array should return true');
cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows');
cmp_ok(scalar @{$tuple_status}, '==', 2, '... we should have 2 tuple_status');
ok(eq_array(
$rows,
[ [1, 'a', 'b', 'c'], [2, 'a', 'b', 'c'] ]
),
'... rows should match'
);
ok(eq_array(
$tuple_status,
[1, 1]
),
'... tuple_status should match'
);
# -----------------------------------------------
# --- ArrayTupleFetch sth tests ---
my $fetch_sth = $dbh->prepare("foo", {
rows => [ map { [ $_,'x','y','z' ] } 7..9 ],
NUM_OF_FIELDS => 4
});
isa_ok($fetch_sth, "DBI::st");
$fetch_sth->execute();
@$rows = ();
ok( $sth->execute_array({
ArrayTupleFetch => $fetch_sth,
ArrayTupleStatus => $tuple_status,
}), '... execute_array should return true');
cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows');
cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
ok(eq_array(
$rows,
[ [7, 'x', 'y', 'z'], [8, 'x', 'y', 'z'], [9, 'x', 'y', 'z'] ]
),
'... rows should match'
);
ok(eq_array(
$tuple_status,
[1, 1, 1]
),
'... tuple status should match'
);
# -----------------------------------------------
# --- error detection tests ---
$sth->{RaiseError} = 0;
$sth->{PrintError} = 0;
ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [1],[2]), '... execute_array should return undef');
is($sth->errstr, '2 bind values supplied but 4 expected', '... errstr is as expected');
ok(!defined $sth->execute_array( { ArrayTupleStatus => { } }, [ 1, 2, 3 ]), '... execute_array should return undef');
is( $sth->errstr, 'ArrayTupleStatus attribute must be an arrayref', '... errstr is as expected');
ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 1,{},3,4), '... execute_array should return undef');
is( $sth->errstr, 'Value for parameter 2 must be a scalar or an arrayref, not a HASH', '... errstr is as expected');
ok(!defined $sth->bind_param_array(":foo", [ qw(a b c) ]), '... bind_param_array should return undef');
is( $sth->errstr, "Can't use named placeholder ':foo' for non-driver supported bind_param_array", '... errstr is as expected');
$dbh->disconnect;
1;