[svn:dbd-oracle] r14697 - in dbd-oracle/trunk: . t
[email protected] Thu, 10 Feb 2011 05:41:56 -0800 (PST)
| Newsgroups | perl.dbd.oracle.changes |
|---|---|
| Message-ID | <[email protected]> |
Author: byterock
Date: Thu Feb 10 05:41:56 2011
New Revision: 14697
Modified:
dbd-oracle/trunk/Changes
dbd-oracle/trunk/Oracle.pm
dbd-oracle/trunk/Oracle.xs
dbd-oracle/trunk/dbdimp.c
dbd-oracle/trunk/dbdimp.h
dbd-oracle/trunk/t/26exe_array.t
Log:
Fix in execute_array to stop possible endless loop when using a fetch sub by by Martin J. Evans
Adapted Martin J. Evans' ODBC 70execute_array.t into t/26exe_array.t by John Scoles
Fix for execute_array to bring it up to spec. by Martin J. Evans and John Scoles
Modified: dbd-oracle/trunk/Changes
==============================================================================
--- dbd-oracle/trunk/Changes (original)
+++ dbd-oracle/trunk/Changes Thu Feb 10 05:41:56 2011
@@ -1,5 +1,8 @@
=head1 Changes in DBD-Oracle 1.28 (svn rev xxxxx)
+ Fix in execute_array to stop possible endless loop when using a fetch sub by by Martin J. Evans
+ Adapted Martin J. Evans' ODBC 70execute_array.t into t/26exe_array.t by John Scoles
+ Fix for execute_array to bring it up to spec. by Martin J. Evans and John Scoles
Marked ProC, Oraperl.pm, ora_explain.pl, ora_context, ora_use_proc_connection and ora_parse_lang as deprecated to be removed in 1.29
Added in 4 new server side debug/trace attributes, ora_driver_name, ora_client_info, ora_session_user and ora_action on the connection handle from John Scoles
Cleaned up the pod a little by John Scoles
Modified: dbd-oracle/trunk/Oracle.pm
==============================================================================
--- dbd-oracle/trunk/Oracle.pm (original)
+++ dbd-oracle/trunk/Oracle.pm Thu Feb 10 05:41:56 2011
@@ -978,8 +978,7 @@
return $dbh->{ora_can_unicode};
}
-
-
+
} # end of package DBD::Oracle::db
@@ -1011,6 +1010,7 @@
sub execute_for_fetch {
my ($sth, $fetch_tuple_sub, $tuple_status) = @_;
my $row_count = 0;
+ my $err_count = 0;
my $tuple_count="0E0";
my $tuple_batch_status;
my $dbh = $sth->{Database};
@@ -1020,30 +1020,47 @@
$tuple_batch_status = [ ];
}
+ my $finished;
while (1) {
my @tuple_batch;
for (my $i = 0; $i < $batch_size; $i++) {
- push @tuple_batch, [ @{$fetch_tuple_sub->() || last} ];
+ $finished = $fetch_tuple_sub->();
+ push @tuple_batch, [@{$finished || last}];
+
}
last unless @tuple_batch;
+
my $res = ora_execute_array($sth,
\@tuple_batch,
scalar(@tuple_batch),
- $tuple_batch_status);
- if(defined($res) && defined($row_count)) {
+ $tuple_batch_status,
+ $err_count );
+
+ if(defined($res)) { #no error
$row_count += $res;
} else {
$row_count = undef;
}
+
$tuple_count+=@$tuple_batch_status;
push @$tuple_status, @$tuple_batch_status
- if defined($tuple_status);
+ if defined($tuple_status);
+
+ last if !$finished;
+
}
+ #error check here
+ return $sth->set_err($DBI::stderr, "executing $tuple_count generated $err_count errors")
+ if $err_count;
+
if (!wantarray) {
- return undef if !defined $row_count;
- return $tuple_count;
+ return $tuple_count;
}
- return (defined $row_count ? $tuple_count : undef, $row_count);
+
+ return ($tuple_count, defined $row_count ? $row_count : undef);
+
+
+
}
sub private_attribute_info {
@@ -1382,7 +1399,9 @@
$dbh = DBI->connect('dbi:Oracle:DB','username','password',{ora_drcp=>1})
- $dbh = DBI->connect('dbi:Oracle:DB','username','password',{ora_drcp=>1, ora_drcp_class=>'my_app', ora_drcp_min=>10})
+ $dbh = DBI->connect('dbi:Oracle:DB','username','password',{ora_drcp=>1,
+ ora_drcp_class=>'my_app',
+ ora_drcp_min =>10})
$dbh = DBI->connect('dbi:Oracle:host=foobar;sid=ORCL;port=1521;SERVER=POOLED', 'scott/tiger', '')
Modified: dbd-oracle/trunk/Oracle.xs
==============================================================================
--- dbd-oracle/trunk/Oracle.xs (original)
+++ dbd-oracle/trunk/Oracle.xs Thu Feb 10 05:41:56 2011
@@ -157,10 +157,10 @@
D_imp_sth(sth);
SV *av_value;
if (!SvROK(av_ref) || SvTYPE(SvRV(av_ref)) != SVt_PVAV)
- croak("bind_param_inout_array needs a reference to a array value");
+ croak("bind_param_inout_array needs a reference to a array value");
av_value = av_ref;
if (SvREADONLY(av_value))
- croak("Modification of a read-only value attempted");
+ croak("Modification of a read-only value attempted");
if (attribs) {
if (SvNIOK(attribs)) {
sql_type = SvIV(attribs);
@@ -199,7 +199,7 @@
XSRETURN_IV(DBIc_NUM_FIELDS(imp_sth));
}
if (debug >= 2)
- PerlIO_printf(DBILOGFP, " -> ora_fetch\n");
+ PerlIO_printf(DBILOGFP, " -> ora_fetch\n");
av = dbd_st_fetch(sth, imp_sth);
if (av) {
int num_fields = AvFILL(av)+1;
@@ -216,16 +216,17 @@
PerlIO_printf(DBILOGFP, " <- () [0 items]\n");
}
if (debug >= 2 && SvTRUE(DBIc_ERR(imp_sth)))
- PerlIO_printf(DBILOGFP, " !! ERROR: %s %s",
- neatsvpv(DBIc_ERR(imp_sth),0), neatsvpv(DBIc_ERRSTR(imp_sth),0));
+ PerlIO_printf(DBILOGFP, " !! ERROR: %s %s",
+ neatsvpv(DBIc_ERR(imp_sth),0), neatsvpv(DBIc_ERRSTR(imp_sth),0));
void
-ora_execute_array(sth, tuples, exe_count, tuples_status, cols=&PL_sv_undef)
+ora_execute_array(sth, tuples, exe_count, tuples_status, err_count, cols=&PL_sv_undef)
SV * sth
SV * tuples
IV exe_count
SV * tuples_status
SV * cols
+ SV * err_count
PREINIT:
D_imp_sth(sth);
int retval;
@@ -235,7 +236,7 @@
if (DBIc_ROW_COUNT(imp_sth) > 0) /* reset for re-execute */
DBIc_ROW_COUNT(imp_sth) = 0;
retval = ora_st_execute_array(sth, imp_sth, tuples, tuples_status,
- cols, (ub4)exe_count);
+ cols, (ub4)exe_count,err_count);
/* XXX Handle return value ... like DBI::execute_array(). */
/* remember that dbd_st_execute must return <= -2 for error */
if (retval == 0) /* ok with no rows affected */
@@ -354,7 +355,7 @@
ST(0) = &PL_sv_undef;
}
else {
- ST(0) = &PL_sv_yes;
+ ST(0) = &PL_sv_yes;
}
void
@@ -500,8 +501,6 @@
ST(0) = sv_2mortal(newSVuv(is_init));
}
-
-
void
ora_lob_length(dbh, locator)
SV *dbh
Modified: dbd-oracle/trunk/dbdimp.c
==============================================================================
--- dbd-oracle/trunk/dbdimp.c (original)
+++ dbd-oracle/trunk/dbdimp.c Thu Feb 10 05:41:56 2011
@@ -424,6 +424,7 @@
imp_dbh->using_drcp = 1;
/* some connection pool atributes */
+
if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_drcp_class", 14)) && SvOK(*svp)) {
STRLEN svp_len;
if (!SvPOK(*svp))
@@ -436,7 +437,7 @@
if (DBD_ATTRIB_TRUE(attr,"ora_drcp_max",12,svp))
DBD_ATTRIB_GET_IV( attr, "ora_drcp_max", 12, svp, imp_dbh->pool_max);
if (DBD_ATTRIB_TRUE(attr,"ora_drcp_incr",13,svp))
- DBD_ATTRIB_GET_IV( attr, "ora_drcp_incr", 13, svp, imp_dbh->pool_incr);
+ DBD_ATTRIB_GET_IV( attr, "ora_drcp_incr", 13, svp, imp_dbh->pool_incr);
if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_driver_name", 15)) && SvOK(*svp)) {
@@ -1001,11 +1002,11 @@
OCIAttrSet_log_stat(imp_dbh->svchp, (ub4) OCI_HTYPE_SVCCTX,
imp_dbh->seshp, (ub4) 0,(ub4) OCI_ATTR_SESSION, imp_dbh->errhp, status);
-
#ifdef ORA_OCI_112
}
#endif
}
+
#if defined(CAN_USE_PRO_C)
} /* use_proc_connection */
#endif
@@ -1036,7 +1037,6 @@
}
#endif
-
return 1;
}
@@ -3599,12 +3599,13 @@
OCINlsCharSetIdToName(imp_sth->envhp,charsetname, sizeof(charsetname),csid );
for(i=0;i<av_len(tuples_utf8_av)+1;i++){
- SV *err_svs[2];
+ SV *err_svs[3];
SV *item;
item=*(av_fetch(tuples_utf8_av,i,0));
err_svs[0] = newSViv((IV)0);
err_svs[1] = newSVpvf("DBD Oracle Warning: You have mixed utf8 and non-utf8 in an array bind in parameter#%d. This may result in corrupt data. The Query charset id=%d, name=%s",parma_index+1,csid,charsetname);
- av_store(tuples_status_av,SvIV(item),newRV_noinc((SV *)(av_make(2, err_svs))));
+ err_svs[2] = newSVpvn("S1000", 0);
+ av_store(tuples_status_av,SvIV(item),newRV_noinc((SV *)(av_make(3, err_svs))));
}
@@ -3654,17 +3655,18 @@
}
int
-ora_st_execute_array(sth, imp_sth, tuples, tuples_status, columns, exe_count)
+ora_st_execute_array(sth, imp_sth, tuples, tuples_status, columns, exe_count, err_count)
SV *sth;
imp_sth_t *imp_sth;
SV *tuples;
SV *tuples_status;
SV *columns;
ub4 exe_count;
+ SV *err_count;
{
dTHX;
dTHR;
- /*ub4 row_count = 0;*/
+ ub4 row_count = 0;
int debug = DBIS->debug;
D_imp_dbh_from_sth;
sword status, exe_status;
@@ -3847,6 +3849,9 @@
OCIStmtExecute_log_stat(imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp,
exe_count, 0, 0, 0, oci_mode, exe_status);
+ OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
+
+
imp_sth->bind_tuples = NULL;
if (exe_status != OCI_SUCCESS) {
@@ -3854,7 +3859,6 @@
if(exe_status != OCI_SUCCESS_WITH_INFO)
return -2;
}
-
if (outparams){
i=outparams;
while(--i >= 0) {
@@ -3879,12 +3883,13 @@
if(num_errs && tuples_status_av) {
OCIError *row_errhp, *tmp_errhp;
ub4 row_off;
- SV *err_svs[2];
+ SV *err_svs[3];
/*AV *err_av;*/
sb4 err_code;
-
+ sv_setiv(err_count,num_errs);
err_svs[0] = newSViv((IV)0);
err_svs[1] = newSVpvn("", 0);
+ err_svs[2] = newSVpvn("S1000",5);
OCIHandleAlloc_ok(imp_sth->envhp, &row_errhp, OCI_HTYPE_ERROR, status);
OCIHandleAlloc_ok(imp_sth->envhp, &tmp_errhp, OCI_HTYPE_ERROR, status);
for(i = 0; (unsigned int) i < num_errs; i++) {
@@ -3900,7 +3905,7 @@
err_code = oci_error_get(row_errhp, exe_status, NULL, err_svs[1], debug);
sv_setiv(err_svs[0], (IV)err_code);
av_store(tuples_status_av, row_off,
- newRV_noinc((SV *)(av_make(2, err_svs))));
+ newRV_noinc((SV *)(av_make(3, err_svs))));
}
OCIHandleFree_log_stat(tmp_errhp, OCI_HTYPE_ERROR, status);
OCIHandleFree_log_stat(row_errhp, OCI_HTYPE_ERROR, status);
@@ -3920,8 +3925,7 @@
if(num_errs) {
return -2;
} else {
- ub4 row_count = 0;
- OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
+
return row_count;
}
}
Modified: dbd-oracle/trunk/dbdimp.h
==============================================================================
--- dbd-oracle/trunk/dbdimp.h (original)
+++ dbd-oracle/trunk/dbdimp.h Thu Feb 10 05:41:56 2011
@@ -315,7 +315,6 @@
void dbd_fbh_dump(imp_fbh_t *fbh, int i, int aidx);
void ora_free_fbh_contents _((imp_fbh_t *fbh));
void ora_free_templob _((SV *sth, imp_sth_t *imp_sth, OCILobLocator *lobloc));
-
int ora_dbtype_is_long _((int dbtype));
fb_ary_t *fb_ary_alloc _((ub4 bufl, int size));
fb_ary_t *fb_ary_cb_alloc _((ub4 piece_size,ub4 max_len, int size));
@@ -353,7 +352,7 @@
int dbd_rebind_ph_nty _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
int ora_st_execute_array _((SV *sth, imp_sth_t *imp_sth, SV *tuples,
- SV *tuples_status, SV *columns, ub4 exe_count));
+ SV *tuples_status, SV *columns, ub4 exe_count, SV *err_count));
SV * ora_create_xml _((SV *dbh, char *source));
Modified: dbd-oracle/trunk/t/26exe_array.t
==============================================================================
--- dbd-oracle/trunk/t/26exe_array.t (original)
+++ dbd-oracle/trunk/t/26exe_array.t Thu Feb 10 05:41:56 2011
@@ -1,181 +1,467 @@
-#!perl -w
-
-use DBI;
-use DBD::Oracle qw(ORA_RSET SQLCS_NCHAR);
-use strict;
-
-use Test::More;
-unshift @INC ,'t';
-require 'nchar_test_lib.pl';
-
-$| = 1;
-
-## ----------------------------------------------------------------------------
-## 26exe_array.t
-## By John Scoles, The Pythian Group
-## ----------------------------------------------------------------------------
-## Just a few checks to see if execute array works in Oracle::DBD
-## Nothing fancy. I also checks for warnings when utf8 is inserted into
-## an ASCII only DB
-## ----------------------------------------------------------------------------
-
-# 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;
-
-eval {
- $dbh = DBI->connect($dsn, $dbuser, '', { RaiseError=>1,
- AutoCommit=>1,
- PrintError => 0,
- ora_envhp => 0,
- })
-};
-if ($dbh) {
- plan tests => 16;
-} else {
- plan skip_all => "Unable to connect to Oracle";
-}
-
-# check that our db handle is good
-isa_ok($dbh, "DBI::db");
-
-
-my $table = table();
-eval{
- drop_table($dbh);
-};
-$dbh->do(qq{
- CREATE TABLE $table (
- row_1 INTEGER NOT NULL,
- row_2 INTEGER NOT NULL,
- row_3 INTEGER NOT NULL,
- row_4 CHAR(5)
- )
- });
-
-my $rv;
-my @var1 = (1,1,1,1,1,1,1,1,1,1);
-my @var2 = (2,2,2,2,2,2,2,2,2,2);
-my @var3 = (3,3,3,3,3,3,3,3,3,3);
-my @utf8_string = ("A","A","A","A","\x{6e9}","A","A","A","A","A");
-my $tuple_status = [];
-my $dumped ;
-
-
-my $rows = [];
-
-# simple bind and execute_arry
-
-my $sth = $dbh->prepare("INSERT INTO $table ( row_1, row_2, row_3) VALUES (?,?,?)");
-
-
-ok ($sth->execute_array(
- {ArrayTupleStatus => $tuple_status},
- \@var1,
- \@var2,
- \@var2,
- ), '... execute_array should return true');
-
-
-cmp_ok(scalar @{$tuple_status}, '==', 10, '... we should have 10 tuple_status');
-
-
-# simple check to ensurte the error is returned in the status tuple
-
-@var2 = (2,2,2,2,'s',2,2,2,2,2);
-
-{
- # trap the intentional failure of one of these rows
- my $warn_count = 0;
- local $SIG{__WARN__} = sub {
- my $msg = shift;
- if ($warn_count++ == 0 && $msg =~ /ORA-24381/) {
- # this is the first warning, and it's the expected one
- return;
- }
-
- # unexpected warning, pass it through
- warn $msg;
- };
-
- ok (!$sth->execute_array(
- {ArrayTupleStatus => $tuple_status},
- \@var1,
- \@var2,
- \@var2,
- ), '... execute_array should return false');
-
- cmp_ok(scalar @{$tuple_status}, '==', 10, '... we should have 10 tuple_status');
-
- cmp_ok( $tuple_status->[4]->[1],'ne','-1','... we should get text');
-
- cmp_ok( $tuple_status->[3],'==',-1,'... we should get -1');
- is($warn_count, 1, "... we should get a warning");
-
-}
-
-# siple test with execute_for_fetch
-# need some datat
- my $sth2 = $dbh->prepare("select row_1, row_2, row_3 from $table");
-
- $sth2->execute();
-
- my $problems = $sth2->fetchall_arrayref();
-
-
-$sth = $dbh->prepare("INSERT INTO $table ( row_1, row_2, row_3) VALUES (?,?,?)");
-
- ok($sth->execute_for_fetch( sub { shift @$problems },$tuple_status), '... execute_for_fetch should return true');
-
- cmp_ok(scalar @{$tuple_status}, '==',19 , '... we should have 19 tuple_status');
-
-
-#simple test for array bind param
-
- @var2 = (2,2,2,2,2,2,2,2,2,2);
-
- $sth = $dbh->prepare("INSERT INTO $table ( row_1, row_2, row_3) VALUES (?,?,?)");
-
- $sth->bind_param_array(1,\@var1);
- $sth->bind_param_array(2,\@var2);
- $sth->bind_param_array(3,\@var3);
-
-ok( $sth->execute_array( { ArrayTupleStatus => $tuple_status } ), '... execute_array should return flase');
-
- cmp_ok(scalar @{$tuple_status}, '==',10, '... we should have 10 tuple_status');
-
-#last check to see it the number add up
-
-$sth2 = $dbh->prepare("select * from $table");
-
-$sth2->execute();
-
- $problems = $sth2->fetchall_arrayref();
-
-
- cmp_ok(scalar @$problems, '==',48, '... we should have 48 rows');
-
-
-$sth = $dbh->prepare("INSERT INTO $table ( row_1, row_2, row_3,row_4) VALUES (1,2,3,?)");
-
-ok ($sth->execute_array(
- {ArrayTupleStatus => $tuple_status},
- \@utf8_string
- ), '... execute_array should return true');
-
-
-cmp_ok(@$tuple_status[4],'ne','-1','... #5 should be a warning');
-cmp_ok(scalar @{$tuple_status}, '==', 10, '... we should have 10 tuple_status');
-
-
-
- drop_table($dbh);
-
-#dbh->{dbd_verbose}=0;
-$dbh->disconnect;
-
-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 $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});