[svn:dbd-oracle] r14708 - dbd-oracle/trunk/t
[email protected] Mon, 21 Feb 2011 12:24:18 -0800 (PST)
| Newsgroups | perl.dbd.oracle.changes |
|---|---|
| Message-ID | <[email protected]> |
Author: mjevans
Date: Mon Feb 21 12:24:17 2011
New Revision: 14708
Modified:
dbd-oracle/trunk/t/26exe_array.t (contents, props changed)
Log:
stop 26exe_array.t from erroring when database connect fails. Change to native line endings
Modified: dbd-oracle/trunk/t/26exe_array.t
==============================================================================
--- dbd-oracle/trunk/t/26exe_array.t (original)
+++ dbd-oracle/trunk/t/26exe_array.t Mon Feb 21 12:24:17 2011
@@ -1,467 +1,468 @@
-#!/usr/bin/perl -w -I./t
-
-## ----------------------------------------------------------------------------
-## 26exe_array.t this is a completly new one
-## By Martin J. Evans orgianlly called 70execute_array.t for the ODBC DBD driver
-## and adatped into DBD::Oracle (in a very minor way) by John Scoles, The Pythian Group
-## ----------------------------------------------------------------------------
-## loads of execute_array and execute_for_fetch tests
-## tests both insert and update and row fetching
-## with RaiseError on and off and AutoCommit on and off
-## ----------------------------------------------------------------------------
-
-use Test::More;
-use strict;
-use Data::Dumper;
-require 'nchar_test_lib.pl';
-
-$| = 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
-
-
-# create a database handle
-my $dsn = oracle_test_dsn();
-my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
-$ENV{NLS_NCHAR} = "US7ASCII";
-$ENV{NLS_LANG} = "AMERICAN";
-
-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);
-
-eval {
- $dbh = DBI->connect($dsn, $dbuser, '');
-};
-
-if (!$dbh) {
- plan skip_all => "Unable to connect to Oracle";
-}
-use_ok('Data::Dumper');
-
-END {
- if ($dbh) {
- drop_table_local($dbh);
- }
- Test::NoWarnings::had_no_warnings()
- if ($has_test_nowarnings);
- done_testing();
-}
-
-sub error_handler
-{
- @captured_error = @_;
- note("***** error handler called *****");
- 0; # pass errors on
-}
-
-sub create_table_local
-{
- 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_local
-{
- my $dbh = shift;
-
- eval {
- local $dbh->{PrintError} = 0;
- local $dbh->{PrintWarn} = 0;
- $dbh->do(qq/drop table $table/);
- $dbh->do(qq/drop table $table2/);
- };
- note("Table dropped");
-}
-
-# clear the named table of rows
-sub clear_table
-{
- $_[0]->do(qq/delete from $_[1]/);
-}
-
-# check $table contains the data in $c1, $c2 which are arrayrefs of values
-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) = @_;
-
- note(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), 3, '3 elements in array tuple status error');
- } else {
- if ($s == -1) {
- pass("row $row tuple status unknown");
- } else {
- is($s, $expected->[$row], "row $row tuple status");
- }
- }
- $row++
- }
-}
-
-# insert might return 'mas' which means the caller said the test
-# required Multiple Active Statements and the driver appeared to not
-# support MAS.
-sub insert
-{
- my ($dbh, $sth, $ref) = @_;
-
- die "need hashref arg" if (!$ref || (ref($ref) ne 'HASH'));
- note("insert " . join(", ", map {"$_ = ". DBI::neat($ref->{$_})} keys %$ref ));
- # DBD::Oracle supports MAS don't compensate for it not
- if ($ref->{requires_mas} && $dbh->{Driver}->{Name} eq 'Oracle') {
- delete $ref->{requires_mas};
- }
- @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 {
- if ($ref->{requires_mas} && $@) {
- diag("\nThis test died with $@");
- diag("It requires multiple active statement support in the driver and I cannot easily determine if your driver supports MAS. Ignoring the rest of this test.");
- foreach (@tuple_status) {
- if (ref($_)) {
- diag(join(",", @$_));
- }
- }
- return 'mas';
- }
- ok(!$@, 'no error in execute_array eval') or note($@);
- }
- $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});
- }
- return;
-}
-# 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) = @_;
-
- note('simple tests ' . join(", ", map {"$_ = $ref->{$_}"} keys %$ref ));
-
- note(" all param arrays the same size");
- foreach my $commit (1,0) {
- note(" Autocommit: $commit");
- clear_table($dbh, $table);
- $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);
- }
-
- note " Not all param arrays the same size";
- clear_table($dbh, $table);
- 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]);
-
- note " Not all param arrays the same size with bind on execute_array";
- clear_table($dbh, $table);
- $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]);
-
- note " no parameters";
- clear_table($dbh, $table);
- $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'));
-
- note('error tests ' . join(", ", map {"$_ = $ref->{$_}"} keys %$ref ));
- {
- note("Last row in error");
-
- clear_table($dbh, $table);
- 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, {commit => 0, error => 1, sts => undef,
- affected => undef, tuple => [1, 1, 1, 1, []],
- %$ref});
- check_data($dbh, [@pe1[0..4]], [@p2[0..4]]);
- }
-
- {
- note("2nd last row in error");
- clear_table($dbh, $table);
- 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
-{
- note("fetch_sub $fetch_row");
- if ($fetch_row == @p1) {
- note('returning undef');
- $fetch_row = 0;
- return;
- }
-
- return [$p1[$fetch_row], $p2[$fetch_row++]];
-}
-
-# test insertion via execute_array and ArrayTupleFetch
-sub row_wise
-{
- my ($dbh, $ref) = @_;
-
- note("row_size via execute_for_fetch");
-
- $fetch_row = 0;
- clear_table($dbh, $table);
- 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. If it errors the driver probably does not have MAS
- # so the error is ignored and a diagnostic is output.
- note("row_size via select");
- clear_table($dbh, $table);
- $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
- my $sth2 = $dbh->prepare(qq/select * from $table2/);
- ok($sth2->execute, 'execute on second table') or diag($sth2->errstr);
- ok($sth2->{Executed}, 'second statement is in executed state');
- my $res = insert($dbh, $sth,
- {commit => 0, error => 0, sts => 5, affected => 5,
- tuple => [1, 1, 1, 1, 1], %$ref,
- fetch => $sth2, requires_mas => 1});
- return if $res && $res eq 'mas'; # aborted , does not seem to support MAS
- check_data($dbh, \@p1, \@p2);
- #my $res = $dbh->selectall_arrayref("select * from $table2");
- #print Dumper($res);
-}
-
-# test updates
-sub update
-{
- my ($dbh, $ref) = @_;
-
- note("update test");
-
- $fetch_row = 0;
- clear_table($dbh, $table);
- 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});
- check_data($dbh, \@p1, \@p2);
-
- $sth = $dbh->prepare(qq/update $table set b = ? where a = ?/);
- # NOTE, this also checks you can pass a scalar to bind_param_array
- $sth->bind_param_array(1, 'fred');
- $sth->bind_param_array(2, \@p1);
- insert($dbh, $sth,
- {commit => 0, error => 0, sts => 5, affected => 5,
- tuple => [1, 1, 1, 1, 1], %$ref});
- check_data($dbh, \@p1, [qw(fred fred fred fred fred)]);
-
- $sth = $dbh->prepare(qq/update $table set b = ? where a = ?/);
- # NOTE, this also checks you can pass a scalar to bind_param_array
- $sth->bind_param_array(1, 'dave');
- my @pe1 = @p1;
- $pe1[-1] = 10; # non-existant row
- $sth->bind_param_array(2, \@pe1);
- insert($dbh, $sth,
- {commit => 0, error => 0, sts => 5, affected => 4,
- tuple => [1, 1, 1, 1, '0E0'], %$ref});
- check_data($dbh, \@p1, [qw(dave dave dave dave fred)]);
-
- $sth = $dbh->prepare(qq/update $table set b = ? where b like ?/);
- # NOTE, this also checks you can pass a scalar to bind_param_array
- $sth->bind_param_array(1, 'pete');
- $sth->bind_param_array(2, ['dave%', 'fred%']);
- insert($dbh, $sth,
- {commit => 0, error => 0, sts => 2, affected => 5,
- tuple => [1, 1], %$ref});
- check_data($dbh, \@p1, [qw(pete pete pete pete pete)]);
-
-
-}
-
-$dbh->{RaiseError} = 1;
-$dbh->{PrintError} = 0;
-$dbh->{ChopBlanks} = 1;
-$dbh->{HandleError} = \&error_handler;
-$dbh->{AutoCommit} = 1;
-
-eval {drop_table_local($dbh)};
-
-ok(create_table_local($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});
-
-update($dbh, {array_context => 1, raise => 1});
+#!/usr/bin/perl -w -I./t
+
+## ----------------------------------------------------------------------------
+## 26exe_array.t this is a completly new one
+## By Martin J. Evans orgianlly called 70execute_array.t for the ODBC DBD driver
+## and adatped into DBD::Oracle (in a very minor way) by John Scoles, The Pythian Group
+## ----------------------------------------------------------------------------
+## loads of execute_array and execute_for_fetch tests
+## tests both insert and update and row fetching
+## with RaiseError on and off and AutoCommit on and off
+## ----------------------------------------------------------------------------
+
+use Test::More;
+use strict;
+use Data::Dumper;
+require 'nchar_test_lib.pl';
+
+$| = 1;
+
+
+my $table = 'PERL_DBD_execute_array';
+my $table2 = 'PERL_DBD_execute_array2';
+my @captured_error; # values captured in error handler
+
+
+# create a database handle
+my $dsn = oracle_test_dsn();
+my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
+$ENV{NLS_NCHAR} = "US7ASCII";
+$ENV{NLS_LANG} = "AMERICAN";
+
+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);
+
+eval {
+ $dbh = DBI->connect($dsn, $dbuser, '', {PrintError => 0});
+};
+
+if (!$dbh) {
+ plan skip_all => "Unable to connect to Oracle";
+}
+$dbh->{PrintError} = 1;
+my $has_test_nowarnings = 1;
+eval "require Test::NoWarnings";
+$has_test_nowarnings = undef if $@;
+use_ok('Data::Dumper');
+
+END {
+ if ($dbh) {
+ drop_table_local($dbh);
+ }
+ Test::NoWarnings::had_no_warnings()
+ if ($has_test_nowarnings);
+ done_testing();
+}
+
+sub error_handler
+{
+ @captured_error = @_;
+ note("***** error handler called *****");
+ 0; # pass errors on
+}
+
+sub create_table_local
+{
+ 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_local
+{
+ my $dbh = shift;
+
+ eval {
+ local $dbh->{PrintError} = 0;
+ local $dbh->{PrintWarn} = 0;
+ $dbh->do(qq/drop table $table/);
+ $dbh->do(qq/drop table $table2/);
+ };
+ note("Table dropped");
+}
+
+# clear the named table of rows
+sub clear_table
+{
+ $_[0]->do(qq/delete from $_[1]/);
+}
+
+# check $table contains the data in $c1, $c2 which are arrayrefs of values
+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) = @_;
+
+ note(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), 3, '3 elements in array tuple status error');
+ } else {
+ if ($s == -1) {
+ pass("row $row tuple status unknown");
+ } else {
+ is($s, $expected->[$row], "row $row tuple status");
+ }
+ }
+ $row++
+ }
+}
+
+# insert might return 'mas' which means the caller said the test
+# required Multiple Active Statements and the driver appeared to not
+# support MAS.
+sub insert
+{
+ my ($dbh, $sth, $ref) = @_;
+
+ die "need hashref arg" if (!$ref || (ref($ref) ne 'HASH'));
+ note("insert " . join(", ", map {"$_ = ". DBI::neat($ref->{$_})} keys %$ref ));
+ # DBD::Oracle supports MAS don't compensate for it not
+ if ($ref->{requires_mas} && $dbh->{Driver}->{Name} eq 'Oracle') {
+ delete $ref->{requires_mas};
+ }
+ @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 {
+ if ($ref->{requires_mas} && $@) {
+ diag("\nThis test died with $@");
+ diag("It requires multiple active statement support in the driver and I cannot easily determine if your driver supports MAS. Ignoring the rest of this test.");
+ foreach (@tuple_status) {
+ if (ref($_)) {
+ diag(join(",", @$_));
+ }
+ }
+ return 'mas';
+ }
+ ok(!$@, 'no error in execute_array eval') or note($@);
+ }
+ $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});
+ }
+ return;
+}
+# 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) = @_;
+
+ note('simple tests ' . join(", ", map {"$_ = $ref->{$_}"} keys %$ref ));
+
+ note(" all param arrays the same size");
+ foreach my $commit (1,0) {
+ note(" Autocommit: $commit");
+ clear_table($dbh, $table);
+ $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);
+ }
+
+ note " Not all param arrays the same size";
+ clear_table($dbh, $table);
+ 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]);
+
+ note " Not all param arrays the same size with bind on execute_array";
+ clear_table($dbh, $table);
+ $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]);
+
+ note " no parameters";
+ clear_table($dbh, $table);
+ $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'));
+
+ note('error tests ' . join(", ", map {"$_ = $ref->{$_}"} keys %$ref ));
+ {
+ note("Last row in error");
+
+ clear_table($dbh, $table);
+ 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, {commit => 0, error => 1, sts => undef,
+ affected => undef, tuple => [1, 1, 1, 1, []],
+ %$ref});
+ check_data($dbh, [@pe1[0..4]], [@p2[0..4]]);
+ }
+
+ {
+ note("2nd last row in error");
+ clear_table($dbh, $table);
+ 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
+{
+ note("fetch_sub $fetch_row");
+ if ($fetch_row == @p1) {
+ note('returning undef');
+ $fetch_row = 0;
+ return;
+ }
+
+ return [$p1[$fetch_row], $p2[$fetch_row++]];
+}
+
+# test insertion via execute_array and ArrayTupleFetch
+sub row_wise
+{
+ my ($dbh, $ref) = @_;
+
+ note("row_size via execute_for_fetch");
+
+ $fetch_row = 0;
+ clear_table($dbh, $table);
+ 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. If it errors the driver probably does not have MAS
+ # so the error is ignored and a diagnostic is output.
+ note("row_size via select");
+ clear_table($dbh, $table);
+ $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
+ my $sth2 = $dbh->prepare(qq/select * from $table2/);
+ ok($sth2->execute, 'execute on second table') or diag($sth2->errstr);
+ ok($sth2->{Executed}, 'second statement is in executed state');
+ my $res = insert($dbh, $sth,
+ {commit => 0, error => 0, sts => 5, affected => 5,
+ tuple => [1, 1, 1, 1, 1], %$ref,
+ fetch => $sth2, requires_mas => 1});
+ return if $res && $res eq 'mas'; # aborted , does not seem to support MAS
+ check_data($dbh, \@p1, \@p2);
+ #my $res = $dbh->selectall_arrayref("select * from $table2");
+ #print Dumper($res);
+}
+
+# test updates
+sub update
+{
+ my ($dbh, $ref) = @_;
+
+ note("update test");
+
+ $fetch_row = 0;
+ clear_table($dbh, $table);
+ 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});
+ check_data($dbh, \@p1, \@p2);
+
+ $sth = $dbh->prepare(qq/update $table set b = ? where a = ?/);
+ # NOTE, this also checks you can pass a scalar to bind_param_array
+ $sth->bind_param_array(1, 'fred');
+ $sth->bind_param_array(2, \@p1);
+ insert($dbh, $sth,
+ {commit => 0, error => 0, sts => 5, affected => 5,
+ tuple => [1, 1, 1, 1, 1], %$ref});
+ check_data($dbh, \@p1, [qw(fred fred fred fred fred)]);
+
+ $sth = $dbh->prepare(qq/update $table set b = ? where a = ?/);
+ # NOTE, this also checks you can pass a scalar to bind_param_array
+ $sth->bind_param_array(1, 'dave');
+ my @pe1 = @p1;
+ $pe1[-1] = 10; # non-existant row
+ $sth->bind_param_array(2, \@pe1);
+ insert($dbh, $sth,
+ {commit => 0, error => 0, sts => 5, affected => 4,
+ tuple => [1, 1, 1, 1, '0E0'], %$ref});
+ check_data($dbh, \@p1, [qw(dave dave dave dave fred)]);
+
+ $sth = $dbh->prepare(qq/update $table set b = ? where b like ?/);
+ # NOTE, this also checks you can pass a scalar to bind_param_array
+ $sth->bind_param_array(1, 'pete');
+ $sth->bind_param_array(2, ['dave%', 'fred%']);
+ insert($dbh, $sth,
+ {commit => 0, error => 0, sts => 2, affected => 5,
+ tuple => [1, 1], %$ref});
+ check_data($dbh, \@p1, [qw(pete pete pete pete pete)]);
+
+
+}
+
+$dbh->{RaiseError} = 1;
+$dbh->{PrintError} = 0;
+$dbh->{ChopBlanks} = 1;
+$dbh->{HandleError} = \&error_handler;
+$dbh->{AutoCommit} = 1;
+
+eval {drop_table_local($dbh)};
+
+ok(create_table_local($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});
+
+update($dbh, {array_context => 1, raise => 1});