[svn:dbd-oracle] r15454 - in dbd-oracle/trunk: . lib/DBD t
[email protected] Fri, 26 Oct 2012 05:16:07 -0700 (PDT)
| Newsgroups | perl.dbd.oracle.changes |
|---|---|
| Message-ID | <[email protected]> |
Author: mjevans
Date: Fri Oct 26 05:16:05 2012
New Revision: 15454
Added:
dbd-oracle/trunk/t/ExecuteArray.pm (contents, props changed)
Modified:
dbd-oracle/trunk/Changes
dbd-oracle/trunk/MANIFEST
dbd-oracle/trunk/dbdimp.c
dbd-oracle/trunk/lib/DBD/Oracle.pm
dbd-oracle/trunk/oci8.c
dbd-oracle/trunk/t/26exe_array.t
Log:
Improve tests in ExecuteArray (espcially to ensure things work when ArrayTupleStatus
is not specified)
Rewrote 26exe_array.t to be more like the one in DBD::ODBC (from where it came
originally) and copied new ExecuteArray module.
Fixes from Stefen for execute_array when no ArrayTupleStatus
Modified: dbd-oracle/trunk/Changes
==============================================================================
--- dbd-oracle/trunk/Changes (original)
+++ dbd-oracle/trunk/Changes Fri Oct 26 05:16:05 2012
@@ -8,6 +8,20 @@
can contain the wrong error count. Thanks to Steffen Goeldner for
RT and patch.
+ - Fix RT80375 - no exception when execute_for_fetch fails and
+ ArrayTupleStatus is not specified. Also the tuple count calculation
+ resulted in an undefined warning. Thanks to Steffen Goeldner for
+ RT and patches.
+
+ [MISCELLANEOUS]
+
+ - The original 26exe_array test was replaced some time ago with a
+ copy of the one from DBD::ODBC. Since then I've fixed issues in
+ the DBD::ODBC one and added more tests (like tests for some RTs
+ above). To make keeping them in synch easier I've modularised the
+ tests. Hence new ExecuteArray.pm. (Martin J. Evans)
+
+
1.52 2012-10-19
- promote 1.51_00 to official release
Modified: dbd-oracle/trunk/MANIFEST
==============================================================================
--- dbd-oracle/trunk/MANIFEST (original)
+++ dbd-oracle/trunk/MANIFEST Fri Oct 26 05:16:05 2012
@@ -67,6 +67,7 @@
t/24implicit_utf8.t
t/25plsql.t
t/26exe_array.t
+t/ExecuteArray.pm
t/28array_bind.t
t/30long.t
t/31lob.t
Modified: dbd-oracle/trunk/dbdimp.c
==============================================================================
--- dbd-oracle/trunk/dbdimp.c (original)
+++ dbd-oracle/trunk/dbdimp.c Fri Oct 26 05:16:05 2012
@@ -2070,19 +2070,19 @@
/*int flag_data_is_utf8=0;*/
if( ( ! SvROK(phs->sv) ) || (SvTYPE(SvRV(phs->sv))!=SVt_PVAV) ) { /* Allow only array binds */
- croak("dbd_rebind_ph_number_table(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
- neatsvpv(phs->sv,0), phs->name);
+ croak("dbd_rebind_ph_number_table(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
+ neatsvpv(phs->sv,0), phs->name);
}
/* Default bind type for number table is double. */
if( ! phs->ora_internal_type ){
- phs->ora_internal_type=SQLT_FLT;
+ phs->ora_internal_type=SQLT_FLT;
}else{
- if( (phs->ora_internal_type != SQLT_FLT) &&
- (phs->ora_internal_type != SQLT_INT) ){
- croak("dbd_rebind_ph_number_table(): Specified internal bind type %d unsupported. "
- "SYS.DBMS_SQL.NUMBER_TABLE can be bound only to SQLT_FLT or SQLT_INT datatypes.",
- phs->ora_internal_type);
- }
+ if( (phs->ora_internal_type != SQLT_FLT) &&
+ (phs->ora_internal_type != SQLT_INT) ){
+ croak("dbd_rebind_ph_number_table(): Specified internal bind type %d unsupported. "
+ "SYS.DBMS_SQL.NUMBER_TABLE can be bound only to SQLT_FLT or SQLT_INT datatypes.",
+ phs->ora_internal_type);
+ }
}
arr=(AV*)(SvRV(phs->sv));
@@ -2112,11 +2112,11 @@
* maxlen(double) = sizeof(double);
*/
switch( phs->ora_internal_type ){
- case SQLT_INT:
+ case SQLT_INT:
phs->maxlen=sizeof(int);
break;
- case SQLT_FLT:
- default:
+ case SQLT_FLT:
+ default:
phs->maxlen=sizeof(double);
}
if (trace_level >= 2 || dbd_verbose >= 3 ){
@@ -2131,7 +2131,7 @@
phs->array_numstruct=1;
}
if( phs->ora_maxarray_numentries== 0 ){
- /* Zero means "use current array length". */
+ /* Zero means "use current array length". */
phs->ora_maxarray_numentries=phs->array_numstruct;
if (trace_level >= 2 || dbd_verbose >= 3 ){
@@ -2153,7 +2153,7 @@
need_allocate_rows=phs->ora_maxarray_numentries;
if( need_allocate_rows< phs->array_numstruct ){
- need_allocate_rows=phs->array_numstruct;
+ need_allocate_rows=phs->array_numstruct;
}
buflen=need_allocate_rows* phs->maxlen; /* We need buffer for at least ora_maxarray_numentries entries */
@@ -2179,160 +2179,160 @@
/* Fill array buffer with data */
{
- int i; /* Not to require C99 mode */
- for(i=0;i<av_len(arr)+1;i++){
- SV *item;
- item=*(av_fetch(arr,i,0));
- if( item ){
- switch( phs->ora_internal_type ){
- case SQLT_INT:
- {
- int ival =0;
- int val_found=0;
- /* Double values are converted as int(val) */
- if( SvOK( item ) && ! SvIOK( item ) ){
- double val=SvNVx( item );
- if( SvNOK( item ) ){
- ival=(int) val;
- val_found=1;
- }
- }
- /* Convert item, if possible. */
- if( (!val_found) && SvOK( item ) && ! SvIOK( item ) ){
- SvIVx( item );
- }
- if( SvIOK( item ) || val_found ){
- if( ! val_found ){
- ival=SvIV( item );
- }
- /* as phs->array_buf=malloc(), proper alignment is guaranteed */
- *(int*)(phs->array_buf+phs->maxlen*i)=ival;
- phs->array_indicators[i]=0;
- }else{
- if( SvOK( item ) ){
- /* Defined NaN assumed =0 */
- *(int*)(phs->array_buf+phs->maxlen*i)=0;
- phs->array_indicators[i]=0;
- }else{
- /* NULL */
- phs->array_indicators[i]=1;
- }
- }
- phs->array_lengths[i]=sizeof(int);
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(
- DBIc_LOGPIO(imp_sth), "dbd_rebind_ph_number_table(): "
- "(integer) array[%d]=%d%s\n",
- i, *(int*)(phs->array_buf+phs->maxlen*i),
- phs->array_indicators[i] ? " (NULL)" : "" );
- }
- }
- break;
- case SQLT_FLT:
- default:
- {
- phs->ora_internal_type=SQLT_FLT; /* Just in case */
- /* Convert item, if possible. */
- if( SvOK( item ) && ! SvNOK( item ) ){
- SvNVx( item );
- }
- if( SvNOK( item ) ){
- double val=SvNVx( item );
- /* as phs->array_buf=malloc(), proper alignment is guaranteed */
- *(double*)(phs->array_buf+phs->maxlen*i)=val;
- phs->array_indicators[i]=0;
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(
- DBIc_LOGPIO(imp_sth),
- "dbd_rebind_ph_number_table(): "
- "let (double) array[%d]=%f - NOT NULL\n",
- i, val);
- }
- }else{
- if( SvOK( item ) ){
- /* Defined NaN assumed =0 */
- *(double*)(phs->array_buf+phs->maxlen*i)=0;
- phs->array_indicators[i]=0;
- if (trace_level >= 2 || dbd_verbose >= 3 ){
- STRLEN l;
- char *p=SvPV(item,l);
-
- PerlIO_printf(
- DBIc_LOGPIO(imp_sth),
- "dbd_rebind_ph_number_table(): "
- "let (double) array[%d]=\"%s\" =NaN. Set =0 - NOT NULL\n",
- i, p ? p : "<NULL>" );
- }
- }else{
- /* NULL */
- phs->array_indicators[i]=1;
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(
- DBIc_LOGPIO(imp_sth),
- "dbd_rebind_ph_number_table(): "
- "let (double) array[%d] NULL\n",
- i);
- }
- }
- }
- phs->array_lengths[i]=sizeof(double);
- if (trace_level >= 3 || dbd_verbose >= 3 ){
+ int i; /* Not to require C99 mode */
+ for(i=0;i<av_len(arr)+1;i++){
+ SV *item;
+ item=*(av_fetch(arr,i,0));
+ if( item ){
+ switch( phs->ora_internal_type ){
+ case SQLT_INT:
+ {
+ int ival =0;
+ int val_found=0;
+ /* Double values are converted as int(val) */
+ if( SvOK( item ) && ! SvIOK( item ) ){
+ double val=SvNVx( item );
+ if( SvNOK( item ) ){
+ ival=(int) val;
+ val_found=1;
+ }
+ }
+ /* Convert item, if possible. */
+ if( (!val_found) && SvOK( item ) && ! SvIOK( item ) ){
+ SvIVx( item );
+ }
+ if( SvIOK( item ) || val_found ){
+ if( ! val_found ){
+ ival=SvIV( item );
+ }
+ /* as phs->array_buf=malloc(), proper alignment is guaranteed */
+ *(int*)(phs->array_buf+phs->maxlen*i)=ival;
+ phs->array_indicators[i]=0;
+ }else{
+ if( SvOK( item ) ){
+ /* Defined NaN assumed =0 */
+ *(int*)(phs->array_buf+phs->maxlen*i)=0;
+ phs->array_indicators[i]=0;
+ }else{
+ /* NULL */
+ phs->array_indicators[i]=1;
+ }
+ }
+ phs->array_lengths[i]=sizeof(int);
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(
+ DBIc_LOGPIO(imp_sth), "dbd_rebind_ph_number_table(): "
+ "(integer) array[%d]=%d%s\n",
+ i, *(int*)(phs->array_buf+phs->maxlen*i),
+ phs->array_indicators[i] ? " (NULL)" : "" );
+ }
+ }
+ break;
+ case SQLT_FLT:
+ default:
+ {
+ phs->ora_internal_type=SQLT_FLT; /* Just in case */
+ /* Convert item, if possible. */
+ if( SvOK( item ) && ! SvNOK( item ) ){
+ SvNVx( item );
+ }
+ if( SvNOK( item ) ){
+ double val=SvNVx( item );
+ /* as phs->array_buf=malloc(), proper alignment is guaranteed */
+ *(double*)(phs->array_buf+phs->maxlen*i)=val;
+ phs->array_indicators[i]=0;
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(
+ DBIc_LOGPIO(imp_sth),
+ "dbd_rebind_ph_number_table(): "
+ "let (double) array[%d]=%f - NOT NULL\n",
+ i, val);
+ }
+ }else{
+ if( SvOK( item ) ){
+ /* Defined NaN assumed =0 */
+ *(double*)(phs->array_buf+phs->maxlen*i)=0;
+ phs->array_indicators[i]=0;
+ if (trace_level >= 2 || dbd_verbose >= 3 ){
+ STRLEN l;
+ char *p=SvPV(item,l);
+
+ PerlIO_printf(
+ DBIc_LOGPIO(imp_sth),
+ "dbd_rebind_ph_number_table(): "
+ "let (double) array[%d]=\"%s\" =NaN. Set =0 - NOT NULL\n",
+ i, p ? p : "<NULL>" );
+ }
+ }else{
+ /* NULL */
+ phs->array_indicators[i]=1;
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(
+ DBIc_LOGPIO(imp_sth),
+ "dbd_rebind_ph_number_table(): "
+ "let (double) array[%d] NULL\n",
+ i);
+ }
+ }
+ }
+ phs->array_lengths[i]=sizeof(double);
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(
+ DBIc_LOGPIO(imp_sth),
+ "dbd_rebind_ph_number_table(): "
+ "(double) array[%d]=%f%s\n",
+ i, *(double*)(phs->array_buf+phs->maxlen*i),
+ phs->array_indicators[i] ? " (NULL)" : "" );
+ }
+ }
+ break;
+ }
+ }else{
+ /* item not defined, mark NULL */
+ phs->array_indicators[i]=1;
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
"dbd_rebind_ph_number_table(): "
- "(double) array[%d]=%f%s\n",
- i, *(double*)(phs->array_buf+phs->maxlen*i),
- phs->array_indicators[i] ? " (NULL)" : "" );
- }
- }
- break;
- }
- }else{
- /* item not defined, mark NULL */
- phs->array_indicators[i]=1;
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(
- DBIc_LOGPIO(imp_sth),
- "dbd_rebind_ph_number_table(): "
- "Copying length=? array[%d]=NULL av_fetch failed.\n", i);
- }
- }
- }
+ "Copying length=? array[%d]=NULL av_fetch failed.\n", i);
+ }
+ }
+ }
}
/* Do actual bind */
OCIBindByName_log_stat(imp_sth, imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
- (text*)phs->name, (sb4)strlen(phs->name),
- phs->array_buf,
- phs->maxlen,
- (ub2)phs->ora_internal_type, phs->array_indicators,
- phs->array_lengths,
- (ub2)0,
- (ub4)phs->ora_maxarray_numentries, /* max elements that can fit in allocated array */
- (ub4 *)&(phs->array_numstruct), /* (ptr to) current number of elements in array */
- OCI_DEFAULT, /* OCI_DATA_AT_EXEC (bind with callbacks) or OCI_DEFAULT */
- status
- );
+ (text*)phs->name, (sb4)strlen(phs->name),
+ phs->array_buf,
+ phs->maxlen,
+ (ub2)phs->ora_internal_type, phs->array_indicators,
+ phs->array_lengths,
+ (ub2)0,
+ (ub4)phs->ora_maxarray_numentries, /* max elements that can fit in allocated array */
+ (ub4 *)&(phs->array_numstruct), /* (ptr to) current number of elements in array */
+ OCI_DEFAULT, /* OCI_DATA_AT_EXEC (bind with callbacks) or OCI_DEFAULT */
+ status
+ );
if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindByName");
- return 0;
+ oci_error(sth, imp_sth->errhp, status, "OCIBindByName");
+ return 0;
}
OCIBindArrayOfStruct_log_stat(imp_sth, phs->bndhp, imp_sth->errhp,
- (unsigned)phs->maxlen, /* Skip parameter for the next data value */
- (unsigned)sizeof(OCIInd), /* Skip parameter for the next indicator value */
- (unsigned)sizeof(unsigned short), /* Skip parameter for the next actual length value */
- 0, /* Skip parameter for the next column-level error code */
- status);
+ (unsigned)phs->maxlen, /* Skip parameter for the next data value */
+ (unsigned)sizeof(OCIInd), /* Skip parameter for the next indicator value */
+ (unsigned)sizeof(unsigned short), /* Skip parameter for the next actual length value */
+ 0, /* Skip parameter for the next column-level error code */
+ status);
if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindArrayOfStruct");
- return 0;
+ oci_error(sth, imp_sth->errhp, status, "OCIBindArrayOfStruct");
+ return 0;
}
if (phs->maxdata_size) {
OCIAttrSet_log_stat(imp_sth, phs->bndhp, (ub4)OCI_HTYPE_BIND,
- phs->array_buf, (ub4)phs->array_buflen, (ub4)OCI_ATTR_MAXDATA_SIZE, imp_sth->errhp, status);
- if ( status != OCI_SUCCESS ) {
- oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_MAXDATA_SIZE)"));
- return 0;
- }
+ phs->array_buf, (ub4)phs->array_buflen, (ub4)OCI_ATTR_MAXDATA_SIZE, imp_sth->errhp, status);
+ if ( status != OCI_SUCCESS ) {
+ oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_MAXDATA_SIZE)"));
+ return 0;
+ }
}
return 2;
@@ -3882,6 +3882,9 @@
DBIc_LOGPIO(imp_sth),
" ora_st_execute_array %d errors in batch.\n",
num_errs);
+ if (num_errs) {
+ sv_setiv(err_count,num_errs);
+ }
if(num_errs && tuples_status_av) {
OCIError *row_errhp, *tmp_errhp;
@@ -3889,7 +3892,7 @@
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);
Modified: dbd-oracle/trunk/lib/DBD/Oracle.pm
==============================================================================
--- dbd-oracle/trunk/lib/DBD/Oracle.pm (original)
+++ dbd-oracle/trunk/lib/DBD/Oracle.pm Fri Oct 26 05:16:05 2012
@@ -1110,7 +1110,8 @@
}
$err_total += $err_count;
- $tuple_count+=@$tuple_batch_status;
+
+ $tuple_count+=@tuple_batch;
push @$tuple_status, @$tuple_batch_status
if defined($tuple_status);
Modified: dbd-oracle/trunk/oci8.c
==============================================================================
--- dbd-oracle/trunk/oci8.c (original)
+++ dbd-oracle/trunk/oci8.c Fri Oct 26 05:16:05 2012
@@ -3423,7 +3423,7 @@
/* long_readlen: length for long/longraw (if >0), else 80 (ora app dflt) */
/* Ought to be for COMPAT mode only but was relaxed before LongReadLen existed */
long_readlen = (SvOK(imp_drh -> ora_long) && SvUV(imp_drh->ora_long)>0)
- ? SvUV(imp_drh->ora_long) : DBIc_LongReadLen(imp_sth);
+ ? SvUV(imp_drh->ora_long) : DBIc_LongReadLen(imp_sth);
/* set long_readlen for SELECT or PL/SQL with output placeholders */
imp_sth->long_readlen = long_readlen;
@@ -3435,7 +3435,7 @@
DBIc_LOGPIO(imp_sth),
" dbd_describe skipped for %s\n",
oci_stmt_type_name(imp_sth->stmt_type));
- /* imp_sth memory was cleared when created so no setup required here */
+ /* imp_sth memory was cleared when created so no setup required here */
return 1;
}
@@ -3451,12 +3451,12 @@
if ( !DBIc_ACTIVE(imp_sth) ) {
OCIStmtExecute_log_stat(imp_sth, imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp,
- 0, 0, 0, 0, OCI_DESCRIBE_ONLY, status);
+ 0, 0, 0, 0, OCI_DESCRIBE_ONLY, status);
if (status != OCI_SUCCESS) {
oci_error(h, imp_sth->errhp, status,
- ora_sql_error(imp_sth, "OCIStmtExecute/Describe"));
+ ora_sql_error(imp_sth, "OCIStmtExecute/Describe"));
if (status != OCI_SUCCESS_WITH_INFO)
- return 0;
+ return 0;
}
}
OCIAttrGet_stmhp_stat(imp_sth, &num_fields, 0, OCI_ATTR_PARAM_COUNT, status);
@@ -3478,7 +3478,7 @@
Newz(42, imp_sth->fbh, num_fields, imp_fbh_t);
/* Get number of fields and space needed for field names */
-/* loop though the fields and get all the fileds and thier types to get back*/
+ /* loop though the fields and get all the fileds and thier types to get back*/
for(i = 1; i <= num_fields; ++i) { /*start define of filed struct[i] fbh */
char *p;
@@ -3490,7 +3490,7 @@
fbh->define_mode = OCI_DEFAULT;
OCIParamGet_log_stat(imp_sth, imp_sth->stmhp, OCI_HTYPE_STMT, imp_sth->errhp,
- (dvoid**)&fbh->parmdp, (ub4)i, status);
+ (dvoid**)&fbh->parmdp, (ub4)i, status);
if (status != OCI_SUCCESS) {
oci_error(h, imp_sth->errhp, status, "OCIParamGet");
@@ -3513,7 +3513,7 @@
OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->csid, 0, OCI_ATTR_CHARSET_ID, status);
OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->csform, 0, OCI_ATTR_CHARSET_FORM, status);
#endif
- /* OCI_ATTR_PRECISION returns 0 for most types including some numbers */
+ /* OCI_ATTR_PRECISION returns 0 for most types including some numbers */
OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->prec, 0, OCI_ATTR_PRECISION, status);
OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->scale, 0, OCI_ATTR_SCALE, status);
OCIAttrGet_parmdp(imp_sth, fbh->parmdp, &fbh->nullok, 0, OCI_ATTR_IS_NULL, status);
@@ -3528,6 +3528,8 @@
fbh->name = SvPVX(fbh->name_sv);
fbh->ftype = 5; /* default: return as null terminated string */
+ /* TO_DO there is something wrong with the tracing below as sql_typecode_name
+ returns NVARCHAR2 for type 2 and ORA_NUMBER is 2 */
if (DBIc_DBISTATE(imp_sth)->debug >= 4 || dbd_verbose >= 4 )
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
@@ -3535,283 +3537,283 @@
i,fbh->dbtype,sql_typecode_name(fbh->dbtype));
switch (fbh->dbtype) {
- /* the simple types */
- case ORA_VARCHAR2: /* VARCHAR2 */
-
- if (fbh->dbsize == 0){
- fbh->dbsize=4000;
- }
- avg_width = fbh->dbsize / 2;
- /* FALLTHRU */
- case ORA_CHAR: /* CHAR */
- if ( CSFORM_IMPLIES_UTF8(fbh->csform) && !CS_IS_UTF8(fbh->csid) )
- fbh->disize = fbh->dbsize * 4;
- else
- fbh->disize = fbh->dbsize;
-
- fbh->prec = fbh->disize;
- break;
- case ORA_RAW: /* RAW */
- fbh->disize = fbh->dbsize * 2;
- fbh->prec = fbh->disize;
- break;
- case ORA_NUMBER: /* NUMBER */
- case 21: /* BINARY FLOAT os-endian */
- case 22: /* BINARY DOUBLE os-endian */
- case 100: /* BINARY FLOAT oracle-endian */
- case 101: /* BINARY DOUBLE oracle-endian */
- fbh->disize = 130+38+3; /* worst case */
- avg_width = 4; /* NUMBER approx +/- 1_000_000 */
- break;
-
- case ORA_DATE: /* DATE */
- /* actually dependent on NLS default date format*/
- fbh->disize = 75; /* a generous default */
- fbh->prec = fbh->disize;
- avg_width = 8; /* size in SQL*Net packet */
- break;
-
- case ORA_LONG: /* LONG */
- imp_sth->row_cache_off = 1;
- has_longs++;
- if (imp_sth->clbk_lob){ /*get by peice with callback a slow*/
-
- fbh->clbk_lob = 1;
- fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
- fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
- fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
- fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
-
- if (!imp_sth->piece_size){ /*if not set use max value*/
- imp_sth->piece_size=imp_sth->long_readlen;
- }
-
- fbh->ftype = SQLT_CHR;
- fbh->fetch_func = fetch_clbk_lob;
-
- }
- else if (imp_sth->piece_lob){ /*get by peice with polling slowest*/
-
- fbh->piece_lob = 1;
- fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
- fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
- fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
- fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
-
- if (!imp_sth->piece_size){ /*if not set use max value*/
- imp_sth->piece_size=imp_sth->long_readlen;
- }
- fbh->ftype = SQLT_CHR;
- fbh->fetch_func = fetch_get_piece;
- }
- else {
+ /* the simple types */
+ case ORA_VARCHAR2: /* VARCHAR2 */
- if ( CSFORM_IMPLIES_UTF8(fbh->csform) && !CS_IS_UTF8(fbh->csid) )
- fbh->disize = long_readlen * 4;
- else
- fbh->disize = long_readlen;
-
- /* not governed by else: */
- fbh->dbsize = (fbh->disize>65535) ? 65535 : fbh->disize;
- fbh->ftype = 94; /* VAR form */
- fbh->fetch_func = fetch_func_varfield;
-
- }
- break;
- case ORA_LONGRAW: /* LONG RAW */
- has_longs++;
- if (imp_sth->clbk_lob){ /*get by peice with callback a slow*/
-
- fbh->clbk_lob = 1;
- fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
- fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
- fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
- fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
+ if (fbh->dbsize == 0){
+ fbh->dbsize=4000;
+ }
+ avg_width = fbh->dbsize / 2;
+ /* FALLTHRU */
+ case ORA_CHAR: /* CHAR */
+ if ( CSFORM_IMPLIES_UTF8(fbh->csform) && !CS_IS_UTF8(fbh->csid) )
+ fbh->disize = fbh->dbsize * 4;
+ else
+ fbh->disize = fbh->dbsize;
+
+ fbh->prec = fbh->disize;
+ break;
+ case ORA_RAW: /* RAW */
+ fbh->disize = fbh->dbsize * 2;
+ fbh->prec = fbh->disize;
+ break;
+ case ORA_NUMBER: /* NUMBER */
+ case 21: /* BINARY FLOAT os-endian */
+ case 22: /* BINARY DOUBLE os-endian */
+ case 100: /* BINARY FLOAT oracle-endian */
+ case 101: /* BINARY DOUBLE oracle-endian */
+ fbh->disize = 130+38+3; /* worst case */
+ avg_width = 4; /* NUMBER approx +/- 1_000_000 */
+ break;
+
+ case ORA_DATE: /* DATE */
+ /* actually dependent on NLS default date format*/
+ fbh->disize = 75; /* a generous default */
+ fbh->prec = fbh->disize;
+ avg_width = 8; /* size in SQL*Net packet */
+ break;
+
+ case ORA_LONG: /* LONG */
+ imp_sth->row_cache_off = 1;
+ has_longs++;
+ if (imp_sth->clbk_lob){ /*get by peice with callback a slow*/
+
+ fbh->clbk_lob = 1;
+ fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
+ fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
+ fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
+ fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
+
+ if (!imp_sth->piece_size){ /*if not set use max value*/
+ imp_sth->piece_size=imp_sth->long_readlen;
+ }
+
+ fbh->ftype = SQLT_CHR;
+ fbh->fetch_func = fetch_clbk_lob;
+
+ }
+ else if (imp_sth->piece_lob){ /*get by peice with polling slowest*/
+
+ fbh->piece_lob = 1;
+ fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
+ fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
+ fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
+ fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
+
+ if (!imp_sth->piece_size){ /*if not set use max value*/
+ imp_sth->piece_size=imp_sth->long_readlen;
+ }
+ fbh->ftype = SQLT_CHR;
+ fbh->fetch_func = fetch_get_piece;
+ }
+ else {
+
+ if ( CSFORM_IMPLIES_UTF8(fbh->csform) && !CS_IS_UTF8(fbh->csid) )
+ fbh->disize = long_readlen * 4;
+ else
+ fbh->disize = long_readlen;
+
+ /* not governed by else: */
+ fbh->dbsize = (fbh->disize>65535) ? 65535 : fbh->disize;
+ fbh->ftype = 94; /* VAR form */
+ fbh->fetch_func = fetch_func_varfield;
+
+ }
+ break;
+ case ORA_LONGRAW: /* LONG RAW */
+ has_longs++;
+ if (imp_sth->clbk_lob){ /*get by peice with callback a slow*/
+
+ fbh->clbk_lob = 1;
+ fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
+ fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
+ fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
+ fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
+
+ if (!imp_sth->piece_size){ /*if not set use max value*/
+ imp_sth->piece_size=imp_sth->long_readlen;
+ }
+
+ fbh->ftype = SQLT_BIN;
+ fbh->fetch_func = fetch_clbk_lob;
+
+ }
+ else if (imp_sth->piece_lob){ /*get by peice with polling slowest*/
+
+ fbh->piece_lob = 1;
+ fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
+ fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
+ fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
+ fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
+
+ if (!imp_sth->piece_size){ /*if not set use max value*/
+ imp_sth->piece_size=imp_sth->long_readlen;
+ }
+ fbh->ftype = SQLT_BIN;
+ fbh->fetch_func = fetch_get_piece;
+ }
+ else {
+ fbh->disize = long_readlen * 2;
+ fbh->dbsize = (fbh->disize>65535) ? 65535 : fbh->disize;
+ fbh->ftype = 95; /* VAR form */
+ fbh->fetch_func = fetch_func_varfield;
+ }
+ break;
+
+ case ORA_ROWID: /* ROWID */
+ case 104: /* ROWID Desc */
+ fbh->disize = 20;
+ fbh->prec = fbh->disize;
+ break;
+ case 108: /* some sort of embedded object */
+ imp_sth->row_cache_off = 1;/* cant fetch more thatn one at a time */
+ fbh->ftype = fbh->dbtype; /*varray or alike */
+ fbh->fetch_func = fetch_func_oci_object; /* need a new fetch function for it */
+ fbh->fetch_cleanup = fetch_cleanup_oci_object; /* clean up any AV from the fetch*/
+ fbh->desc_t = SQLT_NTY;
+ if (!imp_sth->dschp){
+ OCIHandleAlloc_ok(imp_sth, imp_sth->envhp, &imp_sth->dschp, OCI_HTYPE_DESCRIBE, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(h,imp_sth->errhp, status, "OCIHandleAlloc");
+ ++num_errors;
+ }
+ }
+ break;
+ case ORA_CLOB: /* CLOB & NCLOB */
+ case ORA_BLOB: /* BLOB */
+ case ORA_BFILE: /* BFILE */
+ has_longs++;
+ fbh->ftype = fbh->dbtype;
+ imp_sth->ret_lobs = 1;
+ imp_sth->row_cache_off = 1; /* Cannot use mulit fetch for a lob*/
+ /* Unless they are just getting the locator */
+
+ if (imp_sth->pers_lob){ /*get as one peice fasted but limited to 64k big you can get.*/
+
+ fbh->pers_lob = 1;
+
+ if (long_readlen){
+ fbh->disize =long_readlen;/*user set max value for the fetch*/
+ }
+ else {
+ fbh->disize = fbh->dbsize*10; /*default size*/
+ }
+
+
+ if (fbh->dbtype == ORA_CLOB){
+ fbh->ftype = SQLT_CHR;/*SQLT_LNG*/
+ }
+ else {
+ fbh->ftype = SQLT_LVB; /*Binary form seems this is the only value where we can get the length correctly*/
+ }
+ }
+ else if (imp_sth->clbk_lob){ /*get by peice with callback a slow*/
+ fbh->clbk_lob = 1;
+ fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
+ fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
+ fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
+ fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
+ if (!imp_sth->piece_size){ /*if not set use max value*/
+ imp_sth->piece_size=imp_sth->long_readlen;
+ }
+ if (fbh->dbtype == ORA_CLOB){
+ fbh->ftype = SQLT_CHR;
+ } else {
+ fbh->ftype = SQLT_BIN; /*other Binary*/
+ }
+ fbh->fetch_func = fetch_clbk_lob;
+
+ }
+ else if (imp_sth->piece_lob){ /*get by peice with polling slowest*/
+ fbh->piece_lob = 1;
+ fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
+ fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
+ fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
+ fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
+ if (!imp_sth->piece_size){ /*if not set use max value*/
+ imp_sth->piece_size=imp_sth->long_readlen;
+ }
+ if (fbh->dbtype == ORA_CLOB){
+ fbh->ftype = SQLT_CHR;
+ }
+ else {
+ fbh->ftype = SQLT_BIN; /*other Binary */
+ }
+ fbh->fetch_func = fetch_get_piece;
+
+ }
+ else { /*auto lob fetch with locator by far the fastest*/
+ fbh->disize = sizeof(OCILobLocator*);/* Size of the lob locator ar we do not really get the lob! */
+ if (imp_sth->auto_lob) {
+ fbh->fetch_func = fetch_func_autolob;
+ }
+ else {
+ fbh->fetch_func = fetch_func_getrefpv;
+ }
+
+ fbh->bless = "OCILobLocatorPtr";
+ fbh->desc_t = OCI_DTYPE_LOB;
+ OCIDescriptorAlloc_ok(imp_sth, imp_sth->envhp, &fbh->desc_h, fbh->desc_t);
- if (!imp_sth->piece_size){ /*if not set use max value*/
- imp_sth->piece_size=imp_sth->long_readlen;
- }
-
- fbh->ftype = SQLT_BIN;
- fbh->fetch_func = fetch_clbk_lob;
-
- }
- else if (imp_sth->piece_lob){ /*get by peice with polling slowest*/
- fbh->piece_lob = 1;
- fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
- fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
- fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
- fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
+ }
- if (!imp_sth->piece_size){ /*if not set use max value*/
- imp_sth->piece_size=imp_sth->long_readlen;
- }
- fbh->ftype = SQLT_BIN;
- fbh->fetch_func = fetch_get_piece;
- }
- else {
- fbh->disize = long_readlen * 2;
- fbh->dbsize = (fbh->disize>65535) ? 65535 : fbh->disize;
- fbh->ftype = 95; /* VAR form */
- fbh->fetch_func = fetch_func_varfield;
- }
- break;
-
- case ORA_ROWID: /* ROWID */
- case 104: /* ROWID Desc */
- fbh->disize = 20;
- fbh->prec = fbh->disize;
- break;
- case 108: /* some sort of embedded object */
- imp_sth->row_cache_off = 1;/* cant fetch more thatn one at a time */
- fbh->ftype = fbh->dbtype; /*varray or alike */
- fbh->fetch_func = fetch_func_oci_object; /* need a new fetch function for it */
- fbh->fetch_cleanup = fetch_cleanup_oci_object; /* clean up any AV from the fetch*/
- fbh->desc_t = SQLT_NTY;
- if (!imp_sth->dschp){
- OCIHandleAlloc_ok(imp_sth, imp_sth->envhp, &imp_sth->dschp, OCI_HTYPE_DESCRIBE, status);
- if (status != OCI_SUCCESS) {
- oci_error(h,imp_sth->errhp, status, "OCIHandleAlloc");
- ++num_errors;
- }
- }
- break;
- case ORA_CLOB: /* CLOB & NCLOB */
- case ORA_BLOB: /* BLOB */
- case ORA_BFILE: /* BFILE */
- has_longs++;
- fbh->ftype = fbh->dbtype;
- imp_sth->ret_lobs = 1;
- imp_sth->row_cache_off = 1; /* Cannot use mulit fetch for a lob*/
- /* Unless they are just getting the locator */
-
- if (imp_sth->pers_lob){ /*get as one peice fasted but limited to 64k big you can get.*/
-
- fbh->pers_lob = 1;
-
- if (long_readlen){
- fbh->disize =long_readlen;/*user set max value for the fetch*/
- }
- else {
- fbh->disize = fbh->dbsize*10; /*default size*/
- }
-
-
- if (fbh->dbtype == ORA_CLOB){
- fbh->ftype = SQLT_CHR;/*SQLT_LNG*/
- }
- else {
- fbh->ftype = SQLT_LVB; /*Binary form seems this is the only value where we can get the length correctly*/
- }
- }
- else if (imp_sth->clbk_lob){ /*get by peice with callback a slow*/
- fbh->clbk_lob = 1;
- fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
- fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
- fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
- fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
- if (!imp_sth->piece_size){ /*if not set use max value*/
- imp_sth->piece_size=imp_sth->long_readlen;
- }
- if (fbh->dbtype == ORA_CLOB){
- fbh->ftype = SQLT_CHR;
- } else {
- fbh->ftype = SQLT_BIN; /*other Binary*/
- }
- fbh->fetch_func = fetch_clbk_lob;
-
- }
- else if (imp_sth->piece_lob){ /*get by peice with polling slowest*/
- fbh->piece_lob = 1;
- fbh->define_mode = OCI_DYNAMIC_FETCH; /* piecwise fetch*/
- fbh->disize = imp_sth->long_readlen; /*user set max value for the fetch*/
- fbh->piece_size = imp_sth->piece_size; /*the size for each piece*/
- fbh->fetch_cleanup = fetch_cleanup_pres_lobs; /* clean up buffer before each fetch*/
- if (!imp_sth->piece_size){ /*if not set use max value*/
- imp_sth->piece_size=imp_sth->long_readlen;
- }
- if (fbh->dbtype == ORA_CLOB){
- fbh->ftype = SQLT_CHR;
- }
- else {
- fbh->ftype = SQLT_BIN; /*other Binary */
- }
- fbh->fetch_func = fetch_get_piece;
-
- }
- else { /*auto lob fetch with locator by far the fastest*/
- fbh->disize = sizeof(OCILobLocator*);/* Size of the lob locator ar we do not really get the lob! */
- if (imp_sth->auto_lob) {
- fbh->fetch_func = fetch_func_autolob;
- }
- else {
- fbh->fetch_func = fetch_func_getrefpv;
- }
-
- fbh->bless = "OCILobLocatorPtr";
- fbh->desc_t = OCI_DTYPE_LOB;
- OCIDescriptorAlloc_ok(imp_sth, imp_sth->envhp, &fbh->desc_h, fbh->desc_t);
-
-
- }
-
- break;
+ break;
#ifdef OCI_DTYPE_REF
- case 111: /* REF */
- fbh_setup_getrefpv(imp_sth, fbh, OCI_DTYPE_REF, "OCIRefPtr");
- break;
+ case 111: /* REF */
+ fbh_setup_getrefpv(imp_sth, fbh, OCI_DTYPE_REF, "OCIRefPtr");
+ break;
#endif
- case ORA_RSET: /* RSET */
- fbh->ftype = fbh->dbtype;
- fbh->disize = sizeof(OCIStmt *);
- fbh->fetch_func = fetch_func_rset;
- fbh->fetch_cleanup = fetch_cleanup_rset;
- nested_cursors++;
- break;
-
- case 182: /* INTERVAL YEAR TO MONTH */
- case 183: /* INTERVAL DAY TO SECOND */
- case 185: /* TIME (ocidfn.h) */
- case 186: /* TIME WITH TIME ZONE (ocidfn.h) */
- case 187: /* TIMESTAMP */
- case 188: /* TIMESTAMP WITH TIME ZONE */
- case 189: /* INTERVAL YEAR TO MONTH (ocidfn.h) */
- case 190: /* INTERVAL DAY TO SECOND */
- case 232: /* TIMESTAMP WITH LOCAL TIME ZONE */
- /* actually dependent on NLS default date format*/
- fbh->disize = 75; /* XXX */
- break;
+ case ORA_RSET: /* RSET */
+ fbh->ftype = fbh->dbtype;
+ fbh->disize = sizeof(OCIStmt *);
+ fbh->fetch_func = fetch_func_rset;
+ fbh->fetch_cleanup = fetch_cleanup_rset;
+ nested_cursors++;
+ break;
+
+ case 182: /* INTERVAL YEAR TO MONTH */
+ case 183: /* INTERVAL DAY TO SECOND */
+ case 185: /* TIME (ocidfn.h) */
+ case 186: /* TIME WITH TIME ZONE (ocidfn.h) */
+ case 187: /* TIMESTAMP */
+ case 188: /* TIMESTAMP WITH TIME ZONE */
+ case 189: /* INTERVAL YEAR TO MONTH (ocidfn.h) */
+ case 190: /* INTERVAL DAY TO SECOND */
+ case 232: /* TIMESTAMP WITH LOCAL TIME ZONE */
+ /* actually dependent on NLS default date format*/
+ fbh->disize = 75; /* XXX */
+ break;
- default:
+ default:
/* XXX unhandled type may lead to errors or worse */
- fbh->ftype = fbh->dbtype;
- fbh->disize = fbh->dbsize;
- p = "Field %d has an Oracle type (%d) which is not explicitly supported%s";
- if (DBIc_DBISTATE(imp_sth)->debug >= 1 || dbd_verbose >= 3 )
- PerlIO_printf(DBIc_LOGPIO(imp_sth), p, i, fbh->dbtype, "\n");
- if (PL_dowarn)
- warn(p, i, fbh->dbtype, "");
- break;
+ fbh->ftype = fbh->dbtype;
+ fbh->disize = fbh->dbsize;
+ p = "Field %d has an Oracle type (%d) which is not explicitly supported%s";
+ if (DBIc_DBISTATE(imp_sth)->debug >= 1 || dbd_verbose >= 3 )
+ PerlIO_printf(DBIc_LOGPIO(imp_sth), p, i, fbh->dbtype, "\n");
+ if (PL_dowarn)
+ warn(p, i, fbh->dbtype, "");
+ break;
}
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
- PerlIO_printf(
- DBIc_LOGPIO(imp_sth),
- "Described col %2d: dbtype %d(%s), scale %d, prec %d, nullok %d, "
- "name %s\n : dbsize %d, char_used %d, char_size %d, "
- "csid %d, csform %d(%s), disize %d\n",
- i, fbh->dbtype, sql_typecode_name(fbh->dbtype), fbh->scale,
- fbh->prec, fbh->nullok, fbh->name, fbh->dbsize,
- fbh->len_char_used, fbh->len_char_size,
- fbh->csid,fbh->csform,oci_csform_name(fbh->csform), fbh->disize);
+ PerlIO_printf(
+ DBIc_LOGPIO(imp_sth),
+ "Described col %2d: dbtype %d(%s), scale %d, prec %d, nullok %d, "
+ "name %s\n : dbsize %d, char_used %d, char_size %d, "
+ "csid %d, csform %d(%s), disize %d\n",
+ i, fbh->dbtype, sql_typecode_name(fbh->dbtype), fbh->scale,
+ fbh->prec, fbh->nullok, fbh->name, fbh->dbsize,
+ fbh->len_char_used, fbh->len_char_size,
+ fbh->csid,fbh->csform,oci_csform_name(fbh->csform), fbh->disize);
if (fbh->ftype == 5) /* XXX need to handle wide chars somehow */
fbh->disize += 1; /* allow for null terminator */
- /* dbsize can be zero for 'select NULL ...' */
+ /* dbsize can be zero for 'select NULL ...' */
imp_sth->t_dbsize += fbh->dbsize;
@@ -3828,8 +3830,8 @@
imp_sth->est_width = est_width;
sth_set_row_cache(h, imp_sth,
- (imp_dbh->max_nested_cursors) ? 0 :nested_cursors ,
- (int)num_fields, has_longs );
+ (imp_dbh->max_nested_cursors) ? 0 :nested_cursors ,
+ (int)num_fields, has_longs );
/* Initialise cache counters */
imp_sth->in_cache = 0;
imp_sth->eod_errno = 0;
@@ -3861,26 +3863,26 @@
if (fbh->ftype == ORA_RSET) { /* RSET */
OCIHandleAlloc_ok(imp_sth, imp_sth->envhp,
- (dvoid*)&((OCIStmt **)fb_ary->abuf)[0],
- OCI_HTYPE_STMT, status);
+ (dvoid*)&((OCIStmt **)fb_ary->abuf)[0],
+ OCI_HTYPE_STMT, status);
}
OCIDefineByPos_log_stat(imp_sth, imp_sth->stmhp,
- &fbh->defnp,
- imp_sth->errhp,
- (ub4) i,
- (fbh->desc_h) ? (dvoid*)&fbh->desc_h : fbh->clbk_lob ? (dvoid *) 0: fbh->piece_lob ? (dvoid *) 0:(dvoid*)fb_ary->abuf,
- (fbh->desc_h) ? 0 : define_len,
- (ub2)fbh->ftype,
- fb_ary->aindp,
- (ftype==94||ftype==95) ? NULL : fb_ary->arlen,
- fb_ary->arcode,
- fbh->define_mode,
- status);
+ &fbh->defnp,
+ imp_sth->errhp,
+ (ub4) i,
+ (fbh->desc_h) ? (dvoid*)&fbh->desc_h : fbh->clbk_lob ? (dvoid *) 0: fbh->piece_lob ? (dvoid *) 0:(dvoid*)fb_ary->abuf,
+ (fbh->desc_h) ? 0 : define_len,
+ (ub2)fbh->ftype,
+ fb_ary->aindp,
+ (ftype==94||ftype==95) ? NULL : fb_ary->arlen,
+ fb_ary->arcode,
+ fbh->define_mode,
+ status);
if (fbh->clbk_lob){
- /* use a dynamic callback for persistent binary and char lobs*/
+ /* use a dynamic callback for persistent binary and char lobs*/
OCIDefineDynamic_log_stat(imp_sth, fbh->defnp,imp_sth->errhp,(dvoid *) fbh,status);
}
@@ -3917,14 +3919,14 @@
#ifdef OCI_ATTR_CHARSET_FORM
if ( (fbh->dbtype == 1) && fbh->csform ) {
- /* csform may be 0 when talking to Oracle 8.0 database*/
+ /* csform may be 0 when talking to Oracle 8.0 database*/
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
" calling OCIAttrSet OCI_ATTR_CHARSET_FORM with csform=%d (%s)\n",
fbh->csform,oci_csform_name(fbh->csform) );
OCIAttrSet_log_stat(imp_sth, fbh->defnp, (ub4) OCI_HTYPE_DEFINE, (dvoid *) &fbh->csform,
- (ub4) 0, (ub4) OCI_ATTR_CHARSET_FORM, imp_sth->errhp, status );
+ (ub4) 0, (ub4) OCI_ATTR_CHARSET_FORM, imp_sth->errhp, status );
if (status != OCI_SUCCESS) {
oci_error(h, imp_sth->errhp, status, "OCIAttrSet OCI_ATTR_CHARSET_FORM");
++num_errors;
@@ -4016,7 +4018,7 @@
imp_sth->rs_array_idx=0;
}
- else { /*Array Fetch the New Noraml Super speedy and very nice*/
+ else { /*Array Fetch the New Normal Super speedy and very nice*/
imp_sth->rs_array_idx++;
@@ -4161,7 +4163,7 @@
char errstr[256];
sts = DBIc_DBISTATE(imp_sth)->sql_type_cast_svpv(
- aTHX_ sv, fbh->req_type, fbh->bind_flags, NULL);
+ aTHX_ sv, fbh->req_type, fbh->bind_flags, NULL);
if (sts == 0) {
sprintf(errstr,
Modified: dbd-oracle/trunk/t/26exe_array.t
==============================================================================
--- dbd-oracle/trunk/t/26exe_array.t (original)
+++ dbd-oracle/trunk/t/26exe_array.t Fri Oct 26 05:16:05 2012
@@ -1,15 +1,9 @@
-#!/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
-## ----------------------------------------------------------------------------
-
+# $Id$
+# Completely new test for DBD::Oracle which came from DBD::ODBC
+# Author: Martin J. Evans
+#
+# loads of execute_array and execute_for_fetch tests using DBI's methods
+#
use Test::More;
use strict;
use Data::Dumper;
@@ -17,25 +11,30 @@
$| = 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, $ea);
+use DBI qw(:sql_types);
+use ExecuteArray;
+
+END {
+ if ($dbh && $ea) {
+ $ea->drop_table($dbh);
+ $dbh->disconnect();
+ }
+ Test::NoWarnings::had_no_warnings()
+ if ($has_test_nowarnings);
+ done_testing();
+}
-# 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});
};
@@ -43,426 +42,24 @@
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 order by a/);
- 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 => [4, 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});
+$ea = ExecuteArray->new($dbh, 1); # set odbc_disable_array_operations
+$dbh = $ea->dbh;
-update($dbh, {array_context => 1, raise => 1});
+$ea->drop_table($dbh);
+ok($ea->create_table($dbh), "create test table") or exit 1;
+$ea->simple($dbh, {array_context => 1, raise => 1});
+$ea->simple($dbh, {array_context => 0, raise => 1});
+$ea->error($dbh, {array_context => 1, raise => 1});
+$ea->error($dbh, {array_context => 0, raise => 1});
+$ea->error($dbh, {array_context => 1, raise => 0});
+$ea->error($dbh, {array_context => 0, raise => 0});
+
+$ea->row_wise($dbh, {array_context => 1, raise => 1});
+
+$ea->update($dbh, {array_context => 1, raise => 1});
+
+$ea->error($dbh, {array_context => 1, raise => 1, notuplestatus => 1});
+$ea->error($dbh, {array_context => 0, raise => 1, notuplestatus => 1});
+$ea->error($dbh, {array_context => 1, raise => 0, notuplestatus => 1});
+$ea->error($dbh, {array_context => 0, raise => 0, notuplestatus => 1});
Added: dbd-oracle/trunk/t/ExecuteArray.pm
==============================================================================
--- (empty file)
+++ dbd-oracle/trunk/t/ExecuteArray.pm Fri Oct 26 05:16:05 2012
@@ -0,0 +1,519 @@
+# $Id$
+# Author: Martin J. Evans
+# This should be an exact copy of the same file in DBD::ODBC
+# If you change this file please let me know.
+package ExecuteArray;
+use Test::More;
+use Data::Dumper;
+use DBI;
+our $VERSION = '0.01';
+
+my $table = 'PERL_DBD_execute_array';
+my $table2 = 'PERL_DBD_execute_array2';
+my @p1 = (1,2,3,4,5);
+my @p2 = qw(one two three four five);
+my $fetch_row = 0;
+my @captured_error; # values captured in error handler
+
+sub error_handler
+{
+ @captured_error = @_;
+ note("***** error handler called *****");
+ 0; # pass errors on
+}
+
+sub new {
+ my ($class, $dbh, $dbi_version) = @_;
+ my $self = {};
+
+ $dbh = setup($dbh, $dbi_version);
+ $self->{_dbh} = $dbh;
+
+ # find out how the driver supports row counts and parameter status
+ $self->{_param_array_row_counts} = $dbh->get_info(153);
+ # a return of 1 is SQL_PARC_BATCH which means:
+ # Individual row counts are available for each set of parameters. This is
+ # conceptually equivalent to the driver generating a batch of SQL
+ # statements, one for each parameter set in the array. Extended error
+ # information can be retrieved by using the SQL_PARAM_STATUS_PTR
+ # descriptor field.
+ # a return of 2 is SQL_PARC_NO_BATCH which means:
+ # There is only one row count available, which is the cumulative row
+ # count resulting from the execution of the statement for the entire
+ # array of parameters. This is conceptually equivalent to treating
+ # the statement together with the complete parameter array as one
+ # atomic unit. Errors are handled the same as if one statement
+ # were executed.
+ return bless ($self, $class);
+}
+
+sub dbh {
+ my $self = shift;
+ return $self->{_dbh};
+}
+
+sub setup {
+ my ($dbh, $dbi_version) = @_;
+
+ $dbh = enable_mars($dbh, $native);
+ $dbh->{HandleError} = \&error_handler;
+ if ($dbi_version) {
+ $dbh->{odbc_disable_array_operations} = 1;
+ }
+ #$dbh->{ora_verbose} = 5;
+ $dbh->{RaiseError} = 1;
+ $dbh->{PrintError} = 0;
+ $dbh->{ChopBlanks} = 1;
+ $dbh->{AutoCommit} = 1;
+
+ return $dbh;
+}
+
+sub create_table
+{
+ my ($self, $dbh) = @_;
+
+ eval {
+ $dbh->do(qq/create table $table (a integer not null primary key, b char(20))/);
+ };
+ if ($@) {
+ diag("Failed to create test table $table - $@");
+ return 0;
+ }
+ eval {
+ $dbh->do(qq/create table $table2 (a integer not null 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 ($self, $dbh) = @_;
+
+ 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 order by a/);
+ 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 ($self, $tsts, $expected) = @_;
+
+ note(Data::Dumper->Dump([$tsts], [qw(ArrayTupleStatus)]));
+
+ BAIL_OUT('expected data must be specified')
+ if (!$expected || (ref($expected) ne 'ARRAY'));
+
+ is(ref($tsts), 'ARRAY', 'tuple status is an array') or return;
+ if (!is(scalar(@$tsts), scalar(@$expected), 'status arrays same size')) {
+ diag(Dumper($tsts));
+ diag(Dumper($expected));
+ return;
+ }
+
+ my $row = 0;
+ foreach my $s (@$expected) {
+ if (ref($s)) {
+ unless ($self->{_param_array_row_counts} == 2) {
+ is(ref($tsts->[$row]), 'ARRAY', 'array in array tuple status');
+ is(scalar(@{$tsts->[$row]}), 3, '3 elements in array tuple status error');
+ }
+ } else {
+ if ($tsts->[$row] == -1) {
+ pass("row $row tuple status unknown");
+ } else {
+ is($tsts->[$row], $s, "row $row tuple status");
+ }
+ }
+ $row++;
+ }
+ return;
+}
+
+# insert might return 'mas' which means the caller said the test
+# required Multiple Active Statements and the driver appeared to not
+# support MAS.
+#
+# ref is a hash ref:
+# error (0|1) whether we expect an error
+# raise (0|1) means set RaiseError to this
+# commit (0|1) do the inserts in a txn
+# tuple arrayref of what we expect in the tuple status
+# e.g., [1,1,1,1,[]]
+# where the empty [] signifies we expect an error for this row
+# where 1 signifies we the expect row count for this row
+# affected - the total number of rows affected for insert/update
+#
+sub insert
+{
+ my ($self, $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);
+ my $tuple_status_arg = {};
+ $tuple_status_arg->{ArrayTupleStatus} = \@tuple_status unless $ref->{notuplestatus};
+
+ $sts = 999999; # to ensure it is overwritten
+ $total_affected = 999998;
+ if ($ref->{array_context}) {
+ eval {
+ if ($ref->{params}) {
+ ($sts, $total_affected) =
+ $sth->execute_array($tuple_status_arg,
+ @{$ref->{params}});
+ } elsif ($ref->{fetch}) {
+ ($sts, $total_affected) =
+ $sth->execute_array(
+ {%{$tuple_status_arg},
+ ArrayTupleFetch => $ref->{fetch}});
+ } else {
+ ($sts, $total_affected) =
+ $sth->execute_array($tuple_status_arg);
+ }
+ };
+ } else {
+ eval {
+ if ($ref->{params}) {
+ $sts =
+ $sth->execute_array($tuple_status_arg,
+ @{$ref->{params}});
+ } else {
+ $sts =
+ $sth->execute_array($tuple_status_arg);
+ }
+ };
+ }
+ 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} && !exists($ref->{notuplestatus})) {
+ $self->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 ($self, $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);
+ $self->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)]);
+ $self->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(?,?)/);
+
+ $self->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(?,?)/);
+
+ $self->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 ($self, $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);
+ $self->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);
+ $self->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 ($self, $dbh, $ref) = @_;
+
+ note("row_size via execute_for_fetch");
+
+ # Populate the first table via a ArrayTupleFetch which points to a sub
+ # returning rows
+ $fetch_row = 0; # reset fetch_sub to start with first row
+ clear_table($dbh, $table);
+ my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
+ $self->insert($dbh, $sth,
+ {commit => 0, error => 0, sts => 5, affected => 5,
+ tuple => [1, 1, 1, 1, 1], %$ref,
+ fetch => \&fetch_sub});
+
+ # NOTE: The following test requires Multiple Active Statements. 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. Exceptions are DBD::Oracle which definitely does
+ # support MAS.
+ # The data pushed into the first table is retrieved via ArrayTupleFetch
+ # from the second table by passing an executed select statement handle into
+ # execute_array.
+ 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/);
+ # some drivers issue warnings when mas fails and this causes
+ # Test::NoWarnings to output something when we already found
+ # the test failed and captured it.
+ # e.g., some ODBC drivers cannot do MAS and this test is then expected to
+ # fail but we ignore the failure. Unfortunately in failing DBD::ODBC will
+ # issue a warning in addition to the fail
+ $sth->{Warn} = 0;
+ $sth->{Warn} = 0;
+ ok($sth2->execute, 'execute on second table') or diag($sth2->errstr);
+ ok($sth2->{Executed}, 'second statement is in executed state');
+ my $res = $self->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);
+}
+
+# test updates
+# updates are special as you can update more rows than there are parameter rows
+sub update
+{
+ my ($self, $dbh, $ref) = @_;
+
+ note("update test");
+
+ # populate the first table with the default 5 rows using a ArrayTupleFetch
+ $fetch_row = 0;
+ clear_table($dbh, $table);
+ my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
+ $self->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);
+
+ # update all rows b column to 'fred' checking rows affected is 5
+ $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);
+ $self->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)]);
+
+ # update 4 rows column b to 'dave' checking rows affected is 4
+ $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);
+ $self->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)]);
+
+ # now change all rows b column to 'pete' - this will change all 5
+ # rows even though we have 2 rows of parameters so we can see if
+ # the rows affected is > parameter rows
+ $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%']);
+ $self->insert($dbh, $sth,
+ {commit => 0, error => 0, sts => 2, affected => 5,
+ tuple => [4, 1], %$ref});
+ check_data($dbh, \@p1, [qw(pete pete pete pete pete)]);
+}
+
+sub enable_mars {
+ my $dbh = shift;
+
+ # this test uses multiple active statements
+ # if we recognise the driver and it supports MAS enable it
+ my $driver_name = $dbh->get_info(6) || '';
+ if (($driver_name eq 'libessqlsrv.so') ||
+ ($driver_name =~ /libsqlncli/)) {
+ my $dsn = $ENV{DBI_DSN};
+ if ($dsn !~ /^dbi:ODBC:DSN=/ && $dsn !~ /DRIVER=/i) {
+ my @a = split(q/:/, $ENV{DBI_DSN});
+ $dsn = join(q/:/, @a[0..($#a - 1)]) . ":DSN=" . $a[-1];
+ }
+ $dsn .= ";MARS_Connection=yes";
+ $dbh->disconnect;
+ $dbh = DBI->connect($dsn, $ENV{DBI_USER}, $ENV{DBI_PASS});
+ }
+ return $dbh;
+}
+
+1;