Hi,
I'm still working on and off with execute_array problems hoping to get
DBI and the spec to match and also investigating if the current
implementation covers all possibilities. I've now written a simple test
to see if it complies with the specification (and will include it in
DBD::ODBC) and I don't think it does. The main point is:
the pod says:
"The |ArrayTupleStatus| attribute can be used to specify a reference to
an array which will receive the execute status of each executed
parameter tuple. Note the |ArrayTupleStatus| attribute was mandatory
until DBI 1.38.
For tuples which are successfully executed, the element at the same
ordinal position in the status array is the resulting rowcount. If the
execution of a tuple causes an error, then the corresponding status
array element will be set to a reference to an array containing the
error code and error string set by the failed execution."
but the test shows the ArrayTupleStatus contains 3 elements on an error
and not "an array containing the error code and error string set by the
failed execution".
e.g.,:
# $VAR1 = [
# 1,
# 1,
# 1,
# [
# 1,
# '[unixODBC][Easysoft][SQL Server Driver 10.0][SQL
Server]Violation
of PRIMARY KEY constraint \'PK__PERL_DBD__3BD0198E526429B0\'. Cannot
insert dup
licate key in object \'dbo.PERL_DBD_execute_array\'. (SQL-23000) [state
was 2300
0 now 01000]
# [unixODBC][Easysoft][SQL Server Driver 10.0][SQL Server]The statement
has been
terminated. (SQL-01000)',
# '01000'
# ],
# 1
# ];
It is down to the following line of code:
push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ];
so I guess the pod should say:
"If the execution of a tuple causes an error, then the corresponding
status array element will be set to a reference to an array containing
the err, errstr and state set by the failed execution. If that is the
case let me know and I'll amend the pod. Otherwise, I'll need to know
what was intended.
Attached is my current test code but I'm still working on it. In
particular, I've not found an ODBC driver which aborts on the first
insert failure yet.
Martin
#!/usr/bin/perl -w -I./t
# $Id$
use Test::More;
use strict;
use Data::Dumper;
$| = 1;
my $has_test_nowarnings = 1;
eval "require Test::NoWarnings";
$has_test_nowarnings = undef if $@;
my $table = 'PERL_DBD_execute_array';
my $table2 = 'PERL_DBD_execute_array2';
my @captured_error; # values captured in error handler
my $dbh;
my @p1 = (1,2,3,4,5);
my @p2 = qw(one two three four five);
my $fetch_row = 0;
use DBI qw(:sql_types);
#use_ok('ODBCTEST');
use_ok('Data::Dumper');
BEGIN {
plan skip_all => "DBI_DSN is undefined"
if (!defined $ENV{DBI_DSN});
}
END {
if ($dbh) {
drop_table($dbh);
}
Test::NoWarnings::had_no_warnings()
if ($has_test_nowarnings);
done_testing();
}
sub error_handler
{
@captured_error = @_;
diag("***** error handler called *****");
0; # pass errors on
}
sub create_table
{
my $dbh = shift;
eval {
$dbh->do(qq/create table $table (a int primary key, b char(20))/);
};
if ($@) {
diag("Failed to create test table $table - $@");
return 0;
}
eval {
$dbh->do(qq/create table $table2 (a int primary key, b char(20))/);
};
if ($@) {
diag("Failed to create test table $table2 - $@");
return 0;
}
my $sth = $dbh->prepare(qq/insert into $table2 values(?,?)/);
for (my $row = 0; $row < @p1; $row++) {
$sth->execute($p1[$row], $p2[$row]);
}
1;
}
sub drop_table
{
my $dbh = shift;
eval {
local $dbh->{PrintError} = 0;
local $dbh->{PrintWarn} = 0;
$dbh->do(qq/drop table $table/);
$dbh->do(qq/drop table $table2/);
};
diag("Table dropped");
}
sub clear_table
{
$_[0]->do(qq/delete from $table/);
}
sub check_data
{
my ($dbh, $c1, $c2) = @_;
my $data = $dbh->selectall_arrayref(qq/select * from $table/);
my $row = 0;
foreach (@$data) {
is($_->[0], $c1->[$row], "row $row p1 data");
is($_->[1], $c2->[$row], "row $row p2 data");
$row++;
}
}
sub check_tuple_status
{
my ($tsts, $expected) = @_;
diag(Data::Dumper->Dump([$tsts], [qw(ArrayTupleStatus)]));
my $row = 0;
foreach my $s (@$tsts) {
if (ref($expected->[$row])) {
is(ref($s), 'ARRAY', 'array in array tuple status');
is(scalar(@$s), 2, '2 elements in array tuple status error');
} else {
is($s, $expected->[$row], "row $row tuple status");
}
$row++
}
}
sub insert
{
my ($dbh, $sth, $ref) = @_;
die "need hashref arg" if (!$ref || (ref($ref) ne 'HASH'));
diag("insert " . join(", ", map {"$_ = ". DBI::neat($ref->{$_})} keys %$ref
));
@captured_error = ();
if ($ref->{raise}) {
$sth->{RaiseError} = 1;
} else {
$sth->{RaiseError} = 0;
}
my (@tuple_status, $sts, $total_affected);
$sts = 999999; # to ensure it is overwritten
$total_affected = 999998;
if ($ref->{array_context}) {
eval {
if ($ref->{params}) {
($sts, $total_affected) =
$sth->execute_array({ArrayTupleStatus => \@tuple_status},
@{$ref->{params}});
} elsif ($ref->{fetch}) {
($sts, $total_affected) =
$sth->execute_array(
{ArrayTupleStatus => \@tuple_status,
ArrayTupleFetch => $ref->{fetch}});
} else {
($sts, $total_affected) =
$sth->execute_array({ArrayTupleStatus => \@tuple_status});
}
};
} else {
eval {
if ($ref->{params}) {
$sts =
$sth->execute_array({ArrayTupleStatus => \@tuple_status},
@{$ref->{params}});
} else {
$sts =
$sth->execute_array({ArrayTupleStatus => \@tuple_status});
}
};
}
if ($ref->{error} && $ref->{raise}) {
ok($@, 'error in execute_array eval');
} else {
ok(!$@, 'no error in execute_array eval') or diag($@);
}
$dbh->commit if $ref->{commit};
if (!$ref->{raise} || ($ref->{error} == 0)) {
if (exists($ref->{sts})) {
is($sts, $ref->{sts},
"execute_array returned " . DBI::neat($sts) . " rows executed");
}
if (exists($ref->{affected}) && $ref->{array_context}) {
is($total_affected, $ref->{affected},
"total affected " . DBI::neat($total_affected))
}
}
if ($ref->{raise}) {
if ($ref->{error}) {
ok(scalar(@captured_error) > 0, "error captured");
} else {
is(scalar(@captured_error), 0, "no error captured");
}
}
if ($ref->{sts}) {
is(scalar(@tuple_status), (($ref->{sts} eq '0E0') ? 0 : $ref->{sts}),
"$ref->{sts} rows in tuple_status");
}
if ($ref->{tuple}) {
check_tuple_status(\@tuple_status, $ref->{tuple});
}
}
# simple test on ensure execute_array with no errors:
# o checks returned status and affected is correct
# o checks ArrayTupleStatus is correct
# o checks no error is raised
# o checks rows are inserted
# o run twice with AutoCommit on/off
# o checks if less values are specified for one parameter the right number
# of rows are still inserted and NULLs are placed in the missing rows
# checks binding via bind_param_array and adding params to execute_array
# checks binding no parameters at all
sub simple
{
my ($dbh, $ref) = @_;
diag('simple tests ' . join(", ", map {"$_ = $ref->{$_}"} keys %$ref ));
diag(" all param arrays the same size");
foreach my $commit (1,0) {
diag(" Autocommit: $commit");
clear_table($dbh);
$dbh->begin_work if !$commit;
my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
$sth->bind_param_array(1, \@p1);
$sth->bind_param_array(2, \@p2);
insert($dbh, $sth,
{ commit => !$commit, error => 0, sts => 5, affected => 5,
tuple => [1, 1, 1, 1, 1], %$ref});
check_data($dbh, \@p1, \@p2);
}
diag " Not all param arrays the same size";
clear_table($dbh);
my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
$sth->bind_param_array(1, \@p1);
$sth->bind_param_array(2, [qw(one)]);
insert($dbh, $sth, {commit => 0, error => 0,
raise => 1, sts => 5, affected => 5,
tuple => [1, 1, 1, 1, 1], %$ref});
check_data($dbh, \@p1, ['one', undef, undef, undef, undef]);
diag " Not all param arrays the same size with bind on execute_array";
clear_table($dbh);
$sth = $dbh->prepare(qq/insert into $table values(?,?)/);
insert($dbh, $sth, {commit => 0, error => 0,
raise => 1, sts => 5, affected => 5,
tuple => [1, 1, 1, 1, 1], %$ref,
params => [\@p1, [qw(one)]]});
check_data($dbh, \@p1, ['one', undef, undef, undef, undef]);
diag " no parameters";
clear_table($dbh);
$sth = $dbh->prepare(qq/insert into $table values(?,?)/);
insert($dbh, $sth, {commit => 0, error => 0,
raise => 1, sts => '0E0', affected => 0,
tuple => [], %$ref,
params => [[], []]});
check_data($dbh, \@p1, ['one', undef, undef, undef, undef]);
}
# error test to ensure correct behavior for execute_array when it errors:
# o execute_array of 5 inserts with last one failing
# o check it raises an error
# o check caught error is passed on from handler for eval
# o check returned status and affected rows
# o check ArrayTupleStatus
# o check valid inserts are inserted
# o execute_array of 5 inserts with 2nd last one failing
# o check it raises an error
# o check caught error is passed on from handler for eval
# o check returned status and affected rows
# o check ArrayTupleStatus
# o check valid inserts are inserted
sub error
{
my ($dbh, $ref) = @_;
die "need hashref arg" if (!$ref || (ref($ref) ne 'HASH'));
diag('error tests ' . join(", ", map {"$_ = $ref->{$_}"} keys %$ref ));
# diag("Last row in error, array_context=$array_context");
# breaks easysoft sql server driver
# clear_table($dbh);
# my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
# my @pe1 = @p1;
# $pe1[-1] = 1;
# $sth->bind_param_array(1, \@pe1);
# $sth->bind_param_array(2, \@p2);
# insert($dbh, $sth, 0, 1, 5, 5, [1, 1, 1, 1, []]);
# check_data($dbh, [@pe1[0..4]], [@p2[0..4]]);
diag("2nd last row in error");
clear_table($dbh);
my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
my @pe1 = @p1;
$pe1[-2] = 1;
$sth->bind_param_array(1, \@pe1);
$sth->bind_param_array(2, \@p2);
insert($dbh, $sth, {commit => 0, error => 1, sts => undef,
affected => undef, tuple => [1, 1, 1, [], 1], %$ref});
check_data($dbh, [@pe1[0..2],$pe1[4]], [@p2[0..2], $p2[4]]);
}
sub fetch_sub
{
diag("fetch_sub");
return undef if ($fetch_row == scalar(@p1));
return [$p1[$fetch_row], $p2[$fetch_row++]];
}
# test insertion via execute_array and ArrayTupleFetch
sub row_wise
{
my ($dbh, $ref) = @_;
diag("row_size via execute_for_fetch");
$fetch_row = 0;
clear_table($dbh);
my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
insert($dbh, $sth,
{commit => 0, error => 0, sts => 5, affected => 5,
tuple => [1, 1, 1, 1, 1], %$ref,
fetch => \&fetch_sub});
# NOTE: I'd like to do the following test but it requires Multiple
# Active Statements and although I can find ODBC drivers which do this
# it is not easy (if at all possible) to know if an ODBC driver can
# handle MAS or not.
# diag("row_size via select");
# clear_table($dbh);
# my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
# my $sth2 = $dbh->prepare(qq/select * from $table2/);
# $sth2->execute;
# insert($dbh, $sth,
# {commit => 0, error => 0, sts => 5, affected => 5,
# tuple => [1, 1, 1, 1, 1], %$ref,
# fetch => $sth2});
#
}
$dbh = DBI->connect();
unless($dbh) {
BAIL_OUT("Unable to connect to the database $DBI::errstr\nTests skipped.\n");
exit 0;
}
$dbh->{RaiseError} = 1;
$dbh->{PrintError} = 0;
$dbh->{ChopBlanks} = 1;
$dbh->{HandleError} = \&error_handler;
$dbh->{AutoCommit} = 1;
drop_table($dbh);
ok(create_table($dbh), "create test table") or exit 1;
simple($dbh, {array_context => 1, raise => 1});
simple($dbh, {array_context => 0, raise => 1});
error($dbh, {array_context => 1, raise => 1});
error($dbh, {array_context => 0, raise => 1});
error($dbh, {array_context => 1, raise => 0});
error($dbh, {array_context => 0, raise => 0});
row_wise($dbh, {array_context => 1, raise => 1});
