Author: byterock
Date: Mon Sep 29 10:34:35 2008
New Revision: 11905
Modified:
dbd-oracle/branches/utf8_ea/dbdimp.c
dbd-oracle/branches/utf8_ea/dbdimp.h
Log:
one more test
Modified: dbd-oracle/branches/utf8_ea/dbdimp.c
==============================================================================
--- dbd-oracle/branches/utf8_ea/dbdimp.c (original)
+++ dbd-oracle/branches/utf8_ea/dbdimp.c Mon Sep 29 10:34:35 2008
@@ -1,3994 +1,4041 @@
-/*
- vim: sw=4:ts=8
- dbdimp.c
-
- Copyright (c) 1994-2006 Tim Bunce Ireland
- Copyright (c) 2006-2008 John Scoles (The Pythian Group), Canada
-
- See the COPYRIGHT section in the Oracle.pm file for terms.
-
-*/
-
-#ifdef WIN32
-#define strcasecmp strcmpi
-#endif
-
-#ifdef __CYGWIN32__
-#include "w32api/windows.h"
-#include "w32api/winbase.h"
-#endif /* __CYGWIN32__ */
-
-#include "Oracle.h"
-
-#if defined(CAN_USE_PRO_C)
-/* #include <sql2oci.h> for SQL_SINGLE_RCTX but causes clashes */
-#if !defined(SQL_SINGLE_RCTX)
-/* http://download-west.oracle.com/docs/cd/B10501_01/appdev.920/a97269/pc_01int.htm#1174 */
-#define SQL_SINGLE_RCTX (dvoid *)0 /* from precomp/public/sqlcpr.h */
-#endif
-#endif
-
-/* XXX DBI should provide a better version of this */
-#define IS_DBI_HANDLE(h) \
- (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && \
- SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P')
-
-#ifndef SvPOK_only_UTF8
-#define SvPOK_only_UTF8(sv) SvPOK_only(sv)
-#endif
-
-DBISTATE_DECLARE;
-
-int ora_fetchtest; /* intrnal test only, not thread safe */
-int is_extproc = 0;
-int dbd_verbose = 0; /* DBD only debugging*/
-
-/* bitflag constants for figuring out how to handle utf8 for array binds */
-#define ARRAY_BIND_NATIVE 0x01
-#define ARRAY_BIND_UTF8 0x02
-#define ARRAY_BIND_MIXED (ARRAY_BIND_NATIVE|ARRAY_BIND_UTF8)
-
-ub2 charsetid = 0;
-ub2 ncharsetid = 0;
-ub2 us7ascii_csid = 1;
-ub2 utf8_csid = 871;
-ub2 al32utf8_csid = 873;
-ub2 al16utf16_csid = 2000;
-ub2 we8mswin1252 = 178;
-
-typedef struct sql_fbh_st sql_fbh_t;
-struct sql_fbh_st {
- int dbtype;
- int prec;
- int scale;
-};
-static sql_fbh_t ora2sql_type _((imp_fbh_t* fbh));
-
-void ora_free_phs_contents _((phs_t *phs));
-static void dump_env_to_trace();
-
-static sb4
-oci_error_get(OCIError *errhp, sword status, char *what, SV *errstr, int debug)
-{
- dTHX;
- text errbuf[1024];
- ub4 recno = 0;
- sb4 errcode = 0;
- sb4 eg_errcode = 0;
- sword eg_status;
- if (!SvOK(errstr))
- sv_setpv(errstr,"");
- if (!errhp) {
- sv_catpv(errstr, oci_status_name(status));
- if (what) {
- sv_catpv(errstr, " ");
- sv_catpv(errstr, what);
- }
- return status;
- }
-
- while( ++recno
- && OCIErrorGet_log_stat(errhp, recno, (text*)NULL, &eg_errcode, errbuf,
- (ub4)sizeof(errbuf), OCI_HTYPE_ERROR, eg_status) != OCI_NO_DATA
- && eg_status != OCI_INVALID_HANDLE
- && recno < 100
- ) {
- if (debug >= 4 || recno>1/*XXX temp*/ || dbd_verbose >= 4)
- PerlIO_printf(DBILOGFP, " OCIErrorGet after %s (er%ld:%s): %d, %ld: %s\n",
- what ? what : "<NULL>", (long)recno,
- (eg_status==OCI_SUCCESS) ? "ok" : oci_status_name(eg_status),
- status, (long)eg_errcode, errbuf);
- errcode = eg_errcode;
- sv_catpv(errstr, (char*)errbuf);
- if (*(SvEND(errstr)-1) == '\n')
- --SvCUR(errstr);
- }
- if (what || status != OCI_ERROR) {
- sv_catpv(errstr, (debug<0) ? " (" : " (DBD ");
- sv_catpv(errstr, oci_status_name(status));
- if (what) {
- sv_catpv(errstr, ": ");
- sv_catpv(errstr, what);
- }
- sv_catpv(errstr, ")");
- }
- return errcode;
-}
-
-static int
-GetRegKey(char *key, char *val, char *data, unsigned long *size)
-{
-#ifdef WIN32
- unsigned long len = *size - 1;
- HKEY hKey;
- long ret;
-
- ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, key, 0, KEY_QUERY_VALUE, &hKey);
- if (ret != ERROR_SUCCESS)
- return 0;
- ret = RegQueryValueEx(hKey, val, NULL, NULL, data, size);
- RegCloseKey(hKey);
- if ((ret != ERROR_SUCCESS) || (*size >= len))
- return 0;
- return 1;
-#else
- /* For gcc not to warn on unused parameters. */
- if( key ){}
- if( val ){}
- if( data ){}
- if( size ){}
- return 0;
-#endif
-}
-
-char *
-ora_env_var(char *name, char *buf, unsigned long size)
-{
-#define WIN32_REG_BUFSIZE 80
- dTHX;
- char last_home_id[WIN32_REG_BUFSIZE+1];
- char ora_home_key[WIN32_REG_BUFSIZE+1];
- unsigned long len = WIN32_REG_BUFSIZE;
- char *e = getenv(name);
- if (e)
- return e;
- if (!GetRegKey("SOFTWARE\\ORACLE\\ALL_HOMES", "LAST_HOME", last_home_id, &len))
- return Nullch;
- last_home_id[2] = 0;
- sprintf(ora_home_key, "SOFTWARE\\ORACLE\\HOME%s", last_home_id);
- size -= 1; /* allow room for null termination */
- if (!GetRegKey(ora_home_key, name, buf, &size))
- return Nullch;
- buf[size] = 0;
- return buf;
-}
-
-#ifdef __CYGWIN32__
-/* Under Cygwin there are issues with setting environment variables
- * at runtime such that Windows-native libraries loaded by a Cygwin
- * process can see those changes.
- *
- * Cygwin maintains its own cache of environment variables, and also
- * only writes to the Windows environment using the "_putenv" win32
- * call. This call writes to a Windows C runtime cache, rather than
- * the true process environment block.
- *
- * In order to change environment variables so that the Oracle client
- * DLL can see the change, the win32 function SetEnvironmentVariable
- * must be called. This function gives an interface to that API.
- *
- * It is only available when building under Cygwin, and is used by
- * the testsuite.
- *
- * Whilst it could be called by end users, it should be used with
- * caution, as it bypasses the environment variable conversions that
- * Cygwin typically performs.
- */
-void
-ora_cygwin_set_env(char *name, char *value)
-{
- SetEnvironmentVariable(name, value);
-}
-#endif /* __CYGWIN32__ */
-
-void
-dbd_init(dbistate_t *dbistate)
-{
- dTHX;
- DBIS = dbistate;
- dbd_init_oci(dbistate);
-}
-
-
-int
-dbd_discon_all(SV *drh, imp_drh_t *imp_drh)
-{
- dTHR;
- dTHX;
- /* The disconnect_all concept is flawed and needs more work */
- if (!dirty && !SvTRUE(perl_get_sv("DBI::PERL_ENDING",0))) {
- DBIh_SET_ERR_CHAR(drh, (imp_xxh_t*)imp_drh, Nullch, 1, "disconnect_all not implemented", Nullch, Nullch);
- return FALSE;
- }
- return FALSE;
-}
-
-
-
-void
-dbd_fbh_dump(imp_fbh_t *fbh, int i, int aidx)
-{
- dTHX;
- PerlIO *fp = DBILOGFP;
- PerlIO_printf(fp, " fbh %d: '%s'\t%s, ",
- i, fbh->name, (fbh->nullok) ? "NULLable" : "NO null ");
- PerlIO_printf(fp, "otype %3d->%3d, dbsize %ld/%ld, p%d.s%d\n",
- fbh->dbtype, fbh->ftype, (long)fbh->dbsize,(long)fbh->disize,
- fbh->prec, fbh->scale);
- if (fbh->fb_ary) {
- PerlIO_printf(fp, " out: ftype %d, bufl %d. indp %d, rlen %d, rcode %d\n",
- fbh->ftype, fbh->fb_ary->bufl, fbh->fb_ary->aindp[aidx],
- fbh->fb_ary->arlen[aidx], fbh->fb_ary->arcode[aidx]);
- }
-}
-
-
-int
-ora_dbtype_is_long(int dbtype)
-{
- /* Is it a LONG, LONG RAW, LONG VARCHAR or LONG VARRAW type? */
- /* Return preferred type code to use if it's a long, else 0. */
- if (dbtype == 8 || dbtype == 24) /* LONG or LONG RAW */
- return dbtype; /* --> same */
- if (dbtype == 94) /* LONG VARCHAR */
- return 8; /* --> LONG */
- if (dbtype == 95) /* LONG VARRAW */
- return 24; /* --> LONG RAW */
- return 0;
-}
-
-static int
-oratype_bind_ok(int dbtype) /* It's a type we support for placeholders */
-{
- /* basically we support types that can be returned as strings */
- switch(dbtype) {
- case 1: /* VARCHAR2 */
- case 2: /* NVARCHAR2 */
- case 5: /* STRING */
- case 8: /* LONG */
- case 21: /* BINARY FLOAT os-endian */
- case 22: /* BINARY DOUBLE os-endian */
- case 23: /* RAW */
- case 24: /* LONG RAW */
- case 96: /* CHAR */
- case 97: /* CHARZ */
- case 100: /* BINARY FLOAT oracle-endian */
- case 101: /* BINARY DOUBLE oracle-endian */
- case 106: /* MLSLABEL */
- case 102: /* SQLT_CUR OCI 7 cursor variable */
- case 112: /* SQLT_CLOB / long */
- case 113: /* SQLT_BLOB / long */
- case 116: /* SQLT_RSET OCI 8 cursor variable */
- case ORA_VARCHAR2_TABLE: /* 201 */
- case ORA_NUMBER_TABLE: /* 202 */
- case ORA_XMLTYPE: /* SQLT_NTY must be carefull here as its value (108) is the same for an embedded object Well realy only XML clobs not embedded objects */
- return 1;
- }
- return 0;
-}
-
-
-/* --- allocate and free oracle oci 'array' buffers --- */
-
-/* --- allocate and free oracle oci 'array' buffers for callback--- */
-
-fb_ary_t *
-fb_ary_cb_alloc(ub4 piece_size, ub4 max_len, int size)
-{
- fb_ary_t *fb_ary;
- /* these should be reworked to only to one Newz() */
- /* and setup the pointers in the head fb_ary struct */
- Newz(42, fb_ary, sizeof(fb_ary_t), fb_ary_t);
- Newz(42, fb_ary->abuf, size * piece_size, ub1);
- Newz(42, fb_ary->cb_abuf, size * max_len, ub1);
- Newz(42, fb_ary->aindp, (unsigned)size, sb2);
- Newz(42, fb_ary->arlen, (unsigned)size, ub2);
- Newz(42, fb_ary->arcode, (unsigned)size, ub2);
- fb_ary->bufl = piece_size;
- fb_ary->cb_bufl = max_len;
- return fb_ary;
-}
-
-
-/* --- allocate and free oracle oci 'array' buffers --- */
-
-fb_ary_t *
-fb_ary_alloc(ub4 bufl, int size)
-{
- fb_ary_t *fb_ary;
- /* these should be reworked to only to one Newz() */
- /* and setup the pointers in the head fb_ary struct */
- Newz(42, fb_ary, sizeof(fb_ary_t), fb_ary_t);
- Newz(42, fb_ary->abuf, size * bufl, ub1);
- Newz(42, fb_ary->aindp, (unsigned)size, sb2);
- Newz(42, fb_ary->arlen, (unsigned)size, ub2);
- Newz(42, fb_ary->arcode, (unsigned)size, ub2);
- fb_ary->bufl = bufl;
- /* fb_ary->cb_bufl = bufl;*/
- return fb_ary;
-}
-
-void
-fb_ary_free(fb_ary_t *fb_ary)
-{
- Safefree(fb_ary->abuf);
- Safefree(fb_ary->aindp);
- Safefree(fb_ary->arlen);
- Safefree(fb_ary->arcode);
- Safefree(fb_ary->cb_abuf);
- Safefree(fb_ary);
-
-}
-
-
-/* ================================================================== */
-
-
-int
-dbd_db_login(SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd)
-{
- return dbd_db_login6(dbh, imp_dbh, dbname, uid, pwd, Nullsv);
-}
-
-
-/* from shared.xs */
-typedef struct {
- SV *sv; /* The actual SV - in shared space */
- /* we don't need the following two */
- /*recursive_lock_t lock; */
- /*perl_cond user_cond;*/ /* For user-level conditions */
-} shared_sv;
-
-
-
-int
-dbd_db_login6(SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd, SV *attr)
-{
- dTHR;
- dTHX;
- sword status;
- SV **svp;
- shared_sv * shared_dbh_ssv = NULL ;
- imp_dbh_t * shared_dbh = NULL ;
-#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
- SV ** shared_dbh_priv_svp ;
- SV * shared_dbh_priv_sv ;
- STRLEN shared_dbh_len = 0 ;
-#endif
- struct OCIExtProcContext *this_ctx;
- ub4 use_proc_connection = 0;
- SV **use_proc_connection_sv;
- D_imp_drh_from_dbh;
- ub2 new_charsetid = 0;
- ub2 new_ncharsetid = 0;
- /* check to see if DBD_verbose or ora_verbose is set*/
- if (DBD_ATTRIB_TRUE(attr,"dbd_verbose",11,svp))
- DBD_ATTRIB_GET_IV( attr, "dbd_verbose", 11, svp, dbd_verbose);
- if (DBD_ATTRIB_TRUE(attr,"ora_verbose",11,svp))
- DBD_ATTRIB_GET_IV( attr, "ora_verbose", 11, svp, dbd_verbose);
-
-
- /* dbi_imp_data code adapted from DBD::mysql */
- if (DBIc_has(imp_dbh, DBIcf_IMPSET)) {
- /* dbi_imp_data from take_imp_data */
- if (DBIc_has(imp_dbh, DBIcf_ACTIVE)) {
- if (DBIS->debug >= 2 || dbd_verbose >= 2)
- PerlIO_printf(DBILOGFP, "dbd_db_login6 skip connect\n");
- /* tell our parent we've adopted an active child */
- ++DBIc_ACTIVE_KIDS(DBIc_PARENT_COM(imp_dbh));
- return 1;
- }
- /* not ACTIVE so connect not skipped */
- if (DBIS->debug >= 2 || dbd_verbose >= 2 )
- PerlIO_printf(DBILOGFP,
- "dbd_db_login6 IMPSET but not ACTIVE so connect not skipped\n");
- }
- imp_dbh->envhp = imp_drh->envhp; /* will be NULL on first connect */
-
-#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
- shared_dbh_priv_svp = (DBD_ATTRIB_OK(attr)?hv_fetch((HV*)SvRV(attr), "ora_dbh_share", 13, 0):NULL) ;
- shared_dbh_priv_sv = shared_dbh_priv_svp?*shared_dbh_priv_svp:NULL ;
-
- if (shared_dbh_priv_sv && SvROK(shared_dbh_priv_sv))
- shared_dbh_priv_sv = SvRV(shared_dbh_priv_sv) ;
-
- if (shared_dbh_priv_sv) {
- MAGIC * mg ;
-
- SvLOCK (shared_dbh_priv_sv) ;
-
- /* some magic from shared.xs (no public api yet :-( */
- mg = mg_find(shared_dbh_priv_sv, PERL_MAGIC_shared_scalar) ;
-
- shared_dbh_ssv = (shared_sv * )(mg?mg -> mg_ptr:NULL) ; /*sharedsv_find(*shared_dbh_priv_sv) ;*/
-
- if (!shared_dbh_ssv)
- croak ("value of ora_dbh_share must be a scalar that is shared") ;
-
- shared_dbh = (imp_dbh_t *)SvPVX(shared_dbh_ssv -> sv) ;
- shared_dbh_len = SvCUR((shared_dbh_ssv -> sv)) ;
-
- if (shared_dbh_len > 0 && shared_dbh_len != sizeof (imp_dbh_t))
- croak ("Invalid value for ora_dbh_dup") ;
-
- if (shared_dbh_len == sizeof (imp_dbh_t)) {
- /* initialize from shared data */
- memcpy (((char *)imp_dbh) + DBH_DUP_OFF, ((char *)shared_dbh) + DBH_DUP_OFF, DBH_DUP_LEN) ;
- shared_dbh -> refcnt++ ;
- imp_dbh -> shared_dbh_priv_sv = shared_dbh_priv_sv ;
- imp_dbh -> shared_dbh = shared_dbh ;
- if (DBIS->debug >= 2 || dbd_verbose >= 2)
- PerlIO_printf(DBILOGFP, " dbd_db_login: use shared Oracle database handles.\n");
- } else {
- shared_dbh = NULL ;
- }
- }
-#endif
-
- /* Check if we should re-use a ProC connection and not connect ourselves. */
-
- DBD_ATTRIB_GET_IV(attr, "ora_use_proc_connection", 23,
- use_proc_connection_sv, use_proc_connection);
-
- imp_dbh->get_oci_handle = oci_db_handle;
-
- if (DBIS->debug >= 6 || dbd_verbose >= 7)
- dump_env_to_trace();
-
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_envhp", 9)) && SvOK(*svp)) {
- if (!SvTRUE(*svp)) {
- imp_dbh->envhp = NULL; /* force new environment */
- }
- else {
- IV tmp;
- if (!sv_isa(*svp, "ExtProc::OCIEnvHandle"))
- croak("ora_envhp value is not of type ExtProc::OCIEnvHandle");
- tmp = SvIV((SV*)SvRV(*svp));
- imp_dbh->envhp = (struct OCIEnv *)tmp;
- }
- }
-
- /* "extproc" dbname is special if "ora_context" attribute also given */
- if (strEQ(dbname,"extproc") && (svp=DBD_ATTRIB_GET_SVP(attr, "ora_context", 11))) {
- IV tmp;
- SV **svcsvp;
- SV **errsvp;
- if (!svp)
- croak("pointer to context SV is NULL");
- if (!sv_isa(*svp, "ExtProc::OCIExtProcContext"))
- croak("ora_context value is not of type ExtProc::OCIExtProcContext");
- tmp = SvIV((SV*)SvRV(*svp));
- this_ctx = (struct OCIExtProcContext *)tmp;
- if (this_ctx == NULL)
- croak("ora_context referenced ExtProc value is NULL");
- /* new */
- if ((svcsvp=DBD_ATTRIB_GET_SVP(attr, "ora_svchp", 9)) &&
- (errsvp=DBD_ATTRIB_GET_SVP(attr, "ora_errhp", 9))
- ) {
- if (!sv_isa(*svcsvp, "ExtProc::OCISvcHandle"))
- croak("ora_svchp value is not of type ExtProc::OCISvcHandle");
- tmp = SvIV((SV*)SvRV(*svcsvp));
- imp_dbh->svchp = (struct OCISvcCtx *)tmp;
- if (!sv_isa(*errsvp, "ExtProc::OCIErrHandle"))
- croak("ora_errhp value is not of type ExtProc::OCIErrHandle");
- tmp = SvIV((SV*)SvRV(*errsvp));
- imp_dbh->errhp = (struct OCIError *)tmp;
- }
- /* end new */
- else {
- status = OCIExtProcGetEnv(this_ctx, &imp_dbh->envhp,
- &imp_dbh->svchp, &imp_dbh->errhp);
- if (status != OCI_SUCCESS) {
- oci_error(dbh, (OCIError*)imp_dbh->envhp, status, "OCIExtProcGetEnv");
- return 0;
- }
- }
- is_extproc = 1;
- goto dbd_db_login6_out;
- }
-
- if (!imp_dbh->envhp || is_extproc) {
- SV **init_mode_sv;
- ub4 init_mode = OCI_OBJECT; /* needed for LOBs (8.0.4) */
- DBD_ATTRIB_GET_IV(attr, "ora_init_mode",13, init_mode_sv, init_mode);
-
-#if defined(USE_ITHREADS) || defined(MULTIPLICITY) || defined(USE_5005THREADS)
- init_mode |= OCI_THREADED;
-#endif
-
- if (use_proc_connection) {
- char *err_hint = Nullch;
-#ifdef SQL_SINGLE_RCTX
- /* Use existing SQLLIB connection. Do not call OCIInitialize(), */
- /* since presumably SQLLIB already did that. */
- status = SQLEnvGet(SQL_SINGLE_RCTX, &imp_dbh->envhp);
- imp_dbh->proc_handles = 1;
-#else
- status = OCI_ERROR;
- err_hint = "ProC connection reuse not available in this build of DBD::Oracle";
-#endif /* SQL_SINGLE_RCTX*/
- if (status != SQL_SUCCESS) {
- if (!err_hint)
- err_hint = "SQLEnvGet failed to load ProC environment";
- oci_error(dbh, NULL, status, err_hint);
- return 0;
- }
- }
- else { /* Normal connect. */
-
- size_t rsize = 0;
- imp_dbh->proc_handles = 0;
-
-#ifdef NEW_OCI_INIT /* XXX needs merging into use_proc_connection branch */
-
- /* Get CLIENT char and nchar charset id values */
- OCINlsEnvironmentVariableGet_log_stat( &charsetid, 0, OCI_NLS_CHARSET_ID, 0, &rsize ,status );
- if (status != OCI_SUCCESS) {
- oci_error(dbh, NULL, status,
- "OCINlsEnvironmentVariableGet(OCI_NLS_CHARSET_ID) Check NLS settings etc.");
- return 0;
- }
-
- OCINlsEnvironmentVariableGet_log_stat( &ncharsetid, 0, OCI_NLS_NCHARSET_ID, 0, &rsize ,status );
- if (status != OCI_SUCCESS) {
- oci_error(dbh, NULL, status,
- "OCINlsEnvironmentVariableGet(OCI_NLS_NCHARSET_ID) Check NLS settings etc.");
- return 0;
- }
-
- /*{
- After using OCIEnvNlsCreate() to create the environment handle,
- **the actual lengths and returned lengths of bind and define handles are
- always in number of bytes**. This applies to the following calls:
-
- * OCIBindByName() * OCIBindByPos() * OCIBindDynamic()
- * OCIDefineByPos() * OCIDefineDynamic()
-
- This function enables you to set charset and ncharset ids at
- environment creation time. [...]
-
- This function sets nonzero charset and ncharset as client side
- database and national character sets, replacing the ones specified
- by NLS_LANG and NLS_NCHAR. When charset and ncharset are 0, it
- behaves exactly the same as OCIEnvCreate(). Specifically, charset
- controls the encoding for metadata and data with implicit form
- attribute and ncharset controls the encoding for data with SQLCS_NCHAR
- form attribute.
- }*/
-
- OCIEnvNlsCreate_log_stat( &imp_dbh->envhp, init_mode, 0, NULL, NULL, NULL, 0, 0,
- charsetid, ncharsetid, status );
- if (status != OCI_SUCCESS) {
- oci_error(dbh, NULL, status,
- "OCIEnvNlsCreate. Check ORACLE_HOME (Linux) env var or PATH (Windows) and or NLS settings, permissions, etc.");
- return 0;
- }
-
- svp = DBD_ATTRIB_GET_SVP(attr, "ora_charset", 11);/*get the charset passed in by the user*/
- if (svp) {
- if (!SvPOK(*svp)) {
- croak("ora_charset is not a string");
- }
-
- new_charsetid = OCINlsCharSetNameToId(imp_dbh->envhp, (oratext*)SvPV_nolen(*svp));
-
- if (!new_charsetid) {
- croak("ora_charset value (%s) is not valid", SvPV_nolen(*svp));
- }
- }
-
- svp = DBD_ATTRIB_GET_SVP(attr, "ora_ncharset", 12); /*get the ncharset passed in by the user*/
-
- if (svp) {
- if (!SvPOK(*svp)) {
- croak("ora_ncharset is not a string");
- }
-
- new_ncharsetid = OCINlsCharSetNameToId(imp_dbh->envhp, (oratext*)SvPV_nolen(*svp));
- if (!new_ncharsetid) {
- croak("ora_ncharset value (%s) is not valid", SvPV_nolen(*svp));
- }
- }
-
- if (new_charsetid || new_ncharsetid) { /* reset the ENV with the new charset from above*/
- if (new_charsetid) charsetid = new_charsetid;
- if (new_ncharsetid) ncharsetid = new_ncharsetid;
- imp_dbh->envhp = NULL;
- OCIEnvNlsCreate_log_stat( &imp_dbh->envhp, init_mode, 0, NULL, NULL, NULL, 0, 0,
- charsetid, ncharsetid, status );
- if (status != OCI_SUCCESS) {
- oci_error(dbh, NULL, status,
- "OCIEnvNlsCreate. Check ORACLE_HOME (Linux) env var or PATH (Windows) and or NLS settings, permissions, etc");
- return 0;
- }
- }
-
- /* update the hard-coded csid constants for unicode charsets */
- utf8_csid = OCINlsCharSetNameToId(imp_dbh->envhp, (void*)"UTF8");
- al32utf8_csid = OCINlsCharSetNameToId(imp_dbh->envhp, (void*)"AL32UTF8");
- al16utf16_csid = OCINlsCharSetNameToId(imp_dbh->envhp, (void*)"AL16UTF16");
- we8mswin1252 = OCINlsCharSetNameToId(imp_dbh->envhp, (void*)"we8mswin1252");
-#else /* (the old init code) NEW_OCI_INIT */
- /* this is now depricated and will be removed as we no longer support <9.2 oracle*/
- /* XXX recent oracle docs recommend using OCIEnvCreate() instead of */
- /* OCIInitialize + OCIEnvInit, we'd need ifdef's for pre-OCIEnvNlsCreate */
- OCIInitialize_log_stat(init_mode, 0, 0,0,0, status);
-
-
- if (status != OCI_SUCCESS) {
- oci_error(dbh, NULL, status,
- "OCIInitialize. Check Check ORACLE_HOME (Linux) env var or PATH (Windows) and or NLS settings, permissions, etc");
- return 0;
- }
-
- OCIEnvInit_log_stat( &imp_dbh->envhp, OCI_DEFAULT, 0, 0, status);
- if (status != OCI_SUCCESS) {
- oci_error(dbh, (OCIError*)imp_dbh->envhp, status, "OCIEnvInit");
- return 0;
- }
-#endif /* NEW_OCI_INIT */
- }
- }
-
- if (shared_dbh_ssv) { /*is this a cached or shared handle from DBI*/
- if (!imp_dbh->envhp) { /*no hande so create a new one*/
- if (use_proc_connection) {
- char *err_hint = Nullch;
-#ifdef SQL_SINGLE_RCTX
- status = SQLEnvGet(SQL_SINGLE_RCTX, &imp_dbh->envhp);
- imp_dbh->proc_handles = 1;
-#else
- status = OCI_ERROR;
- err_hint = "ProC connection reuse not available in this build of DBD::Oracle";
-#endif /* SQL_SINGLE_RCTX*/
- if (status != SQL_SUCCESS) {
- if (!err_hint)
- err_hint = "SQLEnvGet failed to load ProC environment";
- oci_error(dbh, (OCIError*)imp_dbh->envhp, status, err_hint);
- return 0;
- }
- }
- else {
- OCIEnvInit_log_stat( &imp_dbh->envhp, OCI_DEFAULT, 0, 0, status);
- imp_dbh->proc_handles = 0;
- if (status != OCI_SUCCESS) {
- oci_error(dbh, (OCIError*)imp_dbh->envhp, status, "OCIEnvInit");
- return 0;
- }
- }
- }
- }
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->errhp, OCI_HTYPE_ERROR, status);
-
-#ifndef NEW_OCI_INIT /* have to get charsetid & ncharsetid the old way this code should go as well as it is for <9.2 oracle*/
-
- OCIAttrGet_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, &charsetid, (ub4)0 ,
- OCI_ATTR_ENV_CHARSET_ID, imp_dbh->errhp, status);
-
-
-
- if (status != OCI_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status, "OCIAttrGet OCI_ATTR_ENV_CHARSET_ID");
- return 0;
- }
- OCIAttrGet_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, &ncharsetid, (ub4)0 ,
- OCI_ATTR_ENV_NCHARSET_ID, imp_dbh->errhp, status);
- if (status != OCI_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status, "OCIAttrGet OCI_ATTR_ENV_NCHARSET_ID");
- return 0;
- }
-#endif
-
- /* At this point we have charsetid & ncharsetid
- * note that it is possible for charsetid and ncharestid to
- * be distinct if NLS_LANG and NLS_NCHAR are both used.
- * BTW: NLS_NCHAR is set as follows: NSL_LANG=AL32UTF8
- */
-
-
-
-
- if (DBIS->debug >= 3 || dbd_verbose >= 3) {
- oratext charsetname[OCI_NLS_MAXBUFSZ];
- oratext ncharsetname[OCI_NLS_MAXBUFSZ];
-
- OCINlsCharSetIdToName(imp_dbh->envhp,charsetname, sizeof(charsetname),charsetid );
- OCINlsCharSetIdToName(imp_dbh->envhp,ncharsetname, sizeof(ncharsetname),ncharsetid );
- PerlIO_printf(DBILOGFP," charset id=%d, name=%s, ncharset id=%d, name=%s"
- " (csid: utf8=%d al32utf8=%d)\n",
- charsetid,charsetname, ncharsetid,ncharsetname, utf8_csid, al32utf8_csid);
- }
-
-
- if (!shared_dbh) {
- if(use_proc_connection) {
-#ifdef SQL_SINGLE_RCTX
-
- imp_dbh->proc_handles = 1;
- status = SQLSvcCtxGet(SQL_SINGLE_RCTX, dbname, strlen(dbname),
- &imp_dbh->svchp);
- if (status != SQL_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status, "SQLSvcCtxGet");
- OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
- return 0;
- }
-
- OCIAttrGet_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, &imp_dbh->srvhp, NULL,
- OCI_ATTR_SERVER, imp_dbh->errhp, status);
- if (status != OCI_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status,
- "OCIAttrGet. Failed to get server context.");
- OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
- return 0;
- }
-
- OCIAttrGet_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, &imp_dbh->authp, NULL,
- OCI_ATTR_SESSION, imp_dbh->errhp, status);
- if (status != OCI_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status,
- "OCIAttrGet. Failed to get authentication context.");
- OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
- return 0;
- }
-#else /* SQL_SINGLE_RCTX */
- oci_error(dbh, (OCIError*)imp_dbh->envhp, OCI_ERROR,
- "ProC connection reuse not available in this build of DBD::Oracle");
-#endif /* SQL_SINGLE_RCTX*/
- }
- else { /* !use_proc_connection */
- imp_dbh->proc_handles = 0;
-
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
- OCIServerAttach_log_stat(imp_dbh, dbname,OCI_DEFAULT, status);
-
- if (status != OCI_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status, "OCIServerAttach");
- OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
- OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
- OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
- OCIHandleFree_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, status);
- return 0;
- }
- OCIAttrSet_log_stat( imp_dbh->svchp, OCI_HTYPE_SVCCTX, imp_dbh->srvhp,
- (ub4) 0, OCI_ATTR_SERVER, imp_dbh->errhp, status);
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->authp, OCI_HTYPE_SESSION, status);
-
- {
- ub4 cred_type = ora_parse_uid(imp_dbh, &uid, &pwd);
- SV **sess_mode_type_sv;
- ub4 sess_mode_type = OCI_DEFAULT;
- DBD_ATTRIB_GET_IV(attr, "ora_session_mode",16, sess_mode_type_sv, sess_mode_type);
- OCISessionBegin_log_stat( imp_dbh->svchp, imp_dbh->errhp, imp_dbh->authp,
- cred_type, sess_mode_type, status);
-
- }
- if (status == OCI_SUCCESS_WITH_INFO) {
- /* eg ORA-28011: the account will expire soon; change your password now */
- oci_error(dbh, imp_dbh->errhp, status, "OCISessionBegin");
- status = OCI_SUCCESS;
- }
- if (status != OCI_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status, "OCISessionBegin");
- OCIServerDetach_log_stat(imp_dbh->srvhp, imp_dbh->errhp, OCI_DEFAULT, status);
- OCIHandleFree_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,status);
- OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
- OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
- OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
- OCIHandleFree_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, status);
-
- return 0;
- }
-
- OCIAttrSet_log_stat(imp_dbh->svchp, (ub4) OCI_HTYPE_SVCCTX,
- imp_dbh->authp, (ub4) 0,
- (ub4) OCI_ATTR_SESSION, imp_dbh->errhp, status);
-
- } /* use_proc_connection */
- }
-
-dbd_db_login6_out:
- DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */
- DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing */
- imp_dbh->ph_type = 1; /* SQLT_CHR "(ORANET TYPE) character string" */
- imp_dbh->ph_csform = 0; /* meaning auto (see dbd_rebind_ph) */
-
- if (!imp_drh->envhp) /* cache first envhp info drh as future default */
- imp_drh->envhp = imp_dbh->envhp;
-
-#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
- if (shared_dbh_ssv && !shared_dbh) {
- /* much of this could be replaced with a single sv_setpvn() */
- (void)SvUPGRADE(shared_dbh_priv_sv, SVt_PV);
- SvGROW(shared_dbh_priv_sv, sizeof(imp_dbh_t) + 1) ;
- SvCUR (shared_dbh_priv_sv) = sizeof(imp_dbh_t) ;
- imp_dbh->refcnt = 1 ;
- imp_dbh->shared_dbh_priv_sv = shared_dbh_priv_sv ;
- memcpy(SvPVX(shared_dbh_priv_sv) + DBH_DUP_OFF, ((char *)imp_dbh) + DBH_DUP_OFF, DBH_DUP_LEN) ;
- SvSETMAGIC(shared_dbh_priv_sv);
- imp_dbh->shared_dbh = (imp_dbh_t *)SvPVX(shared_dbh_ssv->sv);
- }
-#endif
-
- return 1;
-}
-
-
-int
-dbd_db_commit(SV *dbh, imp_dbh_t *imp_dbh)
-{
- dTHX;
- sword status;
- OCITransCommit_log_stat(imp_dbh->svchp, imp_dbh->errhp, OCI_DEFAULT, status);
- if (status != OCI_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status, "OCITransCommit");
- return 0;
- }
- return 1;
-}
-
-
-
-
-int
-dbd_st_cancel(SV *sth, imp_sth_t *imp_sth)
-{
- dTHX;
- sword status;
- status = OCIBreak(imp_sth->svchp, imp_sth->errhp);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBreak");
- return 0;
- }
-
- /* if we are using a scrolling cursor we should get rid of the
- cursor by fetching row 0 */
- if (imp_sth->exe_mode==OCI_STMT_SCROLLABLE_READONLY){
- OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0,OCI_FETCH_NEXT,0, status);
- }
- return 1;
-}
-
-
-
-int
-dbd_db_rollback(SV *dbh, imp_dbh_t *imp_dbh)
-{
- dTHX;
- sword status;
- OCITransRollback_log_stat(imp_dbh->svchp, imp_dbh->errhp, OCI_DEFAULT, status);
- if (status != OCI_SUCCESS) {
- oci_error(dbh, imp_dbh->errhp, status, "OCITransRollback");
- return 0;
- }
- return 1;
-}
-
-
-int
-dbd_db_disconnect(SV *dbh, imp_dbh_t *imp_dbh)
-{
- dTHX;
- dTHR;
- int refcnt = 1 ;
-
-#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
- if (DBIc_IMPSET(imp_dbh) && imp_dbh->shared_dbh) {
- SvLOCK (imp_dbh->shared_dbh_priv_sv) ;
- refcnt = imp_dbh -> shared_dbh -> refcnt ;
- }
-#endif
-
- /* We assume that disconnect will always work */
- /* since most errors imply already disconnected. */
- DBIc_ACTIVE_off(imp_dbh);
-
- /* Oracle will commit on an orderly disconnect. */
- /* See DBI Driver.xst file for the DBI approach. */
-
- if (refcnt == 1 && !imp_dbh->proc_handles) {
- sword s_se, s_sd;
- OCISessionEnd_log_stat(imp_dbh->svchp, imp_dbh->errhp, imp_dbh->authp,
- OCI_DEFAULT, s_se);
- if (s_se) oci_error(dbh, imp_dbh->errhp, s_se, "OCISessionEnd");
- OCIServerDetach_log_stat(imp_dbh->srvhp, imp_dbh->errhp, OCI_DEFAULT, s_sd);
- if (s_sd) oci_error(dbh, imp_dbh->errhp, s_sd, "OCIServerDetach");
- if (s_se || s_sd)
- return 0;
- }
- /* We don't free imp_dbh since a reference still exists */
- /* The DESTROY method is the only one to 'free' memory. */
- /* Note that statement objects may still exists for this dbh! */
- return 1;
-}
-
-
-void
-dbd_db_destroy(SV *dbh, imp_dbh_t *imp_dbh)
-{
- dTHX ;
- int refcnt = 1 ;
- sword status;
-
-#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
- if (DBIc_IMPSET(imp_dbh) && imp_dbh->shared_dbh) {
- SvLOCK (imp_dbh->shared_dbh_priv_sv) ;
- refcnt = imp_dbh -> shared_dbh -> refcnt-- ;
- }
-#endif
-
- if (refcnt == 1) {
- if (DBIc_ACTIVE(imp_dbh))
- dbd_db_disconnect(dbh, imp_dbh);
- if (is_extproc)
- goto dbd_db_destroy_out;
- if (!imp_dbh->proc_handles)
- { sword status;
- OCIHandleFree_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,status);
- OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
- OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
- }
- }
- OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
-dbd_db_destroy_out:
- DBIc_IMPSET_off(imp_dbh);
-}
-
-
-int
-dbd_db_STORE_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv)
-{
- dTHX;
- STRLEN kl;
- char *key = SvPV(keysv,kl);
- int on = SvTRUE(valuesv);
- int cacheit = 1;
-
- if (kl==11 && (strEQ(key, "ora_verbose") || strEQ(key, "dbd_verbose"))) {
- dbd_verbose = SvIV (valuesv);
- }
- else if (kl==10 && strEQ(key, "AutoCommit")) {
- DBIc_set(imp_dbh,DBIcf_AutoCommit, on);
- }
- else if (kl==12 && strEQ(key, "RowCacheSize")) {
- imp_dbh->RowCacheSize = SvIV(valuesv);
- }
- else if (kl==22 && strEQ(key, "ora_max_nested_cursors")) {
- imp_dbh->max_nested_cursors = SvIV(valuesv);
- }
- else if (kl==20 && strEQ(key, "ora_array_chunk_size")) {
- imp_dbh->array_chunk_size = SvIV(valuesv);
- }
- else if (kl==11 && strEQ(key, "ora_ph_type")) {
- if (SvIV(valuesv)!=1 && SvIV(valuesv)!=5 && SvIV(valuesv)!=96 && SvIV(valuesv)!=97)
- warn("ora_ph_type must be 1 (VARCHAR2), 5 (STRING), 96 (CHAR), or 97 (CHARZ)");
- else
- imp_dbh->ph_type = SvIV(valuesv);
- }
-
- else if (kl==13 && strEQ(key, "ora_ph_csform")) {
- if (SvIV(valuesv)!=SQLCS_IMPLICIT && SvIV(valuesv)!=SQLCS_NCHAR)
- warn("ora_ph_csform must be 1 (SQLCS_IMPLICIT) or 2 (SQLCS_NCHAR)");
- else
- imp_dbh->ph_csform = (ub1)SvIV(valuesv);
- }
- else
- {
- return FALSE;
- }
-
- if (cacheit) /* cache value for later DBI 'quick' fetch? */
- hv_store((HV*)SvRV(dbh), key, kl, newSVsv(valuesv), 0);
- return TRUE;
-}
-
-
-SV *
-dbd_db_FETCH_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv)
-{
- dTHX;
- STRLEN kl;
- char *key = SvPV(keysv,kl);
- SV *retsv = Nullsv;
- /* Default to caching results for DBI dispatch quick_FETCH */
- int cacheit = FALSE;
-
- /* AutoCommit FETCH via DBI */
-
- if (kl==11 && (strEQ(key, "ora_verbose") || strEQ(key, "dbd_verbose"))) {
- retsv = newSViv (dbd_verbose);
- }
- else if (kl==10 && strEQ(key, "AutoCommit")) {
- retsv = boolSV(DBIc_has(imp_dbh,DBIcf_AutoCommit));
- }
- else if (kl==12 && strEQ(key, "RowCacheSize")) {
- retsv = newSViv(imp_dbh->RowCacheSize);
- }
- else if (kl==22 && strEQ(key, "ora_max_nested_cursors")) {
- retsv = newSViv(imp_dbh->max_nested_cursors);
- }
- else if (kl==11 && strEQ(key, "ora_ph_type")) {
- retsv = newSViv(imp_dbh->ph_type);
- }
- else if (kl==13 && strEQ(key, "ora_ph_csform")) {
- retsv = newSViv(imp_dbh->ph_csform);
- }
- else if (kl==22 && strEQ(key, "ora_parse_error_offset")) {
- retsv = newSViv(imp_dbh->parse_error_offset);
- }
- if (!retsv)
- return Nullsv;
- if (cacheit) { /* cache for next time (via DBI quick_FETCH) */
- SV **svp = hv_fetch((HV*)SvRV(dbh), key, kl, 1);
- sv_free(*svp);
- *svp = retsv;
- (void)SvREFCNT_inc(retsv); /* so sv_2mortal won't free it */
- }
-
- if (retsv == &sv_yes || retsv == &sv_no)
- return retsv; /* no need to mortalize yes or no */
-
- return sv_2mortal(retsv);
-}
-
-
-
-/* ================================================================== */
-
-#define MAX_OCISTRING_LEN 32766
-
-SV *
-createxmlfromstring(SV *sth, imp_sth_t *imp_sth, SV *source){
-
- dTHX;
- dTHR;
- OCIXMLType *xml = NULL;
- STRLEN len;
- sword status;
- ub1 src_type;
- dvoid* src_ptr = NULL;
- D_imp_dbh_from_sth;
- SV* sv_dest;
- dvoid *bufp;
- ub1 csform;
- ub2 csid;
- csid = 0;
- csform = SQLCS_IMPLICIT;
-
-
- len = SvLEN(source);
- bufp = SvPV(source, len);
-
- if (DBIS->debug >=3 || dbd_verbose >= 3)
- PerlIO_printf(DBILOGFP, " creating xml from string that is %d long\n",len);
-
- if(len > MAX_OCISTRING_LEN) {
- src_type = OCI_XMLTYPE_CREATE_CLOB;
-
- if (DBIS->debug >=5 || dbd_verbose >=5)
- PerlIO_printf(DBILOGFP, " use a temp lob locator for large xml \n");
-
- OCIDescriptorAlloc_ok(imp_dbh->envhp, &src_ptr, OCI_DTYPE_LOB);
-
- OCILobCreateTemporary_log_stat(imp_dbh->svchp, imp_sth->errhp,
- (OCILobLocator *) src_ptr, (ub2) OCI_DEFAULT,
- (ub1) OCI_DEFAULT, OCI_TEMP_CLOB, FALSE, OCI_DURATION_SESSION, status);
-
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCILobCreateTemporary");
- }
- csid = (SvUTF8(source) && !CS_IS_UTF8(csid)) ? utf8_csid : CSFORM_IMPLIED_CSID(csform);
-
- OCILobWriteAppend_log_stat(imp_dbh->svchp, imp_dbh->errhp, src_ptr,
- &len, bufp, (ub4)len, OCI_ONE_PIECE,
- NULL, NULL,
- csid, csform, status);
-
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCILobWriteAppend");
- }
-
- } else {
- src_type = OCI_XMLTYPE_CREATE_OCISTRING;
- if (DBIS->debug >=5 || dbd_verbose >=5 )
- PerlIO_printf(DBILOGFP, " use a OCIStringAssignText for small xml \n");
-
-
- OCIStringAssignText(imp_dbh->envhp,
- imp_dbh->errhp,
- bufp,
- (ub2) (ub4)len,
- (OCIString **) &src_ptr);
- }
-
-
-
- status = OCIXMLTypeCreateFromSrc(imp_dbh->svchp,
- imp_dbh->errhp,
- (OCIDuration)OCI_DURATION_CALLOUT,
- (ub1)src_type,
- (dvoid *)src_ptr,
- (sb4)OCI_IND_NOTNULL,
- &xml);
-
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIXMLTypeCreateFromSrc");
- }
-
- /* free temporary resources */
- if ( src_type == OCI_XMLTYPE_CREATE_CLOB ) {
- OCILobFreeTemporary(imp_dbh->svchp, imp_dbh->errhp,
- (OCILobLocator*) src_ptr);
-
- OCIDescriptorFree((dvoid *) src_ptr, (ub4) OCI_DTYPE_LOB);
- }
-
-
- sv_dest = newSViv(0);
- sv_setref_pv(sv_dest, "OCIXMLTypePtr", xml);
- return sv_dest;
-
-}
-
-
-void
-dbd_preparse(imp_sth_t *imp_sth, char *statement)
-{
- dTHX;
- D_imp_dbh_from_sth;
- bool in_literal = '\0';
- char in_comment = '\0';
- char *src, *start, *dest;
- phs_t phs_tpl;
- SV *phs_sv;
- int idx=0;
- char *style="", *laststyle=Nullch;
- STRLEN namelen;
- phs_t *phs;
- /* allocate room for copy of statement with spare capacity */
- /* for editing '?' or ':1' into ':p1' so we can use obndrv. */
- /* XXX should use SV and append to it */
- imp_sth->statement = (char*)safemalloc(strlen(statement) * 10);
-
- /* initialise phs ready to be cloned per placeholder */
- memset(&phs_tpl, 0, sizeof(phs_tpl));
- phs_tpl.imp_sth = imp_sth;
- phs_tpl.ftype = imp_dbh->ph_type;
- phs_tpl.csform = imp_dbh->ph_csform;
- phs_tpl.sv = &sv_undef;
-
- src = statement;
- dest = imp_sth->statement;
- while(*src) {
-
- if (in_comment) {
- /* 981028-jdl on mocha. Adding all code which deals with */
- /* in_comment variable (its declaration plus 2 code blocks). */
- /* Text appearing within comments should be scanned for neither */
- /* placeholders nor for single quotes (which toggle the in_literal */
- /* boolean). Comments like "3:00" demonstrate the former problem, */
- /* and contractions like "don't" demonstrate the latter problem. */
- /* The comment style is stored in in_comment; each style is */
- /* terminated in a different way. */
- if (in_comment == '-' && *src == '\n') {
- in_comment = '\0';
- }
- else if (in_comment == '/' && *src == '*' && *(src+1) == '/') {
- *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */
- in_comment = '\0';
- }
- *dest++ = *src++;
- continue;
- }
-
- if (in_literal) {
- if (*src == in_literal)
- in_literal = '\0';
- *dest++ = *src++;
- continue;
- }
-
- /* Look for comments: '-- oracle-style' or C-style */
- if ((*src == '-' && *(src+1) == '-') ||
- (*src == '/' && *(src+1) == '*'))
- {
- in_comment = *src;
- /* We know *src & the next char are to be copied, so do */
- /* it. In the case of C-style comments, it happens to */
- /* help us avoid slash-asterisk-slash oddities. */
- *dest++ = *src++;
- *dest++ = *src++;
- continue;
- }
-
- if (*src != ':' && *src != '?') {
-
- if (*src == '\'' || *src == '"')
- in_literal = *src;
-
- *dest++ = *src++;
- continue;
- }
-
- /* only here for : or ? outside of a comment or literal */
-
- start = dest; /* save name inc colon */
- *dest++ = *src++;
- if (*start == '?') { /* X/Open standard */
- sprintf(start,":p%d", ++idx); /* '?' -> ':p1' (etc) */
- dest = start+strlen(start);
- style = "?";
-
- } else if (isDIGIT(*src)) { /* ':1' */
- idx = atoi(src);
- *dest++ = 'p'; /* ':1'->':p1' */
- if (idx <= 0)
- croak("Placeholder :%d invalid, placeholders must be >= 1", idx);
- while(isDIGIT(*src))
- *dest++ = *src++;
- style = ":1";
-
- } else if (isALNUM(*src)) { /* ':foo' */
- while(isALNUM(*src)) /* includes '_' */
- *dest++ = toLOWER(*src), src++;
- style = ":foo";
- } else { /* perhaps ':=' PL/SQL construct */
- /* if (src == ':') *dest++ = *src++; XXX? move past '::'? */
- continue;
- }
- *dest = '\0'; /* handy for debugging */
- namelen = (dest-start);
- if (laststyle && style != laststyle)
- croak("Can't mix placeholder styles (%s/%s)",style,laststyle);
- laststyle = style;
- if (imp_sth->all_params_hv == NULL)
- imp_sth->all_params_hv = newHV();
- phs_sv = newSVpv((char*)&phs_tpl, sizeof(phs_tpl)+namelen+1);
- phs = (phs_t*)(void*)SvPVX(phs_sv);
- hv_store(imp_sth->all_params_hv, start, namelen, phs_sv, 0);
- phs->idx = idx-1; /* Will be 0 for :1, -1 for :foo. */
- strcpy(phs->name, start);
-
- }
- *dest = '\0';
- if (imp_sth->all_params_hv) {
- DBIc_NUM_PARAMS(imp_sth) = (int)HvKEYS(imp_sth->all_params_hv);
- if (DBIS->debug >= 2 || dbd_verbose >=2 )
- PerlIO_printf(DBILOGFP, " dbd_preparse scanned %d distinct placeholders\n",
- (int)DBIc_NUM_PARAMS(imp_sth));
- }
-}
-
-
-static int
-ora_sql_type(imp_sth_t *imp_sth, char *name, int sql_type)
-{
- /* XXX should detect DBI reserved standard type range here */
-
- switch (sql_type) {
- case SQL_NUMERIC:
- case SQL_DECIMAL:
- case SQL_INTEGER:
- case SQL_BIGINT:
- case SQL_TINYINT:
- case SQL_SMALLINT:
- case SQL_FLOAT:
- case SQL_REAL:
- case SQL_DOUBLE:
- case SQL_VARCHAR:
- return 1; /* Oracle VARCHAR2 */
-
- case SQL_CHAR:
- return 96; /* Oracle CHAR */
-
- case SQL_BINARY:
- case SQL_VARBINARY:
- return 23; /* Oracle RAW */
-
- case SQL_LONGVARBINARY:
- return 24; /* Oracle LONG RAW */
-
- case SQL_LONGVARCHAR:
- return 8; /* Oracle LONG */
-
- case SQL_UDT:
- return 108; /* Oracle NTY */
-
- case SQL_CLOB:
- return 112; /* Oracle CLOB */
-
- case SQL_BLOB:
- return 113; /* Oracle BLOB */
-
- case SQL_DATE:
- case SQL_TIME:
- case SQL_TIMESTAMP:
- default:
- if (imp_sth && DBIc_WARN(imp_sth) && name)
- warn("SQL type %d for '%s' is not fully supported, bound as SQL_VARCHAR instead",
- sql_type, name);
- return ora_sql_type(imp_sth, name, SQL_VARCHAR);
- }
-}
-
-
-
-/* ############### Array bind ######################################### */
-/* Added by Alexander V Alekseev. [email protected] */
-/*
- *
- * Realloc temporary array buffer to match required number of entries
- * and buffer size.
- *
- * Return value: croaks on error. false (=0 ) on success.
- * */
-int ora_realloc_phs_array(phs_t *phs,int newentries, int newbufsize){
-
- dTHX;
- dTHR;
- int i; /* Loop variable */
- unsigned short *newal;
-
- if( newbufsize < 0 ){
- newbufsize=0;
- }
- if( newentries > phs->array_numallocated ){
- OCIInd *newind=(OCIInd *)realloc(phs->array_indicators,newentries*sizeof(OCIInd) );
- if( newind ){
- phs->array_indicators=newind;
- /* Init all indicators to NULL values. */
- for( i=phs->array_numallocated; i < newentries ; i++ ){
- newind[i]=1;
- }
- }else{
- croak("Not enough memory to allocate %d OCI indicators.",newentries);
- }
- newal=(unsigned short *)realloc(phs->array_lengths, newentries*sizeof(unsigned short));
- if( newal ){
- phs->array_lengths=newal;
- /* Init all new lengths to zero */
- if( newentries > phs->array_numallocated ){
- memset(
- &(newal[phs->array_numallocated]),
- 0,
- (newentries-(phs->array_numallocated))*sizeof(unsigned short)
- );
- }
- }else{
- croak("Not enough memory to allocate %d entries in OCI array of lengths.",newentries);
- }
- phs->array_numallocated=newentries;
- }
- if( phs->array_buflen < newbufsize ){
- char * newbuf=(char *)realloc( phs->array_buf, (unsigned) newbufsize );
- if( newbuf ){
- phs->array_buf=newbuf;
- }else{
- croak("Not enough memory to allocate OCI array buffer of %d bytes.",newbufsize);
- }
- phs->array_buflen=newbufsize;
- }
- return 0;
-}
-/* bind of SYS.DBMS_SQL.VARCHAR2_TABLE */
-int
-dbd_rebind_ph_varchar2_table(SV *sth, imp_sth_t *imp_sth, phs_t *phs)
-{
- dTHX;
- /*D_imp_dbh_from_sth ;*/
- sword status;
- int trace_level = DBIS->debug;
- AV *arr;
- ub1 csform;
- ub2 csid;
- int flag_data_is_utf8=0;
- int need_allocate_rows;
- int buflen;
- if( ( ! SvROK(phs->sv) ) || (SvTYPE(SvRV(phs->sv))!=SVt_PVAV) ) { /* Allow only array binds */
- croak("dbd_rebind_ph_varchar2_table(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
- neatsvpv(phs->sv,0), phs->name);
- }
- arr=(AV*)(SvRV(phs->sv));
-
- if (trace_level >= 2 || dbd_verbose >= 2){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): array_numstruct=%d\n",
- phs->array_numstruct);
- }
- /* If no number of entries to bind specified,
- * set phs->array_numstruct to the scalar(@array) bound.
- */
- if( phs->array_numstruct <= 0 ){
- /* av_len() returns last array index, or -1 is array is empty */
- int numarrayentries=av_len( arr );
- if( numarrayentries >= 0 ){
- phs->array_numstruct = numarrayentries+1;
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): array_numstruct=%d (calculated) \n",
- phs->array_numstruct);
- }
- }
- }
- /* Fix charset */
- csform = phs->csform;
- if (trace_level >= 2 || dbd_verbose >= 2){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): original csform=%d\n",
- (int)csform);
- }
- /* Calculate each bound structure maxlen.
- * If maxlen<=0, let maxlen=MAX ( length($$_) each @array );
- *
- * Charset calculation is done inside this loop either.
- */
- {
- unsigned int maxlen=0;
- int i;
-
- for(i=0;i<av_len(arr)+1;i++){
- SV *item;
- item=*(av_fetch(arr,i,0));
- if( item ){
- if( phs->maxlen <=0 ){ /* Analyze maxlength only if not forced */
- STRLEN length=0;
- if (!SvPOK(item)) { /* normalizations for special cases */
- if (SvOK(item)) { /* ie a number, convert to string ASAP */
- if (!(SvROK(item) && phs->is_inout)){
- sv_2pv(item, &length);
- }
- } else { /* ensure we're at least an SVt_PV (so SvPVX etc work) */
- if(SvUPGRADE(item, SVt_PV)){}
- }
- }
- if( length == 0 ){
- length=SvCUR(item);
- }
- if( length+1 > maxlen ){
- maxlen=length+1;
- }
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): length(array[%d])=%d\n",
- i,(int)length);
- }
- }
- if(SvUTF8(item) ){
- flag_data_is_utf8=1;
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): is_utf8(array[%d])=true\n", i);
- }
- if (csform != SQLCS_NCHAR) {
- /* try to default csform to avoid translation through non-unicode */
- if (CSFORM_IMPLIES_UTF8(SQLCS_NCHAR)) /* prefer NCHAR */
- csform = SQLCS_NCHAR;
- else if (CSFORM_IMPLIES_UTF8(SQLCS_IMPLICIT))
- csform = SQLCS_IMPLICIT;
- /* else leave csform == 0 */
- if (trace_level || dbd_verbose >= 1 )
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): rebinding %s with UTF8 value %s", phs->name,
- (csform == SQLCS_NCHAR) ? "so setting csform=SQLCS_IMPLICIT" :
- (csform == SQLCS_IMPLICIT) ? "so setting csform=SQLCS_NCHAR" :
- "but neither CHAR nor NCHAR are unicode\n");
- }
- }else{
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): is_utf8(array[%d])=false\n", i);
- }
- }
- }
- }
- if( phs->maxlen <=0 ){
- phs->maxlen=maxlen;
- if (trace_level >= 2 || dbd_verbose >= 2){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): phs->maxlen calculated =%ld\n",
- (long)maxlen);
- }
- } else{
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): phs->maxlen forsed =%ld\n",
- (long)maxlen);
- }
- }
- }
- /* Do not allow string bind longer than max VARCHAR2=4000+1 */
- if( phs->maxlen > 4001 ){
- phs->maxlen=4001;
- }
-
- if( phs->array_numstruct == 0 ){
- /* Oracle doesn't allow NULL buffers even for empty tables. Don't know why. */
- phs->array_numstruct=1;
- }
- if( phs->ora_maxarray_numentries== 0 ){
- /* Zero means "use current array length". */
- phs->ora_maxarray_numentries=phs->array_numstruct;
- }
-
- need_allocate_rows=phs->ora_maxarray_numentries;
-
- if( 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 */
- /* Upgrade array buffer to new length */
- if( ora_realloc_phs_array(phs,need_allocate_rows,buflen) ){
- croak("Unable to bind %s - %d structures by %d bytes requires too much memory.",
- phs->name, need_allocate_rows, buflen );
- }else{
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): ora_realloc_phs_array(,need_allocate_rows=%d,buflen=%d) succeeded.\n",
- need_allocate_rows,buflen);
- }
- }
- /* If maximum allowed bind numentries is less than allowed,
- * do not bind full array
- */
- if( phs->array_numstruct > phs->ora_maxarray_numentries ){
- phs->array_numstruct = phs->ora_maxarray_numentries;
- }
- /* Fill array buffer with string 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 ){
- STRLEN itemlen;
- char *str=SvPV(item, itemlen);
- if( str && (itemlen>0) ){
- /* Limit string length to maxlen. FIXME: This may corrupt UTF-8 data. */
- if( itemlen > (unsigned int) phs->maxlen-1 ){
- itemlen=phs->maxlen-1;
- }
- memcpy( phs->array_buf+phs->maxlen*i,
- str,
- itemlen);
- /* Set last byte to zero */
- phs->array_buf[ phs->maxlen*i + itemlen ]=0;
- phs->array_indicators[i]=0;
- phs->array_lengths[i]=itemlen+1; /* Zero byte */
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): "
- "Copying length=%d array[%d]='%s'.\n",
- itemlen,i,str);
- }
- }else{
- /* Mark NULL */
- phs->array_indicators[i]=1;
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): "
- "Copying length=%d array[%d]=NULL (length==0 or ! str) .\n",
- itemlen,i);
- }
- }
- }else{
- /* Mark NULL */
- phs->array_indicators[i]=1;
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): "
- "Copying length=? array[%d]=NULL av_fetch failed.\n", i);
- }
- }
- }
- }
- /* Do actual bind */
- OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
- (text*)phs->name, (sb4)strlen(phs->name),
- phs->array_buf,
- phs->maxlen,
- (ub2)SQLT_STR, phs->array_indicators,
- phs->array_lengths, /* ub2 *alen_ptr not needed with OCIBindDynamic */
- (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;
- }
- OCIBindArrayOfStruct_log_stat(phs->bndhp, imp_sth->errhp,
- (unsigned)phs->maxlen, /* Skip parameter for the next data value */
- sizeof (OCIInd), /* Skip parameter for the next indicator value */
- 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;
- }
- /* Fixup charset */
- if (csform) {
- /* set OCI_ATTR_CHARSET_FORM before we get the default OCI_ATTR_CHARSET_ID */
- OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
- &csform, (ub4) 0, (ub4) OCI_ATTR_CHARSET_FORM, imp_sth->errhp, status);
- if ( status != OCI_SUCCESS ) {
- oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_FORM)"));
- return 0;
- }
- }
-
- if (!phs->csid_orig) { /* get the default csid Oracle would use */
- OCIAttrGet_log_stat(phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, (ub4)0 ,
- OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
- }
-
- /* if app has specified a csid then use that, else use default */
- csid = (phs->csid) ? phs->csid : phs->csid_orig;
-
- /* if data is utf8 but charset isn't then switch to utf8 csid */
- if ( flag_data_is_utf8 && !CS_IS_UTF8(csid))
- csid = utf8_csid; /* not al32utf8_csid here on purpose */
-
- if (trace_level >= 3 || dbd_verbose >= 3 )
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): bind %s <== %s "
- "(%s, %s, csid %d->%d->%d, ftype %d, csform %d->%d, maxlen %lu, maxdata_size %lu)\n",
- phs->name, neatsvpv(phs->sv,0),
- (phs->is_inout) ? "inout" : "in",
- flag_data_is_utf8 ? "is-utf8" : "not-utf8",
- phs->csid_orig, phs->csid, csid,
- phs->ftype, phs->csform, csform,
- (unsigned long)phs->maxlen, (unsigned long)phs->maxdata_size);
-
-
- if (csid) {
- OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
- &csid, (ub4) 0, (ub4) OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
- if ( status != OCI_SUCCESS ) {
- oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_ID)"));
- return 0;
- }
- }
-
- if (phs->maxdata_size) {
- OCIAttrSet_log_stat(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;
- }
- }
-
- return 2;
-}
-
-
-/* Copy array data from array buffer into perl array */
-/* Returns false on error, true on success */
-int dbd_phs_ora_varchar2_table_fixup_after_execute(phs_t *phs){
- dTHX;
-
- int trace_level = DBIS->debug;
- AV *arr;
-
- if( ( ! SvROK(phs->sv) ) || (SvTYPE(SvRV(phs->sv))!=SVt_PVAV) ) { /* Allow only array binds */
- croak("dbd_phs_ora_varchar2_table_fixup_after_execute(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
- neatsvpv(phs->sv,0), phs->name);
- }
- if (trace_level >= 1 || dbd_verbose >= 1){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_varchar2_table_fixup_after_execute(): Called for '%s' : array_numstruct=%d, maxlen=%ld \n",
- phs->name,
- phs->array_numstruct,
- (long)phs->maxlen
- );
- }
- arr=(AV*)(SvRV(phs->sv));
-
- /* If no data is returned, just clear the array. */
- if( phs->array_numstruct <= 0 ){
- av_clear(arr);
- return 1;
- }
- /* Delete extra data from array, if any */
- while( av_len(arr) >= phs->array_numstruct ){
- av_delete(arr,av_len(arr),G_DISCARD);
- };
- /* Extend array, if needed. */
- if( av_len(arr)+1 < phs->array_numstruct ){
- av_extend(arr,phs->array_numstruct-1);
- }
- /* Fill array with buffer data */
- {
- /* phs_t */
- int i; /* Not to require C99 mode */
- for(i=0;i<phs->array_numstruct;i++){
- SV *item,**pitem;
- pitem=av_fetch(arr,i,0);
- if( pitem ){
- item=*pitem;
- }else{
- item=NULL;
- }
- if( phs->array_indicators[i] == -1 ){
- /* NULL */
- if( item ){
- SvSetMagicSV(item,&PL_sv_undef);
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_varchar2_table_fixup_after_execute(): arr[%d] = undef; SvSetMagicSV(item,&PL_sv_undef);\n",
- i
- );
- }
- }else{
- av_store(arr,i,&PL_sv_undef);
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_varchar2_table_fixup_after_execute(): arr[%d] = undef; av_store(arr,i,&PL_sv_undef);\n",
- i
- );
- }
- }
- }else{
- if( (phs->array_indicators[i] == -2) || (phs->array_indicators[i] > 0) ){
- /* Truncation occurred */
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_varchar2_table_fixup_after_execute(): Placeholder '%s': data truncated at %d row.\n",
- phs->name,i);
- }
- }else{
- /* All OK. Just copy value.*/
- }
- if( item ){
- sv_setpvn_mg(item,phs->array_buf+phs->maxlen*i,phs->array_lengths[i]);
- SvPOK_only_UTF8(item);
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_varchar2_table_fixup_after_execute(): arr[%d] = '%s'; "
- "sv_setpvn_mg(item,phs->array_buf+phs->maxlen*i,phs->array_lengths[i]); \n",
- i, phs->array_buf+phs->maxlen*i
- );
- }
- }else{
- av_store(arr,i,newSVpvn(phs->array_buf+phs->maxlen*i,phs->array_lengths[i]));
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_varchar2_table_fixup_after_execute(): arr[%d] = '%s'; "
- "av_store(arr,i,newSVpvn(phs->array_buf+phs->maxlen*i,phs->array_lengths[i])); \n",
- i, phs->array_buf+phs->maxlen*i
- );
- }
- }
- }
- }
- }
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_varchar2_table_fixup_after_execute(): scalar(@arr)=%ld.\n",
- (long)av_len(arr)+1);
- }
- return 1;
-}
-/* bind of SYS.DBMS_SQL.NUMBER_TABLE */
-int dbd_rebind_ph_number_table(SV *sth, imp_sth_t *imp_sth, phs_t *phs) {
- dTHX;
- /*D_imp_dbh_from_sth ;*/
- sword status;
- int trace_level = DBIS->debug;
- AV *arr;
- int need_allocate_rows;
- int buflen;
- /*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);
- }
- /* Default bind type for number table is double. */
- if( ! phs->ora_internal_type ){
- 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);
- }
- }
- arr=(AV*)(SvRV(phs->sv));
-
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): array_numstruct=%d\n",
- phs->array_numstruct);
- }
- /* If no number of entries to bind specified,
- * set phs->array_numstruct to the scalar(@array) bound.
- */
- if( phs->array_numstruct <= 0 ){
-/* av_len() returns last array index, or -1 is array is empty */
- int numarrayentries=av_len( arr );
- if( numarrayentries >= 0 ){
- phs->array_numstruct = numarrayentries+1;
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): array_numstruct=%d (calculated) \n",
- phs->array_numstruct);
- }
- }
- }
- /* Calculate each bound structure maxlen.
- * maxlen(int) = sizeof(int);
- * maxlen(double) = sizeof(double);
- */
- switch( phs->ora_internal_type ){
- case SQLT_INT:
- phs->maxlen=sizeof(int);
- break;
- case SQLT_FLT:
- default:
- phs->maxlen=sizeof(double);
- }
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): phs->maxlen calculated =%ld\n",
- (long)phs->maxlen);
- }
-
- if( phs->array_numstruct == 0 ){
- /* Oracle doesn't allow NULL buffers even for empty tables. Don't know why. */
- phs->array_numstruct=1;
- }
- if( phs->ora_maxarray_numentries== 0 ){
- /* Zero means "use current array length". */
- phs->ora_maxarray_numentries=phs->array_numstruct;
-
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): ora_maxarray_numentries assumed=phs->array_numstruct=%d\n",
- phs->array_numstruct);
- }
- }else{
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): ora_maxarray_numentries=%d\n",
- phs->ora_maxarray_numentries);
- }
- }
-
- need_allocate_rows=phs->ora_maxarray_numentries;
-
- if( 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 */
-
- /* Upgrade array buffer to new length */
- if( ora_realloc_phs_array(phs,need_allocate_rows,buflen) ){
- croak("Unable to bind %s - %d structures by %d bytes requires too much memory.",
- phs->name, need_allocate_rows, buflen );
- }else{
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): ora_realloc_phs_array(,need_allocate_rows=%d,buflen=%d) succeeded.\n",
- need_allocate_rows,buflen);
- }
- }
- /* If maximum allowed bind numentries is less than allowed,
- * do not bind full array
- */
- if( phs->array_numstruct > phs->ora_maxarray_numentries ){
- phs->array_numstruct = phs->ora_maxarray_numentries;
- }
- /* 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(DBILOGFP, "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(DBILOGFP, "dbd_rebind_ph_number_table(): "
- "let (double) array[%d]=%lf - 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 >= 2 ){
- STRLEN l;
- char *p=SvPV(item,l);
-
- PerlIO_printf(DBILOGFP, "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(DBILOGFP, "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(DBILOGFP, "dbd_rebind_ph_number_table(): "
- "(double) array[%d]=%lf%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(DBILOGFP, "dbd_rebind_ph_number_table(): "
- "Copying length=? array[%d]=NULL av_fetch failed.\n", i);
- }
- }
- }
- }
- /* Do actual bind */
- OCIBindByName_log_stat(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
- );
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindByName");
- return 0;
- }
- OCIBindArrayOfStruct_log_stat(phs->bndhp, imp_sth->errhp,
- (unsigned)phs->maxlen, /* Skip parameter for the next data value */
- sizeof (OCIInd), /* Skip parameter for the next indicator value */
- 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;
- }
- if (phs->maxdata_size) {
- OCIAttrSet_log_stat(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;
- }
- }
-
- return 2;
-}
-
-
-/* Copy array data from array buffer into perl array */
-/* Returns false on error, true on success */
-int dbd_phs_ora_number_table_fixup_after_execute(phs_t *phs){
- dTHX;
-
- int trace_level = DBIS->debug;
- AV *arr;
-
- if( ( ! SvROK(phs->sv) ) || (SvTYPE(SvRV(phs->sv))!=SVt_PVAV) ) { /* Allow only array binds */
- croak("dbd_phs_ora_number_table_fixup_after_execute(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
- neatsvpv(phs->sv,0), phs->name);
- }
- if (trace_level >= 1 || dbd_verbose >= 1 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): Called for '%s' : array_numstruct=%d, maxlen=%ld \n",
- phs->name,
- phs->array_numstruct,
- (long)phs->maxlen
- );
- }
- /* At this point, ora_internal_type can't be default. It must be set at bind time. */
- 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, SQLT_INT datatypes.",
- phs->ora_internal_type);
- }
- arr=(AV*)(SvRV(phs->sv));
-
- /* If no data is returned, just clear the array. */
- if( phs->array_numstruct <= 0 ){
- av_clear(arr);
- return 1;
- }
- /* Delete extra data from array, if any */
- while( av_len(arr) >= phs->array_numstruct ){
- av_delete(arr,av_len(arr),G_DISCARD);
- };
- /* Extend array, if needed. */
- if( av_len(arr)+1 < phs->array_numstruct ){
- av_extend(arr,phs->array_numstruct-1);
- }
- /* Fill array with buffer data */
- {
- /* phs_t */
- int i; /* Not to require C99 mode */
- for(i=0;i<phs->array_numstruct;i++){
- SV *item,**pitem;
- pitem=av_fetch(arr,i,0);
- if( pitem ){
- item=*pitem;
- }else{
- item=NULL;
- }
- if( phs->array_indicators[i] == -1 ){
- /* NULL */
- if( item ){
- SvSetMagicSV(item,&PL_sv_undef);
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): arr[%d] = undef; SvSetMagicSV(item,&PL_sv_undef);\n",
- i
- );
- }
- }else{
- av_store(arr,i,&PL_sv_undef);
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): arr[%d] = undef; av_store(arr,i,&PL_sv_undef);\n",
- i
- );
- }
- }
- }else{
- if( (phs->array_indicators[i] == -2) || (phs->array_indicators[i] > 0) ){
- /* Truncation occurred */
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): Placeholder '%s': data truncated at %d row.\n",
- phs->name,i);
- }
- }else{
- /* All OK. Just copy value.*/
- }
- if( item ){
- switch(phs->ora_internal_type){
- case SQLT_INT:
- if (trace_level >= 4 || dbd_verbose >= 4 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): (int) set arr[%d] = %d \n",
- i, *(int*)(phs->array_buf+phs->maxlen*i)
- );
- }
- sv_setiv_mg(item,*(int*)(phs->array_buf+phs->maxlen*i));
- break;
- case SQLT_FLT:
- if (trace_level >= 4 || dbd_verbose >= 4 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): (double) set arr[%d] = %lf \n",
- i, *(double*)(phs->array_buf+phs->maxlen*i)
- );
- }
- sv_setnv_mg(item,*(double*)(phs->array_buf+phs->maxlen*i));
- }
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- STRLEN l;
- char *str= SvPOK(item) ? SvPV(item,l) : "<unprintable>" ;
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): arr[%d] = '%s'\n",
- i, str ? str : "<unprintable>"
- );
- }
- }else{
- switch(phs->ora_internal_type){
- case SQLT_INT:
- if (trace_level >= 4 || dbd_verbose >= 4 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): (int) store new arr[%d] = %d \n",
- i, *(int*)(phs->array_buf+phs->maxlen*i)
- );
- }
- av_store(arr,i,newSViv( *(int*)(phs->array_buf+phs->maxlen*i) ));
- break;
- case SQLT_FLT:
- if (trace_level >= 4 || dbd_verbose >= 4 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): (double) store new arr[%d] = %lf \n",
- i, *(double*)(phs->array_buf+phs->maxlen*i)
- );
- }
- av_store(arr,i,newSVnv( *(double*)(phs->array_buf+phs->maxlen*i) ));
- }
- if (trace_level >= 3 || dbd_verbose >= 3 ){
- STRLEN l;
- char *str;
- SV**pitem=av_fetch(arr,i,0);
- if( pitem ){
- item=*pitem;
- }
- str= item ? ( SvPOK(item) ? SvPV(item,l) : "<unprintable>" ) : "<undef>";
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): arr[%d] = '%s'\n",
- i, str ? str : "<unprintable>"
- );
- }
- }
- }
- }
- }
- if (trace_level >= 2 || dbd_verbose >= 2 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_ora_number_table_fixup_after_execute(): scalar(@arr)=%ld.\n",
- (long)av_len(arr)+1);
- }
- return 1;
-}
-
-
-
-
-static int
-dbd_rebind_ph_char(imp_sth_t *imp_sth, phs_t *phs)
-{
- dTHX;
- STRLEN value_len;
- int at_exec = 0;
- at_exec = (phs->desc_h == NULL);
-
- if (!SvPOK(phs->sv)) { /* normalizations for special cases */
- if (SvOK(phs->sv)) { /* ie a number, convert to string ASAP */
- if (!(SvROK(phs->sv) && phs->is_inout))
- sv_2pv(phs->sv, &na);
- }
- else /* ensure we're at least an SVt_PV (so SvPVX etc work) */
- if(SvUPGRADE(phs->sv, SVt_PV)){} /* For gcc not to warn on unused result)*/;
- }
-
-
- if (DBIS->debug >= 2 || dbd_verbose >=2 ) {
- char *val = neatsvpv(phs->sv,10);
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_char() (1): bind %s <== %.1000s (", phs->name, val);
- if (!SvOK(phs->sv))
- PerlIO_printf(DBILOGFP, "NULL, ");
- PerlIO_printf(DBILOGFP, "size %ld/%ld/%d, ",(long)SvCUR(phs->sv),(long)SvLEN(phs->sv),phs->maxlen);
- PerlIO_printf(DBILOGFP, "ptype %d(%s), otype %d %s)\n",(int)SvTYPE(phs->sv), sql_typecode_name(phs->ftype),phs->ftype,(phs->is_inout) ? ", inout" : "");
- }
-
- /* At the moment we always do sv_setsv() and rebind. */
- /* Later we may optimise this so that more often we can */
- /* just copy the value & length over and not rebind. */
-
- if (phs->is_inout) { /* XXX */
- if (SvREADONLY(phs->sv))
- croak("Modification of a read-only value attempted");
- if (imp_sth->ora_pad_empty)
- croak("Can't use ora_pad_empty with bind_param_inout");
- if (SvTYPE(phs->sv)!=SVt_RV || !at_exec) {
-
- if (phs->ftype == 96){
- SvGROW(phs->sv,(STRLEN) (unsigned int)phs->maxlen-1);
- } else {
- STRLEN min_len = 28;
- (void)SvUPGRADE(phs->sv, SVt_PVNV);
- /* ensure room for result, 28 is magic number (see sv_2pv) */
- /* don't apply 28 char min to CHAR types - probably shouldn't */
- /* apply it anywhere really, trying to be too helpful. */
- /* phs->sv _is_ the real live variable, it may 'mutate' later */
- /* pre-upgrade to high'ish type to reduce risk of SvPVX realloc/move */
- SvGROW(phs->sv, (STRLEN)(((unsigned int) phs->maxlen <= min_len) ? min_len : (unsigned int) phs->maxlen)+1/*for null*/);
-
- }
- }
-
- }
-
- /* At this point phs->sv must be at least a PV with a valid buffer, */
- /* even if it's undef (null) */
- /* Here we set phs->progv, phs->indp, and value_len. */
-
- if (SvOK(phs->sv)) {
- phs->progv = SvPV(phs->sv, value_len);
- phs->indp = 0;
- } else { /* it's null but point to buffer incase it's an out var */
- phs->progv = (phs->is_inout) ? SvPVX(phs->sv) : NULL;
- phs->indp = -1;
- value_len = 0;
- }
-
-
- if (imp_sth->ora_pad_empty && value_len==0) {
- sv_setpv(phs->sv, " ");
- phs->progv = SvPV(phs->sv, value_len);
- }
-
- phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */
- if (SvTYPE(phs->sv) == SVt_RV && SvTYPE(SvRV(phs->sv)) == SVt_PVAV) { /* it is returning an array of scalars not a single scalar*/
- phs->maxlen = 4000; /* Just make is a varchar max should be ok for most things*/
-
- } else {
- phs->maxlen = ((IV)SvLEN(phs->sv)); /* avail buffer space (64bit safe) Logicaly maxlen should never change but it does why I know not*/
-
- }
-
-
- if (phs->maxlen < 0) /* can happen with nulls */
- phs->maxlen = 0;
-
- phs->alen = value_len + phs->alen_incnull;
-
- if (DBIS->debug >= 3 || dbd_verbose >=3) {
- UV neatsvpvlen = (UV)DBIc_DBISTATE(imp_sth)->neatsvpvlen;
- char *val = neatsvpv(phs->sv,10);
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_char() (2): bind %s <== '%.*s' (size %ld/%ld, otype %d(%s), indp %d, at_exec %d)\n",
- phs->name,
- (int)(phs->alen > neatsvpvlen ? neatsvpvlen : phs->alen),
- (phs->progv) ? val: "",
- (long)phs->alen, (long)phs->maxlen, phs->ftype,sql_typecode_name(phs->ftype), phs->indp, at_exec);
- }
-
- return 1;
-}
-
-
-/*
- * Rebind an "in" cursor ref to its real statement handle
- * This allows passing cursor refs as "in" to pl/sql (but only if you got the
- * cursor from pl/sql to begin with)
- */
-int
-pp_rebind_ph_rset_in(SV *sth, imp_sth_t *imp_sth, phs_t *phs)
-{
- dTHX;
- dTHR;
- SV * sth_csr = phs->sv;
- D_impdata(imp_sth_csr, imp_sth_t, sth_csr);
- sword status;
-
- if (DBIS->debug >= 3 || dbd_verbose >=3)
- PerlIO_printf(DBILOGFP, " pp_rebind_ph_rset_in: BEGIN\n calling OCIBindByName(stmhp=%p, bndhp=%p, errhp=%p, name=%s, csrstmhp=%p, ftype=%d)\n", imp_sth->stmhp, phs->bndhp, imp_sth->errhp, phs->name, imp_sth_csr->stmhp, phs->ftype);
-
- OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
- (text*)phs->name, (sb4)strlen(phs->name),
- &imp_sth_csr->stmhp,
- 0,
- (ub2)phs->ftype, 0,
- NULL,
- 0, 0,
- NULL,
- (ub4)OCI_DEFAULT,
- status
- );
-
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindByName SQLT_RSET");
- return 0;
- }
-
- if (DBIS->debug >= 3 || dbd_verbose >=3)
- PerlIO_printf(DBILOGFP, " pp_rebind_ph_rset_in: END\n");
-
- return 2;
-}
-
-
-int
-pp_exec_rset(SV *sth, imp_sth_t *imp_sth, phs_t *phs, int pre_exec)
-{
- dTHX;
- if (pre_exec) { /* pre-execute - allocate a statement handle */
- dSP;
- D_imp_dbh_from_sth;
- HV *init_attr = newHV();
- int count;
- sword status;
-
- if (DBIS->debug >= 3 || dbd_verbose >=3)
- PerlIO_printf(DBILOGFP, " pp_exec_rset bind %s - allocating new sth...\n", phs->name);
-
-
- /* extproc deallocates everything for us */
- if (is_extproc)
- return 1;
-
- if (!phs->desc_h || 1) { /* XXX phs->desc_t != OCI_HTYPE_STMT) */
- if (phs->desc_h) {
- OCIHandleFree_log_stat(phs->desc_h, phs->desc_t, status);
- phs->desc_h = NULL;
- }
- phs->desc_t = OCI_HTYPE_STMT;
- OCIHandleAlloc_ok(imp_sth->envhp, &phs->desc_h, phs->desc_t, status);
- }
-
-
- phs->progv = (char*)&phs->desc_h;
- phs->maxlen = 0;
-
- OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
- (text*)phs->name, (sb4)strlen(phs->name),
- phs->progv, 0,
- (ub2)phs->ftype, 0, /* using &phs->indp triggers ORA-01001 errors! */
- NULL, 0, 0, NULL, OCI_DEFAULT, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindByName SQLT_RSET");
- return 0;
- }
- ENTER;
- SAVETMPS;
- PUSHMARK(SP);
- XPUSHs(sv_2mortal(newRV((SV*)DBIc_MY_H(imp_dbh))));
- XPUSHs(sv_2mortal(newRV((SV*)init_attr)));
- PUTBACK;
- count = perl_call_pv("DBI::_new_sth", G_ARRAY);
- SPAGAIN;
- if (count != 2)
- croak("panic: DBI::_new_sth returned %d values instead of 2", count);
- (void)POPs; /* discard inner handle */
- sv_setsv(phs->sv, POPs); /* save outer handle */
- SvREFCNT_dec(init_attr);
- PUTBACK;
- FREETMPS;
- LEAVE;
- if (DBIS->debug >= 3 || dbd_verbose >=3)
- PerlIO_printf(DBILOGFP, " pp_exec_rset bind %s - allocated %s...\n",
- phs->name, neatsvpv(phs->sv, 0));
-
- }
- else { /* post-execute - setup the statement handle */
- dTHR;
- SV * sth_csr = phs->sv;
- D_impdata(imp_sth_csr, imp_sth_t, sth_csr);
-
- if (DBIS->debug >= 3 || dbd_verbose >=3 )
- PerlIO_printf(DBILOGFP, " bind %s - initialising new %s for cursor 0x%lx...\n",
- phs->name, neatsvpv(sth_csr,0), (unsigned long)phs->progv);
-
- /* copy appropriate handles and atributes from parent statement */
- imp_sth_csr->envhp = imp_sth->envhp;
- imp_sth_csr->errhp = imp_sth->errhp;
- imp_sth_csr->srvhp = imp_sth->srvhp;
- imp_sth_csr->svchp = imp_sth->svchp;
- imp_sth_csr->auto_lob = imp_sth->auto_lob;
- imp_sth_csr->pers_lob = imp_sth->pers_lob;
- imp_sth_csr->clbk_lob = imp_sth->clbk_lob;
- imp_sth_csr->piece_size = imp_sth->piece_size;
- imp_sth_csr->piece_lob = imp_sth->piece_lob;
- imp_sth_csr->is_child = 1; /*no prefetching on a cursor or sp*/
-
-
- /* assign statement handle from placeholder descriptor */
- imp_sth_csr->stmhp = (OCIStmt*)phs->desc_h;
- phs->desc_h = NULL; /* tell phs that we own it now */
-
- /* force stmt_type since OCIAttrGet(OCI_ATTR_STMT_TYPE) doesn't work! */
- imp_sth_csr->stmt_type = OCI_STMT_SELECT;
- imp_sth_csr->rs_array_on=1; /* turn on array fetch for ref cursors */
- DBIc_IMPSET_on(imp_sth_csr);
-
- /* set ACTIVE so dbd_describe doesn't do explicit OCI describe */
- DBIc_ACTIVE_on(imp_sth_csr);
- if (!dbd_describe(sth_csr, imp_sth_csr)) {
- return 0;
- }
- }
- return 1;
-}
-
-static int
-dbd_rebind_ph_xml( SV* sth, imp_sth_t *imp_sth, phs_t *phs) {
- dTHX;
- dTHR;
- OCIType *tdo = NULL;
- sword status;
- SV* ptr;
-
-
- if (DBIS->debug >= 3 || dbd_verbose >=3)
- PerlIO_printf(DBILOGFP, " in dbd_rebind_ph_xml\n");
-
- /*go and create the XML dom from the passed in value*/
-
- phs->sv=createxmlfromstring(sth, imp_sth, phs->sv );
-
- if (phs->is_inout)
- croak("OUT binding for NTY is currently unsupported");
-
- /* ensure that the value is a support named object type */
- /* (currently only OCIXMLType*) */
- if ( sv_isa(phs->sv, "OCIXMLTypePtr") ) {
- OCITypeByName(imp_sth->envhp, imp_sth->errhp, imp_sth->svchp,
- (CONST text*)"SYS", 3,
- (CONST text*)"XMLTYPE", 7,
- (CONST text*)0, 0,
- OCI_DURATION_CALLOUT, OCI_TYPEGET_HEADER,
- &tdo);
- ptr = SvRV(phs->sv);
- phs->progv = (void*) SvIV(ptr);
- phs->maxlen = sizeof(OCIXMLType*);
- }
- else
- croak("Unsupported named object type for bind parameter");
-
-
- /* bind by name */
-
- OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
- (text*)phs->name, (sb4)strlen(phs->name),
- (dvoid *) NULL, /* value supplied in BindObject later */
- 0,
- (ub2)phs->ftype, 0,
- NULL,
- 0, 0,
- NULL,
- (ub4)OCI_DEFAULT,
- status
- );
-
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindByName SQLT_NTY");
- return 0;
- }
- if (DBIS->debug >= 3 || dbd_verbose >=3)
- PerlIO_printf(DBILOGFP, " pp_rebind_ph_nty: END\n");
-
-
- /* bind the object */
- OCIBindObject(phs->bndhp, imp_sth->errhp,
- (CONST OCIType*)tdo,
- (dvoid **)&phs->progv,
- (ub4*)NULL,
- (dvoid **)NULL,
- (ub4*)NULL);
-
- return 2;
- }
-
-
-static int
-dbd_rebind_ph(SV *sth, imp_sth_t *imp_sth, phs_t *phs)
-{
- dTHX;
- /*ub2 *alen_ptr = NULL;*/
- sword status;
- int done = 0;
- int at_exec;
- int trace_level = DBIS->debug;
- ub1 csform;
- ub2 csid;
-
- if (trace_level >= 5 || dbd_verbose >= 5 )
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph() (1): rebinding %s as %s (%s, ftype %d (%s), csid %d, csform %d, inout %d)\n",
- phs->name, (SvPOK(phs->sv) ? neatsvpv(phs->sv,10) : "NULL"),(SvUTF8(phs->sv) ? "is-utf8" : "not-utf8"),
- phs->ftype,sql_typecode_name(phs->ftype),phs->csid, phs->csform, phs->is_inout);
-
-
- switch (phs->ftype) {
- case ORA_VARCHAR2_TABLE:
- done = dbd_rebind_ph_varchar2_table(sth, imp_sth, phs);
- break;
- case ORA_NUMBER_TABLE:
- done = dbd_rebind_ph_number_table(sth, imp_sth, phs);
- break;
- case SQLT_CLOB:
- case SQLT_BLOB:
- done = dbd_rebind_ph_lob(sth, imp_sth, phs);
- break;
- case SQLT_RSET:
- done = dbd_rebind_ph_rset(sth, imp_sth, phs);
- break;
- case ORA_XMLTYPE:
- done = dbd_rebind_ph_xml(sth, imp_sth, phs);
- break;
- default:
- done = dbd_rebind_ph_char(imp_sth, phs);
- }
-
- if (done == 2) { /* the dbd_rebind_* did the OCI bind call itself successfully */
- if (trace_level >= 3 || dbd_verbose >= 3 )
- PerlIO_printf(DBILOGFP, " rebind %s done with ftype %d (%s)\n",
- phs->name, phs->ftype,sql_typecode_name(phs->ftype));
- return 1;
- }
-
- if (trace_level >= 3 || dbd_verbose >= 3 )
- PerlIO_printf(DBILOGFP, " bind %s as ftype %d (%s)\n",
- phs->name, phs->ftype,sql_typecode_name(phs->ftype));
-
- if (done != 1) {
- return 0; /* the rebind failed */
- }
-
- at_exec = (phs->desc_h == NULL);
-
-
- OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
- (text*)phs->name, (sb4)strlen(phs->name),
- phs->progv,
- phs->maxlen ? (sb4)phs->maxlen : 1, /* else bind "" fails */
- (ub2)phs->ftype, &phs->indp,
- NULL, /* ub2 *alen_ptr not needed with OCIBindDynamic */
- &phs->arcode,
- 0, /* max elements that can fit in allocated array */
- NULL, /* (ptr to) current number of elements in array */
- (ub4)(at_exec ? OCI_DATA_AT_EXEC : OCI_DEFAULT),
- status
- );
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindByName");
- return 0;
- }
- if (at_exec) {
- OCIBindDynamic_log(phs->bndhp, imp_sth->errhp,
- (dvoid *)phs, dbd_phs_in,
- (dvoid *)phs, dbd_phs_out, status);
-
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindDynamic");
- return 0;
- }
- }
-
- /* some/all of the following should perhaps move into dbd_phs_in() */
-
- csform = phs->csform;
-
- if (!csform && SvUTF8(phs->sv)) {
- /* try to default csform to avoid translation through non-unicode */
- if (CSFORM_IMPLIES_UTF8(SQLCS_IMPLICIT)) /* prefer IMPLICIT */
- csform = SQLCS_IMPLICIT;
- else if (CSFORM_IMPLIES_UTF8(SQLCS_NCHAR))
- csform = SQLCS_NCHAR; /* else leave csform == 0 */
- if (trace_level || dbd_verbose >= 1)
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph() (2): rebinding %s with UTF8 value %s", phs->name,
- (csform == SQLCS_IMPLICIT) ? "so setting csform=SQLCS_IMPLICIT" :
- (csform == SQLCS_NCHAR) ? "so setting csform=SQLCS_NCHAR" :
- "but neither CHAR nor NCHAR are unicode\n");
- }
-
- if (csform) {
- /* set OCI_ATTR_CHARSET_FORM before we get the default OCI_ATTR_CHARSET_ID */
- OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
- &csform, (ub4) 0, (ub4) OCI_ATTR_CHARSET_FORM, imp_sth->errhp, status);
- if ( status != OCI_SUCCESS ) {
- oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_FORM)"));
- return 0;
- }
- }
-
- if (!phs->csid_orig) { /* get the default csid Oracle would use */
- OCIAttrGet_log_stat(phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, (ub4)0 ,
- OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
- }
-
- /* if app has specified a csid then use that, else use default */
- csid = (phs->csid) ? phs->csid : phs->csid_orig;
-
- /* if data is utf8 but charset isn't then switch to utf8 csid */
- if (SvUTF8(phs->sv) && !CS_IS_UTF8(csid))
- csid = utf8_csid; /* not al32utf8_csid here on purpose */
-
- if (trace_level >= 3 || dbd_verbose >= 3 )
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph(): bind %s <== %s "
- "(%s, %s, csid %d->%d->%d, ftype %d (%s), csform %d->%d, maxlen %lu, maxdata_size %lu)\n",
- phs->name, neatsvpv(phs->sv,10),
- (phs->is_inout) ? "inout" : "in",
- (SvUTF8(phs->sv) ? "is-utf8" : "not-utf8"),
- phs->csid_orig, phs->csid, csid,
- phs->ftype,sql_typecode_name(phs->ftype), phs->csform, csform,
- (unsigned long)phs->maxlen, (unsigned long)phs->maxdata_size);
-
-
- if (csid) {
- OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
- &csid, (ub4) 0, (ub4) OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
- if ( status != OCI_SUCCESS ) {
- oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_ID)"));
- return 0;
- }
- }
-
- if (phs->maxdata_size) {
- OCIAttrSet_log_stat(phs->bndhp, (ub4)OCI_HTYPE_BIND,
- neatsvpv(phs->sv,0), (ub4)phs->maxdata_size, (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 1;
-}
-
-
-int
-dbd_bind_ph(SV *sth, imp_sth_t *imp_sth, SV *ph_namesv, SV *newvalue, IV sql_type, SV *attribs, int is_inout, IV maxlen)
-{
- dTHX;
- SV **phs_svp;
- STRLEN name_len;
- char *name = Nullch;
- char namebuf[32];
- phs_t *phs;
-
- /* check if placeholder was passed as a number */
- if (SvGMAGICAL(ph_namesv)) /* eg tainted or overloaded */
- mg_get(ph_namesv);
-
- if (!SvNIOKp(ph_namesv)) {
- STRLEN i;
- name = SvPV(ph_namesv, name_len);
- if (name_len > sizeof(namebuf)-1)
- croak("Placeholder name %s too long", neatsvpv(ph_namesv,0));
-
- for (i=0; i<name_len; i++) namebuf[i] = toLOWER(name[i]);
- namebuf[i] = '\0';
- name = namebuf;
- }
-
- if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) {
- sprintf(namebuf, ":p%d", (int)SvIV(ph_namesv));
- name = namebuf;
- name_len = strlen(name);
- }
-
- assert(name != Nullch);
-
- if (SvROK(newvalue)
- && !IS_DBI_HANDLE(newvalue) /* dbi handle allowed for cursor variables */
- && !SvAMAGIC(newvalue) /* overload magic allowed (untested) */
- && !sv_derived_from(newvalue, "OCILobLocatorPtr" ) /* input LOB locator*/
- && !(SvTYPE(SvRV(newvalue))==SVt_PVAV) /* Allow array binds */
- )
- croak("Can't bind a reference (%s)", neatsvpv(newvalue,0));
-
- if (SvTYPE(newvalue) > SVt_PVAV) /* Array binding supported */
- croak("Can't bind a non-scalar, non-array value (%s)", neatsvpv(newvalue,0));
- if (SvTYPE(newvalue) == SVt_PVLV && is_inout) /* may allow later */
- croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)");
-
- if (DBIS->debug >= 2 || dbd_verbose >=2) {
- PerlIO_printf(DBILOGFP, "dbd_bind_ph(): bind %s <== %s (type %ld (%s)",
- name, neatsvpv(newvalue,0), (long)sql_type,sql_typecode_name(sql_type));
- if (is_inout)
- PerlIO_printf(DBILOGFP, ", inout 0x%lx, maxlen %ld",
- (long)newvalue, (long)maxlen);
- if (attribs)
- PerlIO_printf(DBILOGFP, ", attribs: %s", neatsvpv(attribs,0));
- PerlIO_printf(DBILOGFP, ")\n");
- }
-
- phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0);
-
-
- if (phs_svp == NULL)
- croak("Can't bind unknown placeholder '%s' (%s)", name, neatsvpv(ph_namesv,0));
-
- /* This value is not a string, but a binary structure phs_st instead. */
- phs = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */
-
- if (phs->sv == &sv_undef) { /* first bind for this placeholder */
- phs->is_inout = is_inout;
- if (is_inout) {
- /* phs->sv assigned in the code below */
- ++imp_sth->has_inout_params;
- /* build array of phs's so we can deal with out vars fast */
- if (!imp_sth->out_params_av)
- imp_sth->out_params_av = newAV();
- av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp));
- }
-
- /*
- * Init number of bound array entries to zero.
- * If "ora_maxarray_numentries" bind parameter specified,
- * it would be set below.
- *
- * If no ora_maxarray_numentries specified, let it be
- * the same as scalar(@array) bound (see dbd_rebind_ph_varchar2_table() ).
- */
- phs->array_numstruct=0;
-
- if (attribs) { /* only look for ora_type on first bind of var */
- SV **svp;
- /* Setup / Clear attributes as defined by attribs. */
- /* XXX If attribs is EMPTY then reset attribs to default? */
-
- if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_type",8, 0)) != NULL) {
- int ora_type = SvIV(*svp);
- if (!oratype_bind_ok(ora_type))
- croak("Can't bind %s, ora_type %d not supported by DBD::Oracle", phs->name, ora_type);
- if (sql_type)
- croak("Can't specify both TYPE (%d) and ora_type (%d) for %s", sql_type, ora_type, phs->name);
- phs->ftype = ora_type;
- }
- if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_field",9, 0)) != NULL) {
- phs->ora_field = SvREFCNT_inc(*svp);
- }
- if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_csform", 10, 0)) != NULL) {
- if (SvIV(*svp) == SQLCS_IMPLICIT || SvIV(*svp) == SQLCS_NCHAR)
- phs->csform = (ub1)SvIV(*svp);
- else warn("ora_csform must be 1 (SQLCS_IMPLICIT) or 2 (SQLCS_NCHAR), not %d", SvIV(*svp));
- }
- if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_maxdata_size", 16, 0)) != NULL) {
- phs->maxdata_size = SvUV(*svp);
- }
- if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_maxarray_numentries", 23, 0)) != NULL) {
- phs->ora_maxarray_numentries=SvUV(*svp);
- }
- if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_internal_type", 17, 0)) != NULL) {
- phs->ora_internal_type=SvUV(*svp);
- }
- }
-
-
- if (sql_type)
- phs->ftype = ora_sql_type(imp_sth, phs->name, (int)sql_type);
- /* treat Oracle7 SQLT_CUR as SQLT_RSET for Oracle8 */
- if (phs->ftype==102)
- phs->ftype = 116;
-
- /* some types require the trailing null included in the length. */
- /* SQLT_STR=5=STRING, SQLT_AVC=97=VARCHAR */
- phs->alen_incnull = (phs->ftype==SQLT_STR || phs->ftype==SQLT_AVC);
-
- } /* was first bind for this placeholder */
-
- /* check later rebinds for any changes */
- else if (is_inout != phs->is_inout) {
- croak("Can't rebind or change param %s in/out mode after first bind (%d => %d)",
- phs->name, phs->is_inout , is_inout);
-
- }
- else if (sql_type && phs->ftype != ora_sql_type(imp_sth, phs->name, (int)sql_type)) {
- croak("Can't change TYPE of param %s to %d after initial bind",
- phs->name, sql_type);
-
- }
- /* Array binding is supported for a limited number of data types. */
-
- if( SvROK(newvalue) ){
- if( SvTYPE(SvRV(newvalue))==SVt_PVAV ){
- if( (phs->ftype == ORA_VARCHAR2_TABLE) ||
- (phs->ftype == ORA_NUMBER_TABLE) ||
- (phs->ftype == 1)) /*ORA_VARCHAR2*/ {
- /* Supported */
- }else{
- /* All the other types are not supported */
- croak("Array bind is supported only for ORA_%_TABLE types. Unable to bind '%s'.",phs->name);
-
- }
- }
- }
-
- /* Add checks for other reference types here ? */
-
- phs->maxlen = maxlen; /* 0 if not inout */
-
- if (!is_inout) { /* normal bind so take a (new) copy of current value */
- if (phs->sv == &sv_undef) /* (first time bind) */
- phs->sv = newSV(0);
- sv_setsv(phs->sv, newvalue);
- if (SvAMAGIC(phs->sv)) /* overloaded. XXX hack, logic ought to be pushed deeper */
- sv_pvn_force(phs->sv, &na);
- }
- else if (newvalue != phs->sv) {
- if (phs->sv)
- SvREFCNT_dec(phs->sv);
-
- phs->sv = SvREFCNT_inc(newvalue); /* point to live var */
- }
-
- return dbd_rebind_ph(sth, imp_sth, phs);
-}
-
-
-/* --- functions to 'complete' the fetch of a value --- */
-
-void
-dbd_phs_sv_complete(phs_t *phs, SV *sv, I32 debug)
-{
- dTHX;
- char *note = "";
- /* XXX doesn't check arcode for error, caller is expected to */
-
- if (phs->indp == 0) { /* is okay */
-
- if (phs->is_inout && phs->alen == SvLEN(sv)) {
-
- /* if the placeholder has not been assigned to then phs->alen */
- /* is left untouched: still set to SvLEN(sv). If we use that */
- /* then we'll get garbage bytes beyond the original contents. */
- phs->alen = SvCUR(sv);
- note = " UNTOUCHED?";
- }
-
- if (SvPVX(sv)) {
- SvCUR_set(sv, phs->alen);
- *SvEND(sv) = '\0';
- SvPOK_only_UTF8(sv);
- }
- else { /* shouldn't happen */
- debug = 2;
- dbd_verbose =2;
- note = " [placeholder has no data buffer]";
- }
-
- if (debug >= 2 || dbd_verbose >=2)
- PerlIO_printf(DBILOGFP, " out %s = %s (arcode %d, ind %d, len %d)%s\n",
- phs->name, neatsvpv(sv,0), phs->arcode, phs->indp, phs->alen, note);
- }
- else {
- if (phs->indp > 0 || phs->indp == -2) { /* truncated */
- if (SvPVX(sv)) {
- SvCUR_set(sv, phs->alen);
- *SvEND(sv) = '\0';
- SvPOK_only_UTF8(sv);
- }
- else { /* shouldn't happen */
- debug = 2;
- dbd_verbose =2;
- note = " [placeholder has no data buffer]";
- }
- if (debug >= 2 || dbd_verbose >=2)
- PerlIO_printf(DBILOGFP,
- " out %s = %s\t(TRUNCATED from %d to %ld, arcode %d)%s\n",
- phs->name, neatsvpv(sv,0), phs->indp, (long)phs->alen, phs->arcode, note);
- }
- else {
- if (phs->indp == -1) { /* is NULL */
- (void)SvOK_off(phs->sv);
- if (debug >= 2 || dbd_verbose >=2)
- PerlIO_printf(DBILOGFP,
- " out %s = undef (NULL, arcode %d)\n",
- phs->name, phs->arcode);
- }
- else {
- croak("panic dbd_phs_sv_complete: %s bad indp %d, arcode %d", phs->name, phs->indp, phs->arcode);
- }
- }
- }
-}
-void
-dbd_phs_avsv_complete(phs_t *phs, I32 index, I32 debug)
-{
- dTHX;
- AV *av = (AV*)SvRV(phs->sv);
- SV *sv = *av_fetch(av, index, 1);
- dbd_phs_sv_complete(phs, sv, 0);
- if (debug >= 2 || dbd_verbose >=2)
- PerlIO_printf(DBILOGFP, " dbd_phs_avsv_complete out '%s'[%ld] = %s (arcode %d, ind %d, len %d)\n",
- phs->name, (long)index, neatsvpv(sv,0), phs->arcode, phs->indp, phs->alen);
-}
-
-
-/* --- */
-
-
-int
-dbd_st_execute(SV *sth, imp_sth_t *imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */
-{
- dTHR;
- dTHX;
- ub4 row_count = 0;
- int debug = DBIS->debug;
- int outparams = (imp_sth->out_params_av) ? AvFILL(imp_sth->out_params_av)+1 : 0;
- D_imp_dbh_from_sth;
- sword status;
- int is_select = (imp_sth->stmt_type == OCI_STMT_SELECT);
-
-
- if (debug >= 2 || dbd_verbose >= 2)
- PerlIO_printf(DBILOGFP, " dbd_st_execute %s (out%d, lob%d)...\n",
- oci_stmt_type_name(imp_sth->stmt_type), outparams, imp_sth->has_lobs);
-
-
- /* Don't attempt execute for nested cursor. It would be meaningless,
- and Oracle code has been seen to core dump */
- if (imp_sth->nested_cursor) {
- oci_error(sth, NULL, OCI_ERROR,
- "explicit execute forbidden for nested cursor");
- return -2;
- }
-
-
- if (outparams) { /* check validity of bind_param_inout SV's */
- int i = outparams;
- while(--i >= 0) {
- phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]);
- SV *sv = phs->sv;
- /* Make sure we have the value in string format. Typically a number */
- /* will be converted back into a string using the same bound buffer */
- /* so the progv test below will not trip. */
-
- /* is the value a null? */
- phs->indp = (SvOK(sv)) ? 0 : -1;
-
- if (phs->out_prepost_exec) {
- if (!phs->out_prepost_exec(sth, imp_sth, phs, 1))
- return -2; /* out_prepost_exec already called ora_error() */
- }
- else
- if (SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVAV) {
- if (debug >= 2 || dbd_verbose >=2)
- PerlIO_printf(DBILOGFP,
- " with %s = [] (len %ld/%ld, indp %d, otype %d, ptype %d)\n",
- phs->name,
- (long)phs->alen, (long)phs->maxlen, phs->indp,
- phs->ftype, (int)SvTYPE(sv));
- av_clear((AV*)SvRV(sv));
- }
- else
- /* Some checks for mutated storage since we pointed oracle at it. */
- if (SvTYPE(sv) != phs->sv_type
- || (SvOK(sv) && !SvPOK(sv))
- /* SvROK==!SvPOK so cursor (SQLT_CUR) handle will call dbd_rebind_ph */
- /* that suits us for now */
- || SvPVX(sv) != phs->progv
- || (SvPOK(sv) && SvCUR(sv) > UB2MAXVAL)
- ) {
- if (!dbd_rebind_ph(sth, imp_sth, phs))
- croak("Can't rebind placeholder %s", phs->name);
- }
- else {
- /* String may have grown or shrunk since it was bound */
- /* so tell Oracle about it's current length */
- ub2 prev_alen = phs->alen;
- phs->alen = (SvOK(sv)) ? SvCUR(sv) + phs->alen_incnull : 0+phs->alen_incnull;
- if (debug >= 2 || dbd_verbose >=2)
- PerlIO_printf(DBILOGFP,
- " with %s = '%.*s' (len %ld(%ld)/%ld, indp %d, otype %d, ptype %d)\n",
- phs->name, (int)phs->alen,
- (phs->indp == -1) ? "" : SvPVX(sv),
- (long)phs->alen, (long)prev_alen, (long)phs->maxlen, phs->indp,
- phs->ftype, (int)SvTYPE(sv));
- }
- }
- }
-
-
- if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && !is_select) {
- imp_sth->exe_mode=OCI_COMMIT_ON_SUCCESS;
- /* we don't AutoCommit on select so LOB locators work */
- } else if(imp_sth->exe_mode!=OCI_STMT_SCROLLABLE_READONLY){
-
- imp_sth->exe_mode=OCI_DEFAULT;
- }
-
-
- if (debug >= 2 || dbd_verbose >= 2)
- PerlIO_printf(DBILOGFP,"Statement Execute Mode is %d (%s)\n",imp_sth->exe_mode,oci_exe_mode(imp_sth->exe_mode));
-
-
- OCIStmtExecute_log_stat(imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp,
- (ub4)(is_select ? 0 : 1),
- 0, 0, 0,(ub4)imp_sth->exe_mode,status);
-
-
- if (status != OCI_SUCCESS) { /* may be OCI_ERROR or OCI_SUCCESS_WITH_INFO etc */
- /* we record the error even for OCI_SUCCESS_WITH_INFO */
- oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIStmtExecute"));
- /* but only bail out here if not OCI_SUCCESS_WITH_INFO */
- if (status != OCI_SUCCESS_WITH_INFO)
- return -2;
- }
-
- if (is_select) {
- DBIc_ACTIVE_on(imp_sth);
- DBIc_ROW_COUNT(imp_sth) = 0; /* reset (possibly re-exec'ing) */
- row_count = 0;
- }
- else {
- OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
- }
-
- if (debug >= 2 || dbd_verbose >= 2) {
- ub2 sqlfncode;
- OCIAttrGet_stmhp_stat(imp_sth, &sqlfncode, 0, OCI_ATTR_SQLFNCODE, status);
- PerlIO_printf(DBILOGFP,
- " dbd_st_execute %s returned (%s, rpc%ld, fn%d, out%d)\n",
- oci_stmt_type_name(imp_sth->stmt_type),
- oci_status_name(status),
- (long)row_count, sqlfncode, imp_sth->has_inout_params);
- }
-
- if (is_select && !imp_sth->done_desc) {
- /* describe and allocate storage for results (if any needed) */
- if (!dbd_describe(sth, imp_sth))
- return -2; /* dbd_describe already called oci_error() */
- }
-
- if (imp_sth->has_lobs && imp_sth->stmt_type != OCI_STMT_SELECT) {
- if (!post_execute_lobs(sth, imp_sth, row_count))
- return -2; /* post_insert_lobs already called oci_error() */
- }
-
- if (outparams) { /* check validity of bound output SV's */
- int i = outparams;
- while(--i >= 0) {
- /* phs->alen has been updated by Oracle to hold the length of the result */
- phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]);
- SV *sv = phs->sv;
- if (debug >= 2 || dbd_verbose >= 2) {
- PerlIO_printf(DBILOGFP,
- "dbd_st_execute(): Analyzing inout parameter '%s of type=%d'\n",
- phs->name,phs->ftype);
- }
- if( phs->ftype == ORA_VARCHAR2_TABLE ){
- dbd_phs_ora_varchar2_table_fixup_after_execute(phs);
- continue;
- }
- if( phs->ftype == ORA_NUMBER_TABLE ){
- dbd_phs_ora_number_table_fixup_after_execute(phs);
- continue;
- }
-
- if (phs->out_prepost_exec) {
- if (!phs->out_prepost_exec(sth, imp_sth, phs, 0))
- return -2; /* out_prepost_exec already called ora_error() */
- }
- else {
- if (SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVAV) {
- AV *av = (AV*)SvRV(sv);
- I32 avlen = AvFILL(av);
- if (avlen >= 0)
- dbd_phs_avsv_complete(phs, avlen, debug);
- }
- else {
- dbd_phs_sv_complete(phs, sv, debug);
- }
- }
- }
- }
-
- return row_count; /* row count (0 will be returned as "0E0") */
-}
-
-static int
-do_bind_array_exec(sth, imp_sth, phs, utf8)
- SV *sth;
- imp_sth_t *imp_sth;
- phs_t *phs;
- int utf8;
-{
- dTHX;
- sword status;
- ub1 csform;
- ub2 csid;
- int trace_level = DBIS->debug;
-
- OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
- (text*)phs->name, (sb4)strlen(phs->name),
- 0,
- phs->maxlen ? (sb4)phs->maxlen : 1, /* else bind "" fails */
- (ub2)phs->ftype, 0,
- NULL, /* ub2 *alen_ptr not needed with OCIBindDynamic */
- 0,
- 0, /* max elements that can fit in allocated array */
- NULL, /* (ptr to) current number of elements in array */
- (ub4)OCI_DATA_AT_EXEC,
- status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindByName");
- return 0;
- }
-
-
- OCIBindDynamic_log(phs->bndhp, imp_sth->errhp,
- (dvoid *)phs, dbd_phs_in,
- (dvoid *)phs, dbd_phs_out, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindDynamic");
- return 0;
- }
-
- /* copied and adapted from dbd_rebind_ph */
- csform = phs->csform;
- if (!csform && (utf8 & ARRAY_BIND_UTF8)) {
- /* try to default csform to avoid translation through non-unicode */
- if (CSFORM_IMPLIES_UTF8(SQLCS_IMPLICIT)) /* prefer IMPLICIT */
- csform = SQLCS_IMPLICIT;
- else if (CSFORM_IMPLIES_UTF8(SQLCS_NCHAR))
- csform = SQLCS_NCHAR; /* else leave csform == 0 */
-
- if (trace_level || dbd_verbose >= 1)
- PerlIO_printf(DBILOGFP, "do_bind_array_exec() (2): rebinding %s with UTF8 value %s", phs->name,
- (csform == SQLCS_IMPLICIT) ? "so setting csform=SQLCS_IMPLICIT" :
- (csform == SQLCS_NCHAR) ? "so setting csform=SQLCS_NCHAR" :
- "but neither CHAR nor NCHAR are unicode\n");
- }
-
- if (csform) {
- /* set OCI_ATTR_CHARSET_FORM before we get the default OCI_ATTR_CHARSET_ID */
- OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,&csform, (ub4) 0, (ub4) OCI_ATTR_CHARSET_FORM, imp_sth->errhp, status);
- if ( status != OCI_SUCCESS ) {
- oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_FORM)"));
- return 0;
- }
- }
-
- if (!phs->csid_orig) { /* get the default csid Oracle would use */
- OCIAttrGet_log_stat(phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, (ub4)0 ,
- OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
- }
-
- /* if app has specified a csid then use that, else use default */
-
- csid = (phs->csid) ? phs->csid : phs->csid_orig;
- /* if data is utf8 but charset isn't then switch to utf8 csid if possible */
- if ((utf8 & ARRAY_BIND_UTF8) && !CS_IS_UTF8(csid)) {
- /* if the specified or default csid is not utf8 _compatible_ AND we have */
- /* mixed utf8 and native (non-utf8) data, then it's a fatal problem */
- /* utf8 _compatible_ means, can be upgraded to utf8, ie. utf8 or ascii */
- /* if ((utf8 & ARRAY_BIND_NATIVE) && !CS_IS_UTF8_COMPATIBLE(csid)) {
- croak("Can't mix utf8 and non-utf8 in array bind");
- }*/
- csid = utf8_csid; /* not al32utf8_csid here on purpose */
- }
-
- if (trace_level >= 3 || dbd_verbose >= 3 )
- PerlIO_printf(DBILOGFP, "do_bind_array_exec(): bind %s <== [array of values] "
- "(%s, %s, csid %d->%d->%d, ftype %d (%s), csform %d->%d, maxlen %lu, maxdata_size %lu)\n",
- phs->name,
- (phs->is_inout) ? "inout" : "in",
- (utf8 ? "is-utf8" : "not-utf8"),
- phs->csid_orig, phs->csid, csid,
- phs->ftype,sql_typecode_name(phs->ftype), phs->csform, csform,
- (unsigned long)phs->maxlen, (unsigned long)phs->maxdata_size);
-
-
- if (csid) {
- OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
- &csid, (ub4) 0, (ub4) OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
- if ( status != OCI_SUCCESS ) {
- oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_ID)"));
- return 0;
- }
- }
-
- return 1;
-}
-
-static void
-init_bind_for_array_exec(phs)
- phs_t *phs;
-{
- dTHX;
- if (phs->sv == &sv_undef) { /* first bind for this placeholder */
- phs->is_inout = 0;
- phs->maxlen = 1;
- /* treat Oracle7 SQLT_CUR as SQLT_RSET for Oracle8 */
- if (phs->ftype==102)
- phs->ftype = 116;
- /* some types require the trailing null included in the length. */
- /* SQLT_STR=5=STRING, SQLT_AVC=97=VARCHAR */
- phs->alen_incnull = (phs->ftype==SQLT_STR || phs->ftype==SQLT_AVC);
- }
-}
-
- int
-ora_st_execute_array(sth, imp_sth, tuples, tuples_status, columns, exe_count)
- SV *sth;
- imp_sth_t *imp_sth;
- SV *tuples;
- SV *tuples_status;
- SV *columns;
- ub4 exe_count;
-{
- dTHX;
- dTHR;
- /*ub4 row_count = 0;*/
- int debug = DBIS->debug;
- D_imp_dbh_from_sth;
- sword status, exe_status;
- int is_select = (imp_sth->stmt_type == OCI_STMT_SELECT);
- AV *tuples_av, *tuples_status_av, *columns_av;
- ub4 oci_mode;
- ub4 num_errs;
- int i,j;
- int autocommit = DBIc_has(imp_dbh,DBIcf_AutoCommit);
- SV **sv_p;
- phs_t **phs;
- SV *sv;
- AV *av;
- int param_count;
- char namebuf[30];
- STRLEN len;
- int outparams = (imp_sth->out_params_av) ? AvFILL(imp_sth->out_params_av)+1 : 0;
- int *utf8_flgs;
-
- if (debug >= 2 || dbd_verbose >=2)
- PerlIO_printf(DBILOGFP, " ora_st_execute_array %s count=%d (%s %s %s)...\n",
- oci_stmt_type_name(imp_sth->stmt_type), exe_count,
- neatsvpv(tuples,0), neatsvpv(tuples_status,0),
- neatsvpv(columns, 0));
-
- if (is_select) {
- croak("ora_st_execute_array(): SELECT statement not supported "
- "for array operation.");
- }
-
- if (imp_sth->has_lobs) {
- croak("ora_st_execute_array(): LOBs not "
- "supported for array operation.");
- }
-
- /* Check that the `tuples' parameter is an array ref, find the length,
- and store it in the statement handle for the OCI callback. */
- if(!SvROK(tuples) || SvTYPE(SvRV(tuples)) != SVt_PVAV) {
- croak("ora_st_execute_array(): Not an array reference.");
- }
- tuples_av = (AV*)SvRV(tuples);
-
- /* Check the `columns' parameter. */
- if(SvTRUE(columns)) {
- if(!SvROK(columns) || SvTYPE(SvRV(columns)) != SVt_PVAV) {
- croak("ora_st_execute_array(): columns not an array peference.");
- }
- columns_av = (AV*)SvRV(columns);
- } else {
- columns_av = NULL;
- }
- /* Check the `tuples_status' parameter. */
- if(SvTRUE(tuples_status)) {
- if(!SvROK(tuples_status) || SvTYPE(SvRV(tuples_status)) != SVt_PVAV) {
- croak("ora_st_execute_array(): tuples_status not an array reference.");
- }
- tuples_status_av = (AV*)SvRV(tuples_status);
- av_fill(tuples_status_av, exe_count - 1);
- /* Fill in 'unknown' exe count in every element (know not how to get
- individual execute row counts from OCI). */
- for(i = 0; (unsigned int) i < exe_count; i++) {
- av_store(tuples_status_av, i, newSViv((IV)-1));
- }
- } else {
- tuples_status_av = NULL;
- }
-
- /* Nothing to do if no tuples. */
- if(exe_count <= 0)
- return 0;
-
- /* Ensure proper OCIBindByName() calls for all placeholders.
- if(!ora_st_bind_for_array_exec(sth, imp_sth, tuples_av, exe_count,
- DBIc_NUM_PARAMS(imp_sth), columns_av))
- return -2;
-
- fix for Perl undefined warning. Moved out of function back out to main code
- Still ensures proper OCIBindByName*/
-
- param_count=DBIc_NUM_PARAMS(imp_sth);
- phs = safemalloc(param_count*sizeof(*phs));
- utf8_flgs = safemalloc(param_count*sizeof(int));
- memset(phs, 0, param_count*sizeof(*phs));
- memset(utf8_flgs, 0, param_count*sizeof(int));
-
-
- for(j = 0; (unsigned int) j < exe_count; j++) {
-
- sv_p = av_fetch(tuples_av, j, 0);
- if(sv_p == NULL) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Cannot fetch tuple %d", j);
- }
- sv = *sv_p;
- if(!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Not an array ref in element %d", j);
- }
- av = (AV*)SvRV(sv);
- for(i = 0; i < param_count; i++) {
- if(!phs[i]) {
- SV **phs_svp;
- sprintf(namebuf, ":p%d", i+1);
- phs_svp = hv_fetch(imp_sth->all_params_hv,
- namebuf, strlen(namebuf), 0);
- if (phs_svp == NULL) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Can't execute for non-existent placeholder :%d", i);
- }
- phs[i] = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */
- if(phs[i]->idx < 0) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Placeholder %d not of ?/:1 type", i);
- }
- init_bind_for_array_exec(phs[i]);
- }
- sv_p = av_fetch(av, phs[i]->idx, 0);
- if(sv_p == NULL) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Cannot fetch value for param %d in entry %d", i, j);
- }
-
- sv = *sv_p;
-
- /*check to see if value sv is a null (undef) if it is upgrade it*/
- if (!SvOK(sv)) {
- if(SvUPGRADE(sv, SVt_PV)){} /* For GCC not to warn on unused result */
- }
- else {
- SvPV(sv, len);
- }
-
-
- /* Find the value length, and increase maxlen if needed. */
- if(SvROK(sv)) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Can't bind a reference (%s) for param %d, entry %d",
- neatsvpv(sv,0), i, j);
- }
- if(len > (unsigned int) phs[i]->maxlen)
- phs[i]->maxlen = len;
-
- /* update the utf8_flgs for this value */
-
- /*PerlIO_printf(DBILOGFP, "\nn in sv=%s...\n",sv);*/
-
-
-
-
- if (SvUTF8(sv)) {
- /*STRLEN len2;
- char* xx;
- xx=SvPVutf8( sv, len2);
- PerlIO_printf(DBILOGFP, " 11xx=%s,len2=%d...\n",xx,len2);
-*/
- utf8_flgs[i] |= ARRAY_BIND_UTF8;
- }
- else {
- /*STRLEN len2;
- char* xx;
- bool is_utf8;
- xx=SvPVutf8( sv, len2);
- PerlIO_printf(DBILOGFP, " xx=%s,len2=%d...\n",xx,len2);
-
- is_utf8=is_utf8_string((U8*)sv,1);
-
- PerlIO_printf(DBILOGFP, "is_utf8=%d...\n",is_utf8);
-*/
-
- utf8_flgs[i] |= ARRAY_BIND_NATIVE;
-
- }
-
-
-
- /* Do OCI bind calls on last iteration. */
- if( ((unsigned int) j ) == exe_count - 1 ) {
- if(!do_bind_array_exec(sth, imp_sth, phs[i], utf8_flgs[i])) {
- Safefree(phs);
- Safefree(utf8_flgs);
- }
- }
- }
- }
- Safefree(phs);
- Safefree(utf8_flgs);
-
- /* Store array of bind typles, for use in OCIBindDynamic() callback. */
- imp_sth->bind_tuples = tuples_av;
- imp_sth->rowwise = (columns_av == NULL);
-
- oci_mode = OCI_BATCH_ERRORS;
- if(autocommit)
- oci_mode |= OCI_COMMIT_ON_SUCCESS;
-
- OCIStmtExecute_log_stat(imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp,
- exe_count, 0, 0, 0, oci_mode, exe_status);
-
- imp_sth->bind_tuples = NULL;
-
- if (exe_status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, exe_status, ora_sql_error(imp_sth,"OCIStmtExecute"));
- if(exe_status != OCI_SUCCESS_WITH_INFO)
- return -2;
- }
-
- if (outparams){
- i=outparams;
- while(--i >= 0) {
- phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]);
- SV *sv = phs->sv;
- if (SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVAV) {
- AV *av = (AV*)SvRV(sv);
- I32 avlen = AvFILL(av);
- for (j=0;j<=avlen;j++){
- SV *sv2 = *av_fetch(av, j, 1);
- dbd_phs_avsv_complete(phs, j, debug);
- }
- }
- }
- }
-
- OCIAttrGet_stmhp_stat(imp_sth, &num_errs, 0, OCI_ATTR_NUM_DML_ERRORS, status);
-
- if (debug >= 6 || dbd_verbose >= 6)
- PerlIO_printf(DBILOGFP, " ora_st_execute_array %d errors in batch.\n",
- num_errs);
-
- if(num_errs && tuples_status_av) {
- OCIError *row_errhp, *tmp_errhp;
- ub4 row_off;
- SV *err_svs[2];
- /*AV *err_av;*/
- sb4 err_code;
-
- err_svs[0] = newSViv((IV)0);
- err_svs[1] = newSVpvn("", 0);
- 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++) {
- OCIParamGet_log_stat(imp_sth->errhp, OCI_HTYPE_ERROR,
- tmp_errhp, (dvoid *)&row_errhp,
- (ub4)i, status);
- OCIAttrGet_log_stat(row_errhp, OCI_HTYPE_ERROR, &row_off, 0,
- OCI_ATTR_DML_ROW_OFFSET, imp_sth->errhp, status);
- if (debug >= 6 || dbd_verbose >= 6)
- PerlIO_printf(DBILOGFP, " ora_st_execute_array error in row %d.\n",
- row_off);
- sv_setpv(err_svs[1], "");
- 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))));
- }
- OCIHandleFree_log_stat(tmp_errhp, OCI_HTYPE_ERROR, status);
- OCIHandleFree_log_stat(row_errhp, OCI_HTYPE_ERROR, status);
-
- /* Do a commit here if autocommit is set, since Oracle
- doesn't do that for us when some rows are in error. */
- if(autocommit) {
- OCITransCommit_log_stat(imp_sth->svchp, imp_sth->errhp,
- OCI_DEFAULT, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCITransCommit");
- return -2;
- }
- }
- }
-
- 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;
- }
-}
-
-
-
-
-int
-dbd_st_blob_read(SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset)
-{
- dTHX;
- ub4 retl = 0;
- SV *bufsv;
- imp_fbh_t *fbh = &imp_sth->fbh[field];
- int ftype = fbh->ftype;
-
- bufsv = SvRV(destrv);
- sv_setpvn(bufsv,"",0); /* ensure it's writable string */
-
-#ifdef UTF8_SUPPORT
- if (ftype == 112 && CS_IS_UTF8(ncharsetid) ) {
- return ora_blob_read_mb_piece(sth, imp_sth, fbh, bufsv,
- offset, len, destoffset);
- }
-#endif /* UTF8_SUPPORT */
-
- SvGROW(bufsv, (STRLEN)destoffset+len+1); /* SvGROW doesn't do +1 */
-
- retl = ora_blob_read_piece(sth, imp_sth, fbh, bufsv,
- offset, len, destoffset);
- if (!SvOK(bufsv)) { /* ora_blob_read_piece recorded error */
- ora_free_templob(sth, imp_sth, (OCILobLocator*)fbh->desc_h);
- return 0;
- }
- ftype = ftype; /* no unused */
-
- if (DBIS->debug >= 3 || dbd_verbose >=3)
- PerlIO_printf(DBILOGFP,
- " blob_read field %d+1, ftype %d, offset %ld, len %ld, destoffset %ld, retlen %ld\n",
- field, imp_sth->fbh[field].ftype, offset, len, destoffset, (long)retl);
-
- SvCUR_set(bufsv, destoffset+retl);
-
- *SvEND(bufsv) = '\0'; /* consistent with perl sv_setpvn etc */
-
- return 1;
-}
-
-
-int
-dbd_st_rows(SV *sth, imp_sth_t *imp_sth)
-{
- dTHX;
- ub4 row_count = 0;
- sword status;
- OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIAttrGet OCI_ATTR_ROW_COUNT");
- return -1;
- }
- return row_count;
-}
-
-
-int
-dbd_st_finish(SV *sth, imp_sth_t *imp_sth)
-{
- dTHR;
- dTHX;
- D_imp_dbh_from_sth;
- sword status;
- int num_fields = DBIc_NUM_FIELDS(imp_sth);
- int i;
-
-
- if (DBIc_DBISTATE(imp_sth)->debug >= 6 || dbd_verbose >= 6)
- PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_st_finish\n");
-
- if (!DBIc_ACTIVE(imp_sth))
- return 1;
-
- /* Cancel further fetches from this cursor. */
- /* We don't close the cursor till DESTROY (dbd_st_destroy). */
- /* The application may re execute(...) it. */
-
- /* Turn off ACTIVE here regardless of errors below. */
- DBIc_ACTIVE_off(imp_sth);
-
- for(i=0; i < num_fields; ++i) {
- imp_fbh_t *fbh = &imp_sth->fbh[i];
- if (fbh->fetch_cleanup) fbh->fetch_cleanup(sth, fbh);
- }
-
- if (dirty) /* don't walk on the wild side */
- return 1;
-
- if (!DBIc_ACTIVE(imp_dbh)) /* no longer connected */
- return 1;
-
- /*fetching on a cursor with row =0 will explicitly free any
- server side resources this is what the next statment does,
- not sure if we need this for non scrolling cursors they should die on
- a OER(1403) no records)*/
-
- OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0,
- OCI_FETCH_NEXT,0, status);
-
- if (status != OCI_SUCCESS && status != OCI_SUCCESS_WITH_INFO) {
- oci_error(sth, imp_sth->errhp, status, "Finish OCIStmtFetch");
- return 0;
- }
- return 1;
-}
-
-
-void
-ora_free_fbh_contents(imp_fbh_t *fbh)
-{
- dTHX;
- if (fbh->fb_ary)
- fb_ary_free(fbh->fb_ary);
- sv_free(fbh->name_sv);
- if (fbh->desc_h)
- OCIDescriptorFree_log(fbh->desc_h, fbh->desc_t);
- if (fbh->obj)
- Safefree(fbh->obj);
-
-}
-
-void
-ora_free_phs_contents(phs_t *phs)
-{
- dTHX;
- if (phs->desc_h)
- OCIDescriptorFree_log(phs->desc_h, phs->desc_t);
- if( phs->array_buf ){
- free(phs->array_buf);
- phs->array_buf=NULL;
- }
- if( phs->array_indicators ){
- free(phs->array_indicators);
- phs->array_indicators=NULL;
- }
- if( phs->array_lengths ){
- free(phs->array_lengths);
- phs->array_lengths=NULL;
- }
-
- phs->array_buflen=0;
- phs->array_numallocated=0;
- sv_free(phs->ora_field);
- sv_free(phs->sv);
-}
-
-void
-ora_free_templob(SV *sth, imp_sth_t *imp_sth, OCILobLocator *lobloc)
-{
- dTHX;
-#if defined(OCI_HTYPE_DIRPATH_FN_CTX) /* >= 9.0 */
- boolean is_temporary = 0;
- sword status;
- OCILobIsTemporary_log_stat(imp_sth->envhp, imp_sth->errhp, lobloc, &is_temporary, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCILobIsTemporary");
- return;
- }
-
- if (is_temporary) {
- if (DBIS->debug >= 3 || dbd_verbose >=3 ) {
- PerlIO_printf(DBILOGFP, " OCILobFreeTemporary %s\n", oci_status_name(status));
- }
- OCILobFreeTemporary_log_stat(imp_sth->svchp, imp_sth->errhp, lobloc, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCILobFreeTemporary");
- return;
- }
- }
-#endif
-}
-
-
-void
-dbd_st_destroy(SV *sth, imp_sth_t *imp_sth)
-{
- int fields;
- int i;
- sword status;
- dTHX ;
-
- /* Don't free the OCI statement handle for a nested cursor. It will
- be reused by Oracle on the next fetch. Indeed, we never
- free these handles. Experiment shows that Oracle frees them
- when they are no longer needed.
- */
- /* get rid of describe handle if used*/
-
- /* if we are using a scrolling cursor we should get rid of the
- cursor by fetching row 0 */
-
- if (imp_sth->exe_mode==OCI_STMT_SCROLLABLE_READONLY){
- OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0,OCI_FETCH_NEXT,0, status);
- }
-
- if (imp_sth->dschp){
- OCIHandleFree_log_stat(imp_sth->dschp, OCI_HTYPE_DESCRIBE, status);
- }
-
-
- if (DBIc_DBISTATE(imp_sth)->debug >= 6 || dbd_verbose >= 6 )
- PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_st_destroy %s\n",
- (dirty) ? "(OCIHandleFree skipped during global destruction)" :
- (imp_sth->nested_cursor) ?"(OCIHandleFree skipped for nested cursor)" : "");
-
- if (!dirty) { /* XXX not ideal, leak may be a problem in some cases */
- if (!imp_sth->nested_cursor) {
- OCIHandleFree_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, status);
- if (status != OCI_SUCCESS)
- oci_error(sth, imp_sth->errhp, status, "OCIHandleFree");
- }
- }
-
- /* Free off contents of imp_sth */
-
- if (imp_sth->lob_refetch)
- ora_free_lob_refetch(sth, imp_sth);
-
- fields = DBIc_NUM_FIELDS(imp_sth);
- imp_sth->in_cache = 0;
- imp_sth->eod_errno = 1403;
- for(i=0; i < fields; ++i) {
- imp_fbh_t *fbh = &imp_sth->fbh[i];
- ora_free_fbh_contents(fbh);
-
- }
- Safefree(imp_sth->fbh);
- if (imp_sth->fbh_cbuf)
- Safefree(imp_sth->fbh_cbuf);
- Safefree(imp_sth->statement);
-
- if (imp_sth->out_params_av)
- sv_free((SV*)imp_sth->out_params_av);
-
- if (imp_sth->all_params_hv) {
- HV *hv = imp_sth->all_params_hv;
- SV *sv;
- char *key;
- I32 retlen;
- hv_iterinit(hv);
- while( (sv = hv_iternextsv(hv, &key, &retlen)) != NULL ) {
- if (sv != &sv_undef) {
- phs_t *phs = (phs_t*)(void*)SvPVX(sv);
- if (phs->desc_h && phs->desc_t == OCI_DTYPE_LOB)
- ora_free_templob(sth, imp_sth, (OCILobLocator*)phs->desc_h);
-
-
- ora_free_phs_contents(phs);
- }
- }
- sv_free((SV*)imp_sth->all_params_hv);
- }
-
- DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
-
-}
-
-
-int
-dbd_st_STORE_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv)
-{
- dTHX;
- STRLEN kl;
- SV *cachesv = NULL;
- char *key = SvPV(keysv,kl);
- if( imp_sth ) { /* For GCC not to warn on unused argument */}
-/*
- int on = SvTRUE(valuesv);
- int oraperl = DBIc_COMPAT(imp_sth); */
-
- if (strEQ(key, "ora_fetchtest")) {
- ora_fetchtest = SvIV(valuesv);
- }
- else
- return FALSE;
-
- if (cachesv) /* cache value for later DBI 'quick' fetch? */
- hv_store((HV*)SvRV(sth), key, kl, cachesv, 0);
- return TRUE;
-}
-
-
-SV *
-dbd_st_FETCH_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv)
-{
- dTHX;
- STRLEN kl;
- char *key = SvPV(keysv,kl);
- int i;
- SV *retsv = NULL;
- /* Default to caching results for DBI dispatch quick_FETCH */
- int cacheit = TRUE;
- /* int oraperl = DBIc_COMPAT(imp_sth); */
-
- if (kl==13 && strEQ(key, "NUM_OF_PARAMS")) /* handled by DBI */
- return Nullsv;
-
- if (!imp_sth->done_desc && !dbd_describe(sth, imp_sth)) {
- STRLEN lna;
- /* dbd_describe has already called ora_error() */
- /* we can't return Nullsv here because the xs code will */
- /* then just pass the attribute name to DBI for FETCH. */
- croak("Describe failed during %s->FETCH(%s): %ld: %s",
- SvPV(sth,na), key, (long)SvIV(DBIc_ERR(imp_sth)),
- SvPV(DBIc_ERRSTR(imp_sth),lna)
- );
- }
-
- i = DBIc_NUM_FIELDS(imp_sth);
-
- if (kl==4 && strEQ(key, "NAME")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSVpv((char*)imp_sth->fbh[i].name,0));
-
- } else if (kl==11 && strEQ(key, "ParamValues")) {
- HV *pvhv = newHV();
- if (imp_sth->all_params_hv) {
- SV *sv;
- char *key;
- I32 keylen;
- hv_iterinit(imp_sth->all_params_hv);
- while ( (sv = hv_iternextsv(imp_sth->all_params_hv, &key, &keylen)) ) {
- phs_t *phs = (phs_t*)(void*)SvPVX(sv); /* placeholder struct */
- hv_store(pvhv, key, keylen, newSVsv(phs->sv), 0);
- }
- }
- retsv = newRV_noinc((SV*)pvhv);
- cacheit = FALSE;
-
- } else if (kl==11 && strEQ(key, "ora_lengths")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv((IV)imp_sth->fbh[i].disize));
-
- } else if (kl==9 && strEQ(key, "ora_types")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(imp_sth->fbh[i].dbtype));
-
- } else if (kl==4 && strEQ(key, "TYPE")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).dbtype));
-
- } else if (kl==5 && strEQ(key, "SCALE")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).scale));
-
- } else if (kl==9 && strEQ(key, "PRECISION")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).prec));
-
-#ifdef XXX
- } else if (kl==9 && strEQ(key, "ora_rowid")) {
- /* return current _binary_ ROWID (oratype 11) uncached */
- /* Use { ora_type => 11 } when binding to a placeholder */
- retsv = newSVpv((char*)&imp_sth->cda->rid, sizeof(imp_sth->cda->rid));
- cacheit = FALSE;
-#endif
-
- } else if (kl==17 && strEQ(key, "ora_est_row_width")) {
- retsv = newSViv(imp_sth->est_width);
- cacheit = TRUE;
-
- } else if (kl==8 && strEQ(key, "NULLABLE")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, boolSV(imp_sth->fbh[i].nullok));
-
- } else {
- return Nullsv;
- }
- if (cacheit) { /* cache for next time (via DBI quick_FETCH) */
- SV **svp = hv_fetch((HV*)SvRV(sth), key, kl, 1);
- sv_free(*svp);
- *svp = retsv;
- (void)SvREFCNT_inc(retsv); /* so sv_2mortal won't free it */
- }
- return sv_2mortal(retsv);
-}
-
-/* --------------------------------------- */
-
-static sql_fbh_t
-ora2sql_type(imp_fbh_t* fbh) {
- sql_fbh_t sql_fbh;
- sql_fbh.dbtype = fbh->dbtype;
- sql_fbh.prec = fbh->prec;
- sql_fbh.scale = fbh->scale;
-
- switch(fbh->dbtype) { /* oracle Internal (not external) types */
- case SQLT_NUM:
- if (fbh->scale == -127) { /* FLOAT, REAL, DOUBLE_PRECISION */
- sql_fbh.dbtype = SQL_DOUBLE;
- sql_fbh.scale = 0; /* better: undef */
- if (fbh->prec == 0) { /* NUMBER; s. Oracle Bug# 2755842, 2235818 */
- sql_fbh.prec = 126;
- }
- }
- else if (fbh->scale == 0) {
- if (fbh->prec == 0) { /* NUMBER */
- sql_fbh.dbtype = SQL_DOUBLE;
- sql_fbh.prec = 126;
- }
- else { /* INTEGER, NUMBER(p,0) */
- sql_fbh.dbtype = SQL_DECIMAL; /* better: SQL_INTEGER */
- }
- }
- else { /* NUMBER(p,s) */
- sql_fbh.dbtype = SQL_DECIMAL; /* better: SQL_NUMERIC */
- }
- break;
-#ifdef SQLT_IBDOUBLE
- case SQLT_BDOUBLE:
- case SQLT_BFLOAT:
- case SQLT_IBDOUBLE:
- case SQLT_IBFLOAT:
- sql_fbh.dbtype = SQL_DOUBLE;
- sql_fbh.prec = 126;
- break;
-#endif
- case SQLT_CHR: sql_fbh.dbtype = SQL_VARCHAR; break;
- case SQLT_LNG: sql_fbh.dbtype = SQL_LONGVARCHAR; break; /* long */
- case SQLT_DAT: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP;break;
- case SQLT_BIN: sql_fbh.dbtype = SQL_BINARY; break; /* raw */
- case SQLT_LBI: sql_fbh.dbtype = SQL_LONGVARBINARY; break; /* long raw */
- case SQLT_AFC: sql_fbh.dbtype = SQL_CHAR; break; /* Ansi fixed char */
- case SQLT_CLOB: sql_fbh.dbtype = SQL_CLOB; break;
- case SQLT_BLOB: sql_fbh.dbtype = SQL_BLOB; break;
-#ifdef SQLT_TIMESTAMP_TZ
- case SQLT_DATE: sql_fbh.dbtype = SQL_DATE; break;
- case SQLT_TIME: sql_fbh.dbtype = SQL_TIME; break;
- case SQLT_TIME_TZ: sql_fbh.dbtype = SQL_TYPE_TIME_WITH_TIMEZONE; break;
- case SQLT_TIMESTAMP: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP; break;
- case SQLT_TIMESTAMP_TZ: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE; break;
- case SQLT_TIMESTAMP_LTZ: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE; break;
- case SQLT_INTERVAL_YM: sql_fbh.dbtype = SQL_INTERVAL_YEAR_TO_MONTH; break;
- case SQLT_INTERVAL_DS: sql_fbh.dbtype = SQL_INTERVAL_DAY_TO_SECOND; break;
-#endif
- default: sql_fbh.dbtype = -9000 - fbh->dbtype; /* else map type into DBI reserved standard range */
- }
- return sql_fbh;
-}
-
-static void
-dump_env_to_trace() {
- dTHX;
- PerlIO *fp = DBILOGFP;
- int i = 0;
- char *p;
-#ifndef __BORLANDC__
- extern char **environ;
-#endif
- PerlIO_printf(fp, "Environment variables:\n");
- do {
- p = (char*)environ[i++];
- PerlIO_printf(fp,"\t%s\n",p);
- } while ((char*)environ[i] != '\0');
-}
-
+/*
+ vim: sw=4:ts=8
+ dbdimp.c
+
+ Copyright (c) 1994-2006 Tim Bunce Ireland
+ Copyright (c) 2006-2008 John Scoles (The Pythian Group), Canada
+
+ See the COPYRIGHT section in the Oracle.pm file for terms.
+
+*/
+
+#ifdef WIN32
+#define strcasecmp strcmpi
+#endif
+
+#ifdef __CYGWIN32__
+#include "w32api/windows.h"
+#include "w32api/winbase.h"
+#endif /* __CYGWIN32__ */
+
+#include "Oracle.h"
+
+#if defined(CAN_USE_PRO_C)
+/* #include <sql2oci.h> for SQL_SINGLE_RCTX but causes clashes */
+#if !defined(SQL_SINGLE_RCTX)
+/* http://download-west.oracle.com/docs/cd/B10501_01/appdev.920/a97269/pc_01int.htm#1174 */
+#define SQL_SINGLE_RCTX (dvoid *)0 /* from precomp/public/sqlcpr.h */
+#endif
+#endif
+
+/* XXX DBI should provide a better version of this */
+#define IS_DBI_HANDLE(h) \
+ (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && \
+ SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P')
+
+#ifndef SvPOK_only_UTF8
+#define SvPOK_only_UTF8(sv) SvPOK_only(sv)
+#endif
+
+DBISTATE_DECLARE;
+
+int ora_fetchtest; /* intrnal test only, not thread safe */
+int is_extproc = 0;
+int dbd_verbose = 0; /* DBD only debugging*/
+
+/* bitflag constants for figuring out how to handle utf8 for array binds */
+#define ARRAY_BIND_NATIVE 0x01
+#define ARRAY_BIND_UTF8 0x02
+#define ARRAY_BIND_MIXED (ARRAY_BIND_NATIVE|ARRAY_BIND_UTF8)
+
+ub2 charsetid = 0;
+ub2 ncharsetid = 0;
+ub2 us7ascii_csid = 1;
+ub2 utf8_csid = 871;
+ub2 al32utf8_csid = 873;
+ub2 al16utf16_csid = 2000;
+ub2 we8mswin1252 = 178;
+
+typedef struct sql_fbh_st sql_fbh_t;
+struct sql_fbh_st {
+ int dbtype;
+ int prec;
+ int scale;
+};
+static sql_fbh_t ora2sql_type _((imp_fbh_t* fbh));
+
+void ora_free_phs_contents _((phs_t *phs));
+static void dump_env_to_trace();
+
+static sb4
+oci_error_get(OCIError *errhp, sword status, char *what, SV *errstr, int debug)
+{
+ dTHX;
+ text errbuf[1024];
+ ub4 recno = 0;
+ sb4 errcode = 0;
+ sb4 eg_errcode = 0;
+ sword eg_status;
+ if (!SvOK(errstr))
+ sv_setpv(errstr,"");
+ if (!errhp) {
+ sv_catpv(errstr, oci_status_name(status));
+ if (what) {
+ sv_catpv(errstr, " ");
+ sv_catpv(errstr, what);
+ }
+ return status;
+ }
+
+ while( ++recno
+ && OCIErrorGet_log_stat(errhp, recno, (text*)NULL, &eg_errcode, errbuf,
+ (ub4)sizeof(errbuf), OCI_HTYPE_ERROR, eg_status) != OCI_NO_DATA
+ && eg_status != OCI_INVALID_HANDLE
+ && recno < 100
+ ) {
+ if (debug >= 4 || recno>1/*XXX temp*/ || dbd_verbose >= 4)
+ PerlIO_printf(DBILOGFP, " OCIErrorGet after %s (er%ld:%s): %d, %ld: %s\n",
+ what ? what : "<NULL>", (long)recno,
+ (eg_status==OCI_SUCCESS) ? "ok" : oci_status_name(eg_status),
+ status, (long)eg_errcode, errbuf);
+ errcode = eg_errcode;
+ sv_catpv(errstr, (char*)errbuf);
+ if (*(SvEND(errstr)-1) == '\n')
+ --SvCUR(errstr);
+ }
+ if (what || status != OCI_ERROR) {
+ sv_catpv(errstr, (debug<0) ? " (" : " (DBD ");
+ sv_catpv(errstr, oci_status_name(status));
+ if (what) {
+ sv_catpv(errstr, ": ");
+ sv_catpv(errstr, what);
+ }
+ sv_catpv(errstr, ")");
+ }
+ return errcode;
+}
+
+static int
+GetRegKey(char *key, char *val, char *data, unsigned long *size)
+{
+#ifdef WIN32
+ unsigned long len = *size - 1;
+ HKEY hKey;
+ long ret;
+
+ ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, key, 0, KEY_QUERY_VALUE, &hKey);
+ if (ret != ERROR_SUCCESS)
+ return 0;
+ ret = RegQueryValueEx(hKey, val, NULL, NULL, data, size);
+ RegCloseKey(hKey);
+ if ((ret != ERROR_SUCCESS) || (*size >= len))
+ return 0;
+ return 1;
+#else
+ /* For gcc not to warn on unused parameters. */
+ if( key ){}
+ if( val ){}
+ if( data ){}
+ if( size ){}
+ return 0;
+#endif
+}
+
+char *
+ora_env_var(char *name, char *buf, unsigned long size)
+{
+#define WIN32_REG_BUFSIZE 80
+ dTHX;
+ char last_home_id[WIN32_REG_BUFSIZE+1];
+ char ora_home_key[WIN32_REG_BUFSIZE+1];
+ unsigned long len = WIN32_REG_BUFSIZE;
+ char *e = getenv(name);
+ if (e)
+ return e;
+ if (!GetRegKey("SOFTWARE\\ORACLE\\ALL_HOMES", "LAST_HOME", last_home_id, &len))
+ return Nullch;
+ last_home_id[2] = 0;
+ sprintf(ora_home_key, "SOFTWARE\\ORACLE\\HOME%s", last_home_id);
+ size -= 1; /* allow room for null termination */
+ if (!GetRegKey(ora_home_key, name, buf, &size))
+ return Nullch;
+ buf[size] = 0;
+ return buf;
+}
+
+#ifdef __CYGWIN32__
+/* Under Cygwin there are issues with setting environment variables
+ * at runtime such that Windows-native libraries loaded by a Cygwin
+ * process can see those changes.
+ *
+ * Cygwin maintains its own cache of environment variables, and also
+ * only writes to the Windows environment using the "_putenv" win32
+ * call. This call writes to a Windows C runtime cache, rather than
+ * the true process environment block.
+ *
+ * In order to change environment variables so that the Oracle client
+ * DLL can see the change, the win32 function SetEnvironmentVariable
+ * must be called. This function gives an interface to that API.
+ *
+ * It is only available when building under Cygwin, and is used by
+ * the testsuite.
+ *
+ * Whilst it could be called by end users, it should be used with
+ * caution, as it bypasses the environment variable conversions that
+ * Cygwin typically performs.
+ */
+void
+ora_cygwin_set_env(char *name, char *value)
+{
+ SetEnvironmentVariable(name, value);
+}
+#endif /* __CYGWIN32__ */
+
+void
+dbd_init(dbistate_t *dbistate)
+{
+ dTHX;
+ DBIS = dbistate;
+ dbd_init_oci(dbistate);
+}
+
+
+int
+dbd_discon_all(SV *drh, imp_drh_t *imp_drh)
+{
+ dTHR;
+ dTHX;
+ /* The disconnect_all concept is flawed and needs more work */
+ if (!dirty && !SvTRUE(perl_get_sv("DBI::PERL_ENDING",0))) {
+ DBIh_SET_ERR_CHAR(drh, (imp_xxh_t*)imp_drh, Nullch, 1, "disconnect_all not implemented", Nullch, Nullch);
+ return FALSE;
+ }
+ return FALSE;
+}
+
+
+
+void
+dbd_fbh_dump(imp_fbh_t *fbh, int i, int aidx)
+{
+ dTHX;
+ PerlIO *fp = DBILOGFP;
+ PerlIO_printf(fp, " fbh %d: '%s'\t%s, ",
+ i, fbh->name, (fbh->nullok) ? "NULLable" : "NO null ");
+ PerlIO_printf(fp, "otype %3d->%3d, dbsize %ld/%ld, p%d.s%d\n",
+ fbh->dbtype, fbh->ftype, (long)fbh->dbsize,(long)fbh->disize,
+ fbh->prec, fbh->scale);
+ if (fbh->fb_ary) {
+ PerlIO_printf(fp, " out: ftype %d, bufl %d. indp %d, rlen %d, rcode %d\n",
+ fbh->ftype, fbh->fb_ary->bufl, fbh->fb_ary->aindp[aidx],
+ fbh->fb_ary->arlen[aidx], fbh->fb_ary->arcode[aidx]);
+ }
+}
+
+
+int
+ora_dbtype_is_long(int dbtype)
+{
+ /* Is it a LONG, LONG RAW, LONG VARCHAR or LONG VARRAW type? */
+ /* Return preferred type code to use if it's a long, else 0. */
+ if (dbtype == 8 || dbtype == 24) /* LONG or LONG RAW */
+ return dbtype; /* --> same */
+ if (dbtype == 94) /* LONG VARCHAR */
+ return 8; /* --> LONG */
+ if (dbtype == 95) /* LONG VARRAW */
+ return 24; /* --> LONG RAW */
+ return 0;
+}
+
+static int
+oratype_bind_ok(int dbtype) /* It's a type we support for placeholders */
+{
+ /* basically we support types that can be returned as strings */
+ switch(dbtype) {
+ case 1: /* VARCHAR2 */
+ case 2: /* NVARCHAR2 */
+ case 5: /* STRING */
+ case 8: /* LONG */
+ case 21: /* BINARY FLOAT os-endian */
+ case 22: /* BINARY DOUBLE os-endian */
+ case 23: /* RAW */
+ case 24: /* LONG RAW */
+ case 96: /* CHAR */
+ case 97: /* CHARZ */
+ case 100: /* BINARY FLOAT oracle-endian */
+ case 101: /* BINARY DOUBLE oracle-endian */
+ case 106: /* MLSLABEL */
+ case 102: /* SQLT_CUR OCI 7 cursor variable */
+ case 112: /* SQLT_CLOB / long */
+ case 113: /* SQLT_BLOB / long */
+ case 116: /* SQLT_RSET OCI 8 cursor variable */
+ case ORA_VARCHAR2_TABLE: /* 201 */
+ case ORA_NUMBER_TABLE: /* 202 */
+ case ORA_XMLTYPE: /* SQLT_NTY must be carefull here as its value (108) is the same for an embedded object Well realy only XML clobs not embedded objects */
+ return 1;
+ }
+ return 0;
+}
+
+
+/* --- allocate and free oracle oci 'array' buffers --- */
+
+/* --- allocate and free oracle oci 'array' buffers for callback--- */
+
+fb_ary_t *
+fb_ary_cb_alloc(ub4 piece_size, ub4 max_len, int size)
+{
+ fb_ary_t *fb_ary;
+ /* these should be reworked to only to one Newz() */
+ /* and setup the pointers in the head fb_ary struct */
+ Newz(42, fb_ary, sizeof(fb_ary_t), fb_ary_t);
+ Newz(42, fb_ary->abuf, size * piece_size, ub1);
+ Newz(42, fb_ary->cb_abuf, size * max_len, ub1);
+ Newz(42, fb_ary->aindp, (unsigned)size, sb2);
+ Newz(42, fb_ary->arlen, (unsigned)size, ub2);
+ Newz(42, fb_ary->arcode, (unsigned)size, ub2);
+ fb_ary->bufl = piece_size;
+ fb_ary->cb_bufl = max_len;
+ return fb_ary;
+}
+
+
+/* --- allocate and free oracle oci 'array' buffers --- */
+
+fb_ary_t *
+fb_ary_alloc(ub4 bufl, int size)
+{
+ fb_ary_t *fb_ary;
+ /* these should be reworked to only to one Newz() */
+ /* and setup the pointers in the head fb_ary struct */
+ Newz(42, fb_ary, sizeof(fb_ary_t), fb_ary_t);
+ Newz(42, fb_ary->abuf, size * bufl, ub1);
+ Newz(42, fb_ary->aindp, (unsigned)size, sb2);
+ Newz(42, fb_ary->arlen, (unsigned)size, ub2);
+ Newz(42, fb_ary->arcode, (unsigned)size, ub2);
+ fb_ary->bufl = bufl;
+ /* fb_ary->cb_bufl = bufl;*/
+ return fb_ary;
+}
+
+void
+fb_ary_free(fb_ary_t *fb_ary)
+{
+ Safefree(fb_ary->abuf);
+ Safefree(fb_ary->aindp);
+ Safefree(fb_ary->arlen);
+ Safefree(fb_ary->arcode);
+ Safefree(fb_ary->cb_abuf);
+ Safefree(fb_ary);
+
+}
+
+
+/* ================================================================== */
+
+
+int
+dbd_db_login(SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd)
+{
+ return dbd_db_login6(dbh, imp_dbh, dbname, uid, pwd, Nullsv);
+}
+
+
+/* from shared.xs */
+typedef struct {
+ SV *sv; /* The actual SV - in shared space */
+ /* we don't need the following two */
+ /*recursive_lock_t lock; */
+ /*perl_cond user_cond;*/ /* For user-level conditions */
+} shared_sv;
+
+
+
+int
+dbd_db_login6(SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd, SV *attr)
+{
+ dTHR;
+ dTHX;
+ sword status;
+ SV **svp;
+ shared_sv * shared_dbh_ssv = NULL ;
+ imp_dbh_t * shared_dbh = NULL ;
+#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
+ SV ** shared_dbh_priv_svp ;
+ SV * shared_dbh_priv_sv ;
+ STRLEN shared_dbh_len = 0 ;
+#endif
+ struct OCIExtProcContext *this_ctx;
+ ub4 use_proc_connection = 0;
+ SV **use_proc_connection_sv;
+ D_imp_drh_from_dbh;
+ ub2 new_charsetid = 0;
+ ub2 new_ncharsetid = 0;
+ /* check to see if DBD_verbose or ora_verbose is set*/
+ if (DBD_ATTRIB_TRUE(attr,"dbd_verbose",11,svp))
+ DBD_ATTRIB_GET_IV( attr, "dbd_verbose", 11, svp, dbd_verbose);
+ if (DBD_ATTRIB_TRUE(attr,"ora_verbose",11,svp))
+ DBD_ATTRIB_GET_IV( attr, "ora_verbose", 11, svp, dbd_verbose);
+ /* dbi_imp_data code adapted from DBD::mysql */
+ if (DBIc_has(imp_dbh, DBIcf_IMPSET)) {
+ /* dbi_imp_data from take_imp_data */
+ if (DBIc_has(imp_dbh, DBIcf_ACTIVE)) {
+ if (DBIS->debug >= 2 || dbd_verbose >= 2)
+ PerlIO_printf(DBILOGFP, "dbd_db_login6 skip connect\n");
+ /* tell our parent we've adopted an active child */
+ ++DBIc_ACTIVE_KIDS(DBIc_PARENT_COM(imp_dbh));
+ return 1;
+ }
+ /* not ACTIVE so connect not skipped */
+ if (DBIS->debug >= 2 || dbd_verbose >= 2 )
+ PerlIO_printf(DBILOGFP,
+ "dbd_db_login6 IMPSET but not ACTIVE so connect not skipped\n");
+ }
+ imp_dbh->envhp = imp_drh->envhp; /* will be NULL on first connect */
+
+#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
+ shared_dbh_priv_svp = (DBD_ATTRIB_OK(attr)?hv_fetch((HV*)SvRV(attr), "ora_dbh_share", 13, 0):NULL) ;
+ shared_dbh_priv_sv = shared_dbh_priv_svp?*shared_dbh_priv_svp:NULL ;
+
+ if (shared_dbh_priv_sv && SvROK(shared_dbh_priv_sv))
+ shared_dbh_priv_sv = SvRV(shared_dbh_priv_sv) ;
+
+ if (shared_dbh_priv_sv) {
+ MAGIC * mg ;
+
+ SvLOCK (shared_dbh_priv_sv) ;
+
+ /* some magic from shared.xs (no public api yet :-( */
+ mg = mg_find(shared_dbh_priv_sv, PERL_MAGIC_shared_scalar) ;
+
+ shared_dbh_ssv = (shared_sv * )(mg?mg -> mg_ptr:NULL) ; /*sharedsv_find(*shared_dbh_priv_sv) ;*/
+
+ if (!shared_dbh_ssv)
+ croak ("value of ora_dbh_share must be a scalar that is shared") ;
+
+ shared_dbh = (imp_dbh_t *)SvPVX(shared_dbh_ssv -> sv) ;
+ shared_dbh_len = SvCUR((shared_dbh_ssv -> sv)) ;
+
+ if (shared_dbh_len > 0 && shared_dbh_len != sizeof (imp_dbh_t))
+ croak ("Invalid value for ora_dbh_dup") ;
+
+ if (shared_dbh_len == sizeof (imp_dbh_t)) {
+ /* initialize from shared data */
+ memcpy (((char *)imp_dbh) + DBH_DUP_OFF, ((char *)shared_dbh) + DBH_DUP_OFF, DBH_DUP_LEN) ;
+ shared_dbh -> refcnt++ ;
+ imp_dbh -> shared_dbh_priv_sv = shared_dbh_priv_sv ;
+ imp_dbh -> shared_dbh = shared_dbh ;
+ if (DBIS->debug >= 2 || dbd_verbose >= 2)
+ PerlIO_printf(DBILOGFP, " dbd_db_login: use shared Oracle database handles.\n");
+ } else {
+ shared_dbh = NULL ;
+ }
+ }
+#endif
+
+ /* Check if we should re-use a ProC connection and not connect ourselves. */
+
+ DBD_ATTRIB_GET_IV(attr, "ora_use_proc_connection", 23,
+ use_proc_connection_sv, use_proc_connection);
+
+ imp_dbh->get_oci_handle = oci_db_handle;
+
+ if (DBIS->debug >= 6 || dbd_verbose >= 7)
+ dump_env_to_trace();
+
+ if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_envhp", 9)) && SvOK(*svp)) {
+ if (!SvTRUE(*svp)) {
+ imp_dbh->envhp = NULL; /* force new environment */
+ }
+ else {
+ IV tmp;
+ if (!sv_isa(*svp, "ExtProc::OCIEnvHandle"))
+ croak("ora_envhp value is not of type ExtProc::OCIEnvHandle");
+ tmp = SvIV((SV*)SvRV(*svp));
+ imp_dbh->envhp = (struct OCIEnv *)tmp;
+ }
+ }
+
+ /* "extproc" dbname is special if "ora_context" attribute also given */
+ if (strEQ(dbname,"extproc") && (svp=DBD_ATTRIB_GET_SVP(attr, "ora_context", 11))) {
+ IV tmp;
+ SV **svcsvp;
+ SV **errsvp;
+ if (!svp)
+ croak("pointer to context SV is NULL");
+ if (!sv_isa(*svp, "ExtProc::OCIExtProcContext"))
+ croak("ora_context value is not of type ExtProc::OCIExtProcContext");
+ tmp = SvIV((SV*)SvRV(*svp));
+ this_ctx = (struct OCIExtProcContext *)tmp;
+ if (this_ctx == NULL)
+ croak("ora_context referenced ExtProc value is NULL");
+ /* new */
+ if ((svcsvp=DBD_ATTRIB_GET_SVP(attr, "ora_svchp", 9)) &&
+ (errsvp=DBD_ATTRIB_GET_SVP(attr, "ora_errhp", 9))
+ ) {
+ if (!sv_isa(*svcsvp, "ExtProc::OCISvcHandle"))
+ croak("ora_svchp value is not of type ExtProc::OCISvcHandle");
+ tmp = SvIV((SV*)SvRV(*svcsvp));
+ imp_dbh->svchp = (struct OCISvcCtx *)tmp;
+ if (!sv_isa(*errsvp, "ExtProc::OCIErrHandle"))
+ croak("ora_errhp value is not of type ExtProc::OCIErrHandle");
+ tmp = SvIV((SV*)SvRV(*errsvp));
+ imp_dbh->errhp = (struct OCIError *)tmp;
+ }
+ /* end new */
+ else {
+ status = OCIExtProcGetEnv(this_ctx, &imp_dbh->envhp,
+ &imp_dbh->svchp, &imp_dbh->errhp);
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, (OCIError*)imp_dbh->envhp, status, "OCIExtProcGetEnv");
+ return 0;
+ }
+ }
+ is_extproc = 1;
+ goto dbd_db_login6_out;
+ }
+
+ if (!imp_dbh->envhp || is_extproc) {
+ SV **init_mode_sv;
+ ub4 init_mode = OCI_OBJECT; /* needed for LOBs (8.0.4) */
+ DBD_ATTRIB_GET_IV(attr, "ora_init_mode",13, init_mode_sv, init_mode);
+
+#if defined(USE_ITHREADS) || defined(MULTIPLICITY) || defined(USE_5005THREADS)
+ init_mode |= OCI_THREADED;
+#endif
+
+ if (use_proc_connection) {
+ char *err_hint = Nullch;
+#ifdef SQL_SINGLE_RCTX
+ /* Use existing SQLLIB connection. Do not call OCIInitialize(), */
+ /* since presumably SQLLIB already did that. */
+ status = SQLEnvGet(SQL_SINGLE_RCTX, &imp_dbh->envhp);
+ imp_dbh->proc_handles = 1;
+#else
+ status = OCI_ERROR;
+ err_hint = "ProC connection reuse not available in this build of DBD::Oracle";
+#endif /* SQL_SINGLE_RCTX*/
+ if (status != SQL_SUCCESS) {
+ if (!err_hint)
+ err_hint = "SQLEnvGet failed to load ProC environment";
+ oci_error(dbh, NULL, status, err_hint);
+ return 0;
+ }
+ }
+ else { /* Normal connect. */
+
+ size_t rsize = 0;
+ imp_dbh->proc_handles = 0;
+
+#ifdef NEW_OCI_INIT /* XXX needs merging into use_proc_connection branch */
+
+ /* Get CLIENT char and nchar charset id values */
+ OCINlsEnvironmentVariableGet_log_stat( &charsetid, 0, OCI_NLS_CHARSET_ID, 0, &rsize ,status );
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, NULL, status,
+ "OCINlsEnvironmentVariableGet(OCI_NLS_CHARSET_ID) Check NLS settings etc.");
+ return 0;
+ }
+
+ OCINlsEnvironmentVariableGet_log_stat( &ncharsetid, 0, OCI_NLS_NCHARSET_ID, 0, &rsize ,status );
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, NULL, status,
+ "OCINlsEnvironmentVariableGet(OCI_NLS_NCHARSET_ID) Check NLS settings etc.");
+ return 0;
+ }
+
+ /*{
+ After using OCIEnvNlsCreate() to create the environment handle,
+ **the actual lengths and returned lengths of bind and define handles are
+ always in number of bytes**. This applies to the following calls:
+
+ * OCIBindByName() * OCIBindByPos() * OCIBindDynamic()
+ * OCIDefineByPos() * OCIDefineDynamic()
+
+ This function enables you to set charset and ncharset ids at
+ environment creation time. [...]
+
+ This function sets nonzero charset and ncharset as client side
+ database and national character sets, replacing the ones specified
+ by NLS_LANG and NLS_NCHAR. When charset and ncharset are 0, it
+ behaves exactly the same as OCIEnvCreate(). Specifically, charset
+ controls the encoding for metadata and data with implicit form
+ attribute and ncharset controls the encoding for data with SQLCS_NCHAR
+ form attribute.
+ }*/
+
+ OCIEnvNlsCreate_log_stat( &imp_dbh->envhp, init_mode, 0, NULL, NULL, NULL, 0, 0,
+ charsetid, ncharsetid, status );
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, NULL, status,
+ "OCIEnvNlsCreate. Check ORACLE_HOME (Linux) env var or PATH (Windows) and or NLS settings, permissions, etc.");
+ return 0;
+ }
+
+ svp = DBD_ATTRIB_GET_SVP(attr, "ora_charset", 11);/*get the charset passed in by the user*/
+ if (svp) {
+ if (!SvPOK(*svp)) {
+ croak("ora_charset is not a string");
+ }
+
+ new_charsetid = OCINlsCharSetNameToId(imp_dbh->envhp, (oratext*)SvPV_nolen(*svp));
+
+ if (!new_charsetid) {
+ croak("ora_charset value (%s) is not valid", SvPV_nolen(*svp));
+ }
+ }
+
+ svp = DBD_ATTRIB_GET_SVP(attr, "ora_ncharset", 12); /*get the ncharset passed in by the user*/
+
+ if (svp) {
+ if (!SvPOK(*svp)) {
+ croak("ora_ncharset is not a string");
+ }
+
+ new_ncharsetid = OCINlsCharSetNameToId(imp_dbh->envhp, (oratext*)SvPV_nolen(*svp));
+ if (!new_ncharsetid) {
+ croak("ora_ncharset value (%s) is not valid", SvPV_nolen(*svp));
+ }
+ }
+
+ if (new_charsetid || new_ncharsetid) { /* reset the ENV with the new charset from above*/
+ if (new_charsetid) charsetid = new_charsetid;
+ if (new_ncharsetid) ncharsetid = new_ncharsetid;
+ imp_dbh->envhp = NULL;
+ OCIEnvNlsCreate_log_stat( &imp_dbh->envhp, init_mode, 0, NULL, NULL, NULL, 0, 0,
+ charsetid, ncharsetid, status );
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, NULL, status,
+ "OCIEnvNlsCreate. Check ORACLE_HOME (Linux) env var or PATH (Windows) and or NLS settings, permissions, etc");
+ return 0;
+ }
+ }
+
+ /* update the hard-coded csid constants for unicode charsets */
+ utf8_csid = OCINlsCharSetNameToId(imp_dbh->envhp, (void*)"UTF8");
+ al32utf8_csid = OCINlsCharSetNameToId(imp_dbh->envhp, (void*)"AL32UTF8");
+ al16utf16_csid = OCINlsCharSetNameToId(imp_dbh->envhp, (void*)"AL16UTF16");
+ we8mswin1252 = OCINlsCharSetNameToId(imp_dbh->envhp, (void*)"we8mswin1252");
+#else /* (the old init code) NEW_OCI_INIT */
+ /* this is now depricated and will be removed as we no longer support <9.2 oracle*/
+ /* XXX recent oracle docs recommend using OCIEnvCreate() instead of */
+ /* OCIInitialize + OCIEnvInit, we'd need ifdef's for pre-OCIEnvNlsCreate */
+ OCIInitialize_log_stat(init_mode, 0, 0,0,0, status);
+
+
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, NULL, status,
+ "OCIInitialize. Check Check ORACLE_HOME (Linux) env var or PATH (Windows) and or NLS settings, permissions, etc");
+ return 0;
+ }
+
+ OCIEnvInit_log_stat( &imp_dbh->envhp, OCI_DEFAULT, 0, 0, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, (OCIError*)imp_dbh->envhp, status, "OCIEnvInit");
+ return 0;
+ }
+#endif /* NEW_OCI_INIT */
+ }
+ }
+
+ if (shared_dbh_ssv) { /*is this a cached or shared handle from DBI*/
+ if (!imp_dbh->envhp) { /*no hande so create a new one*/
+ if (use_proc_connection) {
+ char *err_hint = Nullch;
+#ifdef SQL_SINGLE_RCTX
+ status = SQLEnvGet(SQL_SINGLE_RCTX, &imp_dbh->envhp);
+ imp_dbh->proc_handles = 1;
+#else
+ status = OCI_ERROR;
+ err_hint = "ProC connection reuse not available in this build of DBD::Oracle";
+#endif /* SQL_SINGLE_RCTX*/
+ if (status != SQL_SUCCESS) {
+ if (!err_hint)
+ err_hint = "SQLEnvGet failed to load ProC environment";
+ oci_error(dbh, (OCIError*)imp_dbh->envhp, status, err_hint);
+ return 0;
+ }
+ }
+ else {
+ OCIEnvInit_log_stat( &imp_dbh->envhp, OCI_DEFAULT, 0, 0, status);
+ imp_dbh->proc_handles = 0;
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, (OCIError*)imp_dbh->envhp, status, "OCIEnvInit");
+ return 0;
+ }
+ }
+ }
+ }
+ OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->errhp, OCI_HTYPE_ERROR, status);
+
+#ifndef NEW_OCI_INIT /* have to get charsetid & ncharsetid the old way this code should go as well as it is for <9.2 oracle*/
+
+ OCIAttrGet_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, &charsetid, (ub4)0 ,
+ OCI_ATTR_ENV_CHARSET_ID, imp_dbh->errhp, status);
+
+
+
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status, "OCIAttrGet OCI_ATTR_ENV_CHARSET_ID");
+ return 0;
+ }
+ OCIAttrGet_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, &ncharsetid, (ub4)0 ,
+ OCI_ATTR_ENV_NCHARSET_ID, imp_dbh->errhp, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status, "OCIAttrGet OCI_ATTR_ENV_NCHARSET_ID");
+ return 0;
+ }
+#endif
+
+ /* At this point we have charsetid & ncharsetid
+ * note that it is possible for charsetid and ncharestid to
+ * be distinct if NLS_LANG and NLS_NCHAR are both used.
+ * BTW: NLS_NCHAR is set as follows: NSL_LANG=AL32UTF8
+ */
+
+
+
+
+ if (DBIS->debug >= 3 || dbd_verbose >= 3) {
+ oratext charsetname[OCI_NLS_MAXBUFSZ];
+ oratext ncharsetname[OCI_NLS_MAXBUFSZ];
+
+ OCINlsCharSetIdToName(imp_dbh->envhp,charsetname, sizeof(charsetname),charsetid );
+ OCINlsCharSetIdToName(imp_dbh->envhp,ncharsetname, sizeof(ncharsetname),ncharsetid );
+ PerlIO_printf(DBILOGFP," charset id=%d, name=%s, ncharset id=%d, name=%s"
+ " (csid: utf8=%d al32utf8=%d)\n",
+ charsetid,charsetname, ncharsetid,ncharsetname, utf8_csid, al32utf8_csid);
+ }
+
+
+ if (!shared_dbh) {
+ if(use_proc_connection) {
+#ifdef SQL_SINGLE_RCTX
+
+ imp_dbh->proc_handles = 1;
+ status = SQLSvcCtxGet(SQL_SINGLE_RCTX, dbname, strlen(dbname),
+ &imp_dbh->svchp);
+ if (status != SQL_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status, "SQLSvcCtxGet");
+ OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
+ return 0;
+ }
+
+ OCIAttrGet_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, &imp_dbh->srvhp, NULL,
+ OCI_ATTR_SERVER, imp_dbh->errhp, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status,
+ "OCIAttrGet. Failed to get server context.");
+ OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
+ return 0;
+ }
+
+ OCIAttrGet_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, &imp_dbh->authp, NULL,
+ OCI_ATTR_SESSION, imp_dbh->errhp, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status,
+ "OCIAttrGet. Failed to get authentication context.");
+ OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
+ return 0;
+ }
+#else /* SQL_SINGLE_RCTX */
+ oci_error(dbh, (OCIError*)imp_dbh->envhp, OCI_ERROR,
+ "ProC connection reuse not available in this build of DBD::Oracle");
+#endif /* SQL_SINGLE_RCTX*/
+ }
+ else { /* !use_proc_connection */
+ imp_dbh->proc_handles = 0;
+
+ OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
+ OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
+ OCIServerAttach_log_stat(imp_dbh, dbname,OCI_DEFAULT, status);
+
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status, "OCIServerAttach");
+ OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
+ OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
+ OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
+ OCIHandleFree_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, status);
+ return 0;
+ }
+ OCIAttrSet_log_stat( imp_dbh->svchp, OCI_HTYPE_SVCCTX, imp_dbh->srvhp,
+ (ub4) 0, OCI_ATTR_SERVER, imp_dbh->errhp, status);
+ OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->authp, OCI_HTYPE_SESSION, status);
+
+ {
+ ub4 cred_type = ora_parse_uid(imp_dbh, &uid, &pwd);
+ SV **sess_mode_type_sv;
+ ub4 sess_mode_type = OCI_DEFAULT;
+ DBD_ATTRIB_GET_IV(attr, "ora_session_mode",16, sess_mode_type_sv, sess_mode_type);
+ OCISessionBegin_log_stat( imp_dbh->svchp, imp_dbh->errhp, imp_dbh->authp,
+ cred_type, sess_mode_type, status);
+
+ }
+ if (status == OCI_SUCCESS_WITH_INFO) {
+ /* eg ORA-28011: the account will expire soon; change your password now */
+ oci_error(dbh, imp_dbh->errhp, status, "OCISessionBegin");
+ status = OCI_SUCCESS;
+ }
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status, "OCISessionBegin");
+ OCIServerDetach_log_stat(imp_dbh->srvhp, imp_dbh->errhp, OCI_DEFAULT, status);
+ OCIHandleFree_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,status);
+ OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
+ OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
+ OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
+ OCIHandleFree_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, status);
+
+ return 0;
+ }
+
+ OCIAttrSet_log_stat(imp_dbh->svchp, (ub4) OCI_HTYPE_SVCCTX,
+ imp_dbh->authp, (ub4) 0,
+ (ub4) OCI_ATTR_SESSION, imp_dbh->errhp, status);
+
+ } /* use_proc_connection */
+ }
+
+dbd_db_login6_out:
+ DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */
+ DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing */
+ imp_dbh->ph_type = 1; /* SQLT_CHR "(ORANET TYPE) character string" */
+ imp_dbh->ph_csform = 0; /* meaning auto (see dbd_rebind_ph) */
+
+ if (!imp_drh->envhp) /* cache first envhp info drh as future default */
+ imp_drh->envhp = imp_dbh->envhp;
+
+#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
+ if (shared_dbh_ssv && !shared_dbh) {
+ /* much of this could be replaced with a single sv_setpvn() */
+ (void)SvUPGRADE(shared_dbh_priv_sv, SVt_PV);
+ SvGROW(shared_dbh_priv_sv, sizeof(imp_dbh_t) + 1) ;
+ SvCUR (shared_dbh_priv_sv) = sizeof(imp_dbh_t) ;
+ imp_dbh->refcnt = 1 ;
+ imp_dbh->shared_dbh_priv_sv = shared_dbh_priv_sv ;
+ memcpy(SvPVX(shared_dbh_priv_sv) + DBH_DUP_OFF, ((char *)imp_dbh) + DBH_DUP_OFF, DBH_DUP_LEN) ;
+ SvSETMAGIC(shared_dbh_priv_sv);
+ imp_dbh->shared_dbh = (imp_dbh_t *)SvPVX(shared_dbh_ssv->sv);
+ }
+#endif
+
+ return 1;
+}
+
+
+int
+dbd_db_commit(SV *dbh, imp_dbh_t *imp_dbh)
+{
+ dTHX;
+ sword status;
+ OCITransCommit_log_stat(imp_dbh->svchp, imp_dbh->errhp, OCI_DEFAULT, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status, "OCITransCommit");
+ return 0;
+ }
+ return 1;
+}
+
+
+
+
+int
+dbd_st_cancel(SV *sth, imp_sth_t *imp_sth)
+{
+ dTHX;
+ sword status;
+ status = OCIBreak(imp_sth->svchp, imp_sth->errhp);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBreak");
+ return 0;
+ }
+
+ /* if we are using a scrolling cursor we should get rid of the
+ cursor by fetching row 0 */
+ if (imp_sth->exe_mode==OCI_STMT_SCROLLABLE_READONLY){
+ OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0,OCI_FETCH_NEXT,0, status);
+ }
+ return 1;
+}
+
+
+
+int
+dbd_db_rollback(SV *dbh, imp_dbh_t *imp_dbh)
+{
+ dTHX;
+ sword status;
+ OCITransRollback_log_stat(imp_dbh->svchp, imp_dbh->errhp, OCI_DEFAULT, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status, "OCITransRollback");
+ return 0;
+ }
+ return 1;
+}
+
+
+int
+dbd_db_disconnect(SV *dbh, imp_dbh_t *imp_dbh)
+{
+ dTHX;
+ dTHR;
+ int refcnt = 1 ;
+
+#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
+ if (DBIc_IMPSET(imp_dbh) && imp_dbh->shared_dbh) {
+ SvLOCK (imp_dbh->shared_dbh_priv_sv) ;
+ refcnt = imp_dbh -> shared_dbh -> refcnt ;
+ }
+#endif
+
+ /* We assume that disconnect will always work */
+ /* since most errors imply already disconnected. */
+ DBIc_ACTIVE_off(imp_dbh);
+
+ /* Oracle will commit on an orderly disconnect. */
+ /* See DBI Driver.xst file for the DBI approach. */
+
+ if (refcnt == 1 && !imp_dbh->proc_handles) {
+ sword s_se, s_sd;
+ OCISessionEnd_log_stat(imp_dbh->svchp, imp_dbh->errhp, imp_dbh->authp,
+ OCI_DEFAULT, s_se);
+ if (s_se) oci_error(dbh, imp_dbh->errhp, s_se, "OCISessionEnd");
+ OCIServerDetach_log_stat(imp_dbh->srvhp, imp_dbh->errhp, OCI_DEFAULT, s_sd);
+ if (s_sd) oci_error(dbh, imp_dbh->errhp, s_sd, "OCIServerDetach");
+ if (s_se || s_sd)
+ return 0;
+ }
+ /* We don't free imp_dbh since a reference still exists */
+ /* The DESTROY method is the only one to 'free' memory. */
+ /* Note that statement objects may still exists for this dbh! */
+ return 1;
+}
+
+
+void
+dbd_db_destroy(SV *dbh, imp_dbh_t *imp_dbh)
+{
+ dTHX ;
+ int refcnt = 1 ;
+ sword status;
+
+#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
+ if (DBIc_IMPSET(imp_dbh) && imp_dbh->shared_dbh) {
+ SvLOCK (imp_dbh->shared_dbh_priv_sv) ;
+ refcnt = imp_dbh -> shared_dbh -> refcnt-- ;
+ }
+#endif
+
+ if (refcnt == 1) {
+ if (DBIc_ACTIVE(imp_dbh))
+ dbd_db_disconnect(dbh, imp_dbh);
+ if (is_extproc)
+ goto dbd_db_destroy_out;
+ if (!imp_dbh->proc_handles)
+ { sword status;
+ OCIHandleFree_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,status);
+ OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
+ OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
+ }
+ }
+ OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
+dbd_db_destroy_out:
+ DBIc_IMPSET_off(imp_dbh);
+}
+
+
+int
+dbd_db_STORE_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv)
+{
+ dTHX;
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ int on = SvTRUE(valuesv);
+ int cacheit = 1;
+
+ if (kl==11 && (strEQ(key, "ora_verbose") || strEQ(key, "dbd_verbose"))) {
+ dbd_verbose = SvIV (valuesv);
+ }
+ else if (kl==10 && strEQ(key, "AutoCommit")) {
+ DBIc_set(imp_dbh,DBIcf_AutoCommit, on);
+ }
+ else if (kl==12 && strEQ(key, "RowCacheSize")) {
+ imp_dbh->RowCacheSize = SvIV(valuesv);
+ }
+ else if (kl==22 && strEQ(key, "ora_max_nested_cursors")) {
+ imp_dbh->max_nested_cursors = SvIV(valuesv);
+ }
+ else if (kl==20 && strEQ(key, "ora_array_chunk_size")) {
+ imp_dbh->array_chunk_size = SvIV(valuesv);
+ }
+ else if (kl==11 && strEQ(key, "ora_ph_type")) {
+ if (SvIV(valuesv)!=1 && SvIV(valuesv)!=5 && SvIV(valuesv)!=96 && SvIV(valuesv)!=97)
+ warn("ora_ph_type must be 1 (VARCHAR2), 5 (STRING), 96 (CHAR), or 97 (CHARZ)");
+ else
+ imp_dbh->ph_type = SvIV(valuesv);
+ }
+
+ else if (kl==13 && strEQ(key, "ora_ph_csform")) {
+ if (SvIV(valuesv)!=SQLCS_IMPLICIT && SvIV(valuesv)!=SQLCS_NCHAR)
+ warn("ora_ph_csform must be 1 (SQLCS_IMPLICIT) or 2 (SQLCS_NCHAR)");
+ else
+ imp_dbh->ph_csform = (ub1)SvIV(valuesv);
+ }
+ else
+ {
+ return FALSE;
+ }
+
+ if (cacheit) /* cache value for later DBI 'quick' fetch? */
+ hv_store((HV*)SvRV(dbh), key, kl, newSVsv(valuesv), 0);
+ return TRUE;
+}
+
+
+SV *
+dbd_db_FETCH_attrib(SV *dbh, imp_dbh_t *imp_dbh, SV *keysv)
+{
+ dTHX;
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ SV *retsv = Nullsv;
+ /* Default to caching results for DBI dispatch quick_FETCH */
+ int cacheit = FALSE;
+
+ /* AutoCommit FETCH via DBI */
+
+ if (kl==11 && (strEQ(key, "ora_verbose") || strEQ(key, "dbd_verbose"))) {
+ retsv = newSViv (dbd_verbose);
+ }
+ else if (kl==10 && strEQ(key, "AutoCommit")) {
+ retsv = boolSV(DBIc_has(imp_dbh,DBIcf_AutoCommit));
+ }
+ else if (kl==12 && strEQ(key, "RowCacheSize")) {
+ retsv = newSViv(imp_dbh->RowCacheSize);
+ }
+ else if (kl==22 && strEQ(key, "ora_max_nested_cursors")) {
+ retsv = newSViv(imp_dbh->max_nested_cursors);
+ }
+ else if (kl==11 && strEQ(key, "ora_ph_type")) {
+ retsv = newSViv(imp_dbh->ph_type);
+ }
+ else if (kl==13 && strEQ(key, "ora_ph_csform")) {
+ retsv = newSViv(imp_dbh->ph_csform);
+ }
+ else if (kl==22 && strEQ(key, "ora_parse_error_offset")) {
+ retsv = newSViv(imp_dbh->parse_error_offset);
+ }
+ if (!retsv)
+ return Nullsv;
+ if (cacheit) { /* cache for next time (via DBI quick_FETCH) */
+ SV **svp = hv_fetch((HV*)SvRV(dbh), key, kl, 1);
+ sv_free(*svp);
+ *svp = retsv;
+ (void)SvREFCNT_inc(retsv); /* so sv_2mortal won't free it */
+ }
+
+ if (retsv == &sv_yes || retsv == &sv_no)
+ return retsv; /* no need to mortalize yes or no */
+
+ return sv_2mortal(retsv);
+}
+
+
+
+/* ================================================================== */
+
+#define MAX_OCISTRING_LEN 32766
+
+SV *
+createxmlfromstring(SV *sth, imp_sth_t *imp_sth, SV *source){
+
+ dTHX;
+ dTHR;
+ OCIXMLType *xml = NULL;
+ STRLEN len;
+ sword status;
+ ub1 src_type;
+ dvoid* src_ptr = NULL;
+ D_imp_dbh_from_sth;
+ SV* sv_dest;
+ dvoid *bufp;
+ ub1 csform;
+ ub2 csid;
+ csid = 0;
+ csform = SQLCS_IMPLICIT;
+
+
+ len = SvLEN(source);
+ bufp = SvPV(source, len);
+
+ if (DBIS->debug >=3 || dbd_verbose >= 3)
+ PerlIO_printf(DBILOGFP, " creating xml from string that is %d long\n",len);
+
+ if(len > MAX_OCISTRING_LEN) {
+ src_type = OCI_XMLTYPE_CREATE_CLOB;
+
+ if (DBIS->debug >=5 || dbd_verbose >=5)
+ PerlIO_printf(DBILOGFP, " use a temp lob locator for large xml \n");
+
+ OCIDescriptorAlloc_ok(imp_dbh->envhp, &src_ptr, OCI_DTYPE_LOB);
+
+ OCILobCreateTemporary_log_stat(imp_dbh->svchp, imp_sth->errhp,
+ (OCILobLocator *) src_ptr, (ub2) OCI_DEFAULT,
+ (ub1) OCI_DEFAULT, OCI_TEMP_CLOB, FALSE, OCI_DURATION_SESSION, status);
+
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCILobCreateTemporary");
+ }
+ csid = (SvUTF8(source) && !CS_IS_UTF8(csid)) ? utf8_csid : CSFORM_IMPLIED_CSID(csform);
+
+ OCILobWriteAppend_log_stat(imp_dbh->svchp, imp_dbh->errhp, src_ptr,
+ &len, bufp, (ub4)len, OCI_ONE_PIECE,
+ NULL, NULL,
+ csid, csform, status);
+
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCILobWriteAppend");
+ }
+
+ } else {
+ src_type = OCI_XMLTYPE_CREATE_OCISTRING;
+ if (DBIS->debug >=5 || dbd_verbose >=5 )
+ PerlIO_printf(DBILOGFP, " use a OCIStringAssignText for small xml \n");
+
+
+ OCIStringAssignText(imp_dbh->envhp,
+ imp_dbh->errhp,
+ bufp,
+ (ub2) (ub4)len,
+ (OCIString **) &src_ptr);
+ }
+
+
+
+ status = OCIXMLTypeCreateFromSrc(imp_dbh->svchp,
+ imp_dbh->errhp,
+ (OCIDuration)OCI_DURATION_CALLOUT,
+ (ub1)src_type,
+ (dvoid *)src_ptr,
+ (sb4)OCI_IND_NOTNULL,
+ &xml);
+
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIXMLTypeCreateFromSrc");
+ }
+
+ /* free temporary resources */
+ if ( src_type == OCI_XMLTYPE_CREATE_CLOB ) {
+ OCILobFreeTemporary(imp_dbh->svchp, imp_dbh->errhp,
+ (OCILobLocator*) src_ptr);
+
+ OCIDescriptorFree((dvoid *) src_ptr, (ub4) OCI_DTYPE_LOB);
+ }
+
+
+ sv_dest = newSViv(0);
+ sv_setref_pv(sv_dest, "OCIXMLTypePtr", xml);
+ return sv_dest;
+
+}
+
+
+void
+dbd_preparse(imp_sth_t *imp_sth, char *statement)
+{
+ dTHX;
+ D_imp_dbh_from_sth;
+ bool in_literal = '\0';
+ char in_comment = '\0';
+ char *src, *start, *dest;
+ phs_t phs_tpl;
+ SV *phs_sv;
+ int idx=0;
+ char *style="", *laststyle=Nullch;
+ STRLEN namelen;
+ phs_t *phs;
+ /* allocate room for copy of statement with spare capacity */
+ /* for editing '?' or ':1' into ':p1' so we can use obndrv. */
+ /* XXX should use SV and append to it */
+ imp_sth->statement = (char*)safemalloc(strlen(statement) * 10);
+
+ /* initialise phs ready to be cloned per placeholder */
+ memset(&phs_tpl, 0, sizeof(phs_tpl));
+ phs_tpl.imp_sth = imp_sth;
+ phs_tpl.ftype = imp_dbh->ph_type;
+ phs_tpl.csform = imp_dbh->ph_csform;
+ phs_tpl.sv = &sv_undef;
+
+ src = statement;
+ dest = imp_sth->statement;
+ while(*src) {
+
+ if (in_comment) {
+ /* 981028-jdl on mocha. Adding all code which deals with */
+ /* in_comment variable (its declaration plus 2 code blocks). */
+ /* Text appearing within comments should be scanned for neither */
+ /* placeholders nor for single quotes (which toggle the in_literal */
+ /* boolean). Comments like "3:00" demonstrate the former problem, */
+ /* and contractions like "don't" demonstrate the latter problem. */
+ /* The comment style is stored in in_comment; each style is */
+ /* terminated in a different way. */
+ if (in_comment == '-' && *src == '\n') {
+ in_comment = '\0';
+ }
+ else if (in_comment == '/' && *src == '*' && *(src+1) == '/') {
+ *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */
+ in_comment = '\0';
+ }
+ *dest++ = *src++;
+ continue;
+ }
+
+ if (in_literal) {
+ if (*src == in_literal)
+ in_literal = '\0';
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* Look for comments: '-- oracle-style' or C-style */
+ if ((*src == '-' && *(src+1) == '-') ||
+ (*src == '/' && *(src+1) == '*'))
+ {
+ in_comment = *src;
+ /* We know *src & the next char are to be copied, so do */
+ /* it. In the case of C-style comments, it happens to */
+ /* help us avoid slash-asterisk-slash oddities. */
+ *dest++ = *src++;
+ *dest++ = *src++;
+ continue;
+ }
+
+ if (*src != ':' && *src != '?') {
+
+ if (*src == '\'' || *src == '"')
+ in_literal = *src;
+
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* only here for : or ? outside of a comment or literal */
+
+ start = dest; /* save name inc colon */
+ *dest++ = *src++;
+ if (*start == '?') { /* X/Open standard */
+ sprintf(start,":p%d", ++idx); /* '?' -> ':p1' (etc) */
+ dest = start+strlen(start);
+ style = "?";
+
+ } else if (isDIGIT(*src)) { /* ':1' */
+ idx = atoi(src);
+ *dest++ = 'p'; /* ':1'->':p1' */
+ if (idx <= 0)
+ croak("Placeholder :%d invalid, placeholders must be >= 1", idx);
+ while(isDIGIT(*src))
+ *dest++ = *src++;
+ style = ":1";
+
+ } else if (isALNUM(*src)) { /* ':foo' */
+ while(isALNUM(*src)) /* includes '_' */
+ *dest++ = toLOWER(*src), src++;
+ style = ":foo";
+ } else { /* perhaps ':=' PL/SQL construct */
+ /* if (src == ':') *dest++ = *src++; XXX? move past '::'? */
+ continue;
+ }
+ *dest = '\0'; /* handy for debugging */
+ namelen = (dest-start);
+ if (laststyle && style != laststyle)
+ croak("Can't mix placeholder styles (%s/%s)",style,laststyle);
+ laststyle = style;
+ if (imp_sth->all_params_hv == NULL)
+ imp_sth->all_params_hv = newHV();
+ phs_sv = newSVpv((char*)&phs_tpl, sizeof(phs_tpl)+namelen+1);
+ phs = (phs_t*)(void*)SvPVX(phs_sv);
+ hv_store(imp_sth->all_params_hv, start, namelen, phs_sv, 0);
+ phs->idx = idx-1; /* Will be 0 for :1, -1 for :foo. */
+ strcpy(phs->name, start);
+
+ }
+ *dest = '\0';
+ if (imp_sth->all_params_hv) {
+ DBIc_NUM_PARAMS(imp_sth) = (int)HvKEYS(imp_sth->all_params_hv);
+ if (DBIS->debug >= 2 || dbd_verbose >=2 )
+ PerlIO_printf(DBILOGFP, " dbd_preparse scanned %d distinct placeholders\n",
+ (int)DBIc_NUM_PARAMS(imp_sth));
+ }
+}
+
+
+static int
+ora_sql_type(imp_sth_t *imp_sth, char *name, int sql_type)
+{
+ /* XXX should detect DBI reserved standard type range here */
+
+ switch (sql_type) {
+ case SQL_NUMERIC:
+ case SQL_DECIMAL:
+ case SQL_INTEGER:
+ case SQL_BIGINT:
+ case SQL_TINYINT:
+ case SQL_SMALLINT:
+ case SQL_FLOAT:
+ case SQL_REAL:
+ case SQL_DOUBLE:
+ case SQL_VARCHAR:
+ return 1; /* Oracle VARCHAR2 */
+
+ case SQL_CHAR:
+ return 96; /* Oracle CHAR */
+
+ case SQL_BINARY:
+ case SQL_VARBINARY:
+ return 23; /* Oracle RAW */
+
+ case SQL_LONGVARBINARY:
+ return 24; /* Oracle LONG RAW */
+
+ case SQL_LONGVARCHAR:
+ return 8; /* Oracle LONG */
+
+ case SQL_UDT:
+ return 108; /* Oracle NTY */
+
+ case SQL_CLOB:
+ return 112; /* Oracle CLOB */
+
+ case SQL_BLOB:
+ return 113; /* Oracle BLOB */
+
+ case SQL_DATE:
+ case SQL_TIME:
+ case SQL_TIMESTAMP:
+ default:
+ if (imp_sth && DBIc_WARN(imp_sth) && name)
+ warn("SQL type %d for '%s' is not fully supported, bound as SQL_VARCHAR instead",
+ sql_type, name);
+ return ora_sql_type(imp_sth, name, SQL_VARCHAR);
+ }
+}
+
+
+
+/* ############### Array bind ######################################### */
+/* Added by Alexander V Alekseev. [email protected] */
+/*
+ *
+ * Realloc temporary array buffer to match required number of entries
+ * and buffer size.
+ *
+ * Return value: croaks on error. false (=0 ) on success.
+ * */
+int ora_realloc_phs_array(phs_t *phs,int newentries, int newbufsize){
+
+ dTHX;
+ dTHR;
+ int i; /* Loop variable */
+ unsigned short *newal;
+
+ if( newbufsize < 0 ){
+ newbufsize=0;
+ }
+ if( newentries > phs->array_numallocated ){
+ OCIInd *newind=(OCIInd *)realloc(phs->array_indicators,newentries*sizeof(OCIInd) );
+ if( newind ){
+ phs->array_indicators=newind;
+ /* Init all indicators to NULL values. */
+ for( i=phs->array_numallocated; i < newentries ; i++ ){
+ newind[i]=1;
+ }
+ }else{
+ croak("Not enough memory to allocate %d OCI indicators.",newentries);
+ }
+ newal=(unsigned short *)realloc(phs->array_lengths, newentries*sizeof(unsigned short));
+ if( newal ){
+ phs->array_lengths=newal;
+ /* Init all new lengths to zero */
+ if( newentries > phs->array_numallocated ){
+ memset(
+ &(newal[phs->array_numallocated]),
+ 0,
+ (newentries-(phs->array_numallocated))*sizeof(unsigned short)
+ );
+ }
+ }else{
+ croak("Not enough memory to allocate %d entries in OCI array of lengths.",newentries);
+ }
+ phs->array_numallocated=newentries;
+ }
+ if( phs->array_buflen < newbufsize ){
+ char * newbuf=(char *)realloc( phs->array_buf, (unsigned) newbufsize );
+ if( newbuf ){
+ phs->array_buf=newbuf;
+ }else{
+ croak("Not enough memory to allocate OCI array buffer of %d bytes.",newbufsize);
+ }
+ phs->array_buflen=newbufsize;
+ }
+ return 0;
+}
+/* bind of SYS.DBMS_SQL.VARCHAR2_TABLE */
+int
+dbd_rebind_ph_varchar2_table(SV *sth, imp_sth_t *imp_sth, phs_t *phs)
+{
+ dTHX;
+ /*D_imp_dbh_from_sth ;*/
+ sword status;
+ int trace_level = DBIS->debug;
+ AV *arr;
+ ub1 csform;
+ ub2 csid;
+ int flag_data_is_utf8=0;
+ int need_allocate_rows;
+ int buflen;
+ if( ( ! SvROK(phs->sv) ) || (SvTYPE(SvRV(phs->sv))!=SVt_PVAV) ) { /* Allow only array binds */
+ croak("dbd_rebind_ph_varchar2_table(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
+ neatsvpv(phs->sv,0), phs->name);
+ }
+ arr=(AV*)(SvRV(phs->sv));
+
+ if (trace_level >= 2 || dbd_verbose >= 2){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): array_numstruct=%d\n",
+ phs->array_numstruct);
+ }
+ /* If no number of entries to bind specified,
+ * set phs->array_numstruct to the scalar(@array) bound.
+ */
+ if( phs->array_numstruct <= 0 ){
+ /* av_len() returns last array index, or -1 is array is empty */
+ int numarrayentries=av_len( arr );
+ if( numarrayentries >= 0 ){
+ phs->array_numstruct = numarrayentries+1;
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): array_numstruct=%d (calculated) \n",
+ phs->array_numstruct);
+ }
+ }
+ }
+ /* Fix charset */
+ csform = phs->csform;
+ if (trace_level >= 2 || dbd_verbose >= 2){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): original csform=%d\n",
+ (int)csform);
+ }
+ /* Calculate each bound structure maxlen.
+ * If maxlen<=0, let maxlen=MAX ( length($$_) each @array );
+ *
+ * Charset calculation is done inside this loop either.
+ */
+ {
+ unsigned int maxlen=0;
+ int i;
+
+ for(i=0;i<av_len(arr)+1;i++){
+ SV *item;
+ item=*(av_fetch(arr,i,0));
+ if( item ){
+ if( phs->maxlen <=0 ){ /* Analyze maxlength only if not forced */
+ STRLEN length=0;
+ if (!SvPOK(item)) { /* normalizations for special cases */
+ if (SvOK(item)) { /* ie a number, convert to string ASAP */
+ if (!(SvROK(item) && phs->is_inout)){
+ sv_2pv(item, &length);
+ }
+ } else { /* ensure we're at least an SVt_PV (so SvPVX etc work) */
+ if(SvUPGRADE(item, SVt_PV)){}
+ }
+ }
+ if( length == 0 ){
+ length=SvCUR(item);
+ }
+ if( length+1 > maxlen ){
+ maxlen=length+1;
+ }
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): length(array[%d])=%d\n",
+ i,(int)length);
+ }
+ }
+ if(SvUTF8(item) ){
+ flag_data_is_utf8=1;
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): is_utf8(array[%d])=true\n", i);
+ }
+ if (csform != SQLCS_NCHAR) {
+ /* try to default csform to avoid translation through non-unicode */
+ if (CSFORM_IMPLIES_UTF8(SQLCS_NCHAR)) /* prefer NCHAR */
+ csform = SQLCS_NCHAR;
+ else if (CSFORM_IMPLIES_UTF8(SQLCS_IMPLICIT))
+ csform = SQLCS_IMPLICIT;
+ /* else leave csform == 0 */
+ if (trace_level || dbd_verbose >= 1 )
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): rebinding %s with UTF8 value %s", phs->name,
+ (csform == SQLCS_NCHAR) ? "so setting csform=SQLCS_IMPLICIT" :
+ (csform == SQLCS_IMPLICIT) ? "so setting csform=SQLCS_NCHAR" :
+ "but neither CHAR nor NCHAR are unicode\n");
+ }
+ }else{
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): is_utf8(array[%d])=false\n", i);
+ }
+ }
+ }
+ }
+ if( phs->maxlen <=0 ){
+ phs->maxlen=maxlen;
+ if (trace_level >= 2 || dbd_verbose >= 2){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): phs->maxlen calculated =%ld\n",
+ (long)maxlen);
+ }
+ } else{
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): phs->maxlen forsed =%ld\n",
+ (long)maxlen);
+ }
+ }
+ }
+ /* Do not allow string bind longer than max VARCHAR2=4000+1 */
+ if( phs->maxlen > 4001 ){
+ phs->maxlen=4001;
+ }
+
+ if( phs->array_numstruct == 0 ){
+ /* Oracle doesn't allow NULL buffers even for empty tables. Don't know why. */
+ phs->array_numstruct=1;
+ }
+ if( phs->ora_maxarray_numentries== 0 ){
+ /* Zero means "use current array length". */
+ phs->ora_maxarray_numentries=phs->array_numstruct;
+ }
+
+ need_allocate_rows=phs->ora_maxarray_numentries;
+
+ if( 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 */
+ /* Upgrade array buffer to new length */
+ if( ora_realloc_phs_array(phs,need_allocate_rows,buflen) ){
+ croak("Unable to bind %s - %d structures by %d bytes requires too much memory.",
+ phs->name, need_allocate_rows, buflen );
+ }else{
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): ora_realloc_phs_array(,need_allocate_rows=%d,buflen=%d) succeeded.\n",
+ need_allocate_rows,buflen);
+ }
+ }
+ /* If maximum allowed bind numentries is less than allowed,
+ * do not bind full array
+ */
+ if( phs->array_numstruct > phs->ora_maxarray_numentries ){
+ phs->array_numstruct = phs->ora_maxarray_numentries;
+ }
+ /* Fill array buffer with string 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 ){
+ STRLEN itemlen;
+ char *str=SvPV(item, itemlen);
+ if( str && (itemlen>0) ){
+ /* Limit string length to maxlen. FIXME: This may corrupt UTF-8 data. */
+ if( itemlen > (unsigned int) phs->maxlen-1 ){
+ itemlen=phs->maxlen-1;
+ }
+ memcpy( phs->array_buf+phs->maxlen*i,
+ str,
+ itemlen);
+ /* Set last byte to zero */
+ phs->array_buf[ phs->maxlen*i + itemlen ]=0;
+ phs->array_indicators[i]=0;
+ phs->array_lengths[i]=itemlen+1; /* Zero byte */
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): "
+ "Copying length=%d array[%d]='%s'.\n",
+ itemlen,i,str);
+ }
+ }else{
+ /* Mark NULL */
+ phs->array_indicators[i]=1;
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): "
+ "Copying length=%d array[%d]=NULL (length==0 or ! str) .\n",
+ itemlen,i);
+ }
+ }
+ }else{
+ /* Mark NULL */
+ phs->array_indicators[i]=1;
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): "
+ "Copying length=? array[%d]=NULL av_fetch failed.\n", i);
+ }
+ }
+ }
+ }
+ /* Do actual bind */
+ OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
+ (text*)phs->name, (sb4)strlen(phs->name),
+ phs->array_buf,
+ phs->maxlen,
+ (ub2)SQLT_STR, phs->array_indicators,
+ phs->array_lengths, /* ub2 *alen_ptr not needed with OCIBindDynamic */
+ (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;
+ }
+ OCIBindArrayOfStruct_log_stat(phs->bndhp, imp_sth->errhp,
+ (unsigned)phs->maxlen, /* Skip parameter for the next data value */
+ sizeof (OCIInd), /* Skip parameter for the next indicator value */
+ 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;
+ }
+ /* Fixup charset */
+ if (csform) {
+ /* set OCI_ATTR_CHARSET_FORM before we get the default OCI_ATTR_CHARSET_ID */
+ OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
+ &csform, (ub4) 0, (ub4) OCI_ATTR_CHARSET_FORM, imp_sth->errhp, status);
+ if ( status != OCI_SUCCESS ) {
+ oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_FORM)"));
+ return 0;
+ }
+ }
+
+ if (!phs->csid_orig) { /* get the default csid Oracle would use */
+ OCIAttrGet_log_stat(phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, (ub4)0 ,
+ OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
+ }
+
+ /* if app has specified a csid then use that, else use default */
+ csid = (phs->csid) ? phs->csid : phs->csid_orig;
+
+ /* if data is utf8 but charset isn't then switch to utf8 csid */
+ if ( flag_data_is_utf8 && !CS_IS_UTF8(csid))
+ csid = utf8_csid; /* not al32utf8_csid here on purpose */
+
+ if (trace_level >= 3 || dbd_verbose >= 3 )
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): bind %s <== %s "
+ "(%s, %s, csid %d->%d->%d, ftype %d, csform %d->%d, maxlen %lu, maxdata_size %lu)\n",
+ phs->name, neatsvpv(phs->sv,0),
+ (phs->is_inout) ? "inout" : "in",
+ flag_data_is_utf8 ? "is-utf8" : "not-utf8",
+ phs->csid_orig, phs->csid, csid,
+ phs->ftype, phs->csform, csform,
+ (unsigned long)phs->maxlen, (unsigned long)phs->maxdata_size);
+
+
+ if (csid) {
+ OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
+ &csid, (ub4) 0, (ub4) OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
+ if ( status != OCI_SUCCESS ) {
+ oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_ID)"));
+ return 0;
+ }
+ }
+
+ if (phs->maxdata_size) {
+ OCIAttrSet_log_stat(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;
+ }
+ }
+
+ return 2;
+}
+
+
+/* Copy array data from array buffer into perl array */
+/* Returns false on error, true on success */
+int dbd_phs_ora_varchar2_table_fixup_after_execute(phs_t *phs){
+ dTHX;
+
+ int trace_level = DBIS->debug;
+ AV *arr;
+
+ if( ( ! SvROK(phs->sv) ) || (SvTYPE(SvRV(phs->sv))!=SVt_PVAV) ) { /* Allow only array binds */
+ croak("dbd_phs_ora_varchar2_table_fixup_after_execute(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
+ neatsvpv(phs->sv,0), phs->name);
+ }
+ if (trace_level >= 1 || dbd_verbose >= 1){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_varchar2_table_fixup_after_execute(): Called for '%s' : array_numstruct=%d, maxlen=%ld \n",
+ phs->name,
+ phs->array_numstruct,
+ (long)phs->maxlen
+ );
+ }
+ arr=(AV*)(SvRV(phs->sv));
+
+ /* If no data is returned, just clear the array. */
+ if( phs->array_numstruct <= 0 ){
+ av_clear(arr);
+ return 1;
+ }
+ /* Delete extra data from array, if any */
+ while( av_len(arr) >= phs->array_numstruct ){
+ av_delete(arr,av_len(arr),G_DISCARD);
+ };
+ /* Extend array, if needed. */
+ if( av_len(arr)+1 < phs->array_numstruct ){
+ av_extend(arr,phs->array_numstruct-1);
+ }
+ /* Fill array with buffer data */
+ {
+ /* phs_t */
+ int i; /* Not to require C99 mode */
+ for(i=0;i<phs->array_numstruct;i++){
+ SV *item,**pitem;
+ pitem=av_fetch(arr,i,0);
+ if( pitem ){
+ item=*pitem;
+ }else{
+ item=NULL;
+ }
+ if( phs->array_indicators[i] == -1 ){
+ /* NULL */
+ if( item ){
+ SvSetMagicSV(item,&PL_sv_undef);
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_varchar2_table_fixup_after_execute(): arr[%d] = undef; SvSetMagicSV(item,&PL_sv_undef);\n",
+ i
+ );
+ }
+ }else{
+ av_store(arr,i,&PL_sv_undef);
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_varchar2_table_fixup_after_execute(): arr[%d] = undef; av_store(arr,i,&PL_sv_undef);\n",
+ i
+ );
+ }
+ }
+ }else{
+ if( (phs->array_indicators[i] == -2) || (phs->array_indicators[i] > 0) ){
+ /* Truncation occurred */
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_varchar2_table_fixup_after_execute(): Placeholder '%s': data truncated at %d row.\n",
+ phs->name,i);
+ }
+ }else{
+ /* All OK. Just copy value.*/
+ }
+ if( item ){
+ sv_setpvn_mg(item,phs->array_buf+phs->maxlen*i,phs->array_lengths[i]);
+ SvPOK_only_UTF8(item);
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_varchar2_table_fixup_after_execute(): arr[%d] = '%s'; "
+ "sv_setpvn_mg(item,phs->array_buf+phs->maxlen*i,phs->array_lengths[i]); \n",
+ i, phs->array_buf+phs->maxlen*i
+ );
+ }
+ }else{
+ av_store(arr,i,newSVpvn(phs->array_buf+phs->maxlen*i,phs->array_lengths[i]));
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_varchar2_table_fixup_after_execute(): arr[%d] = '%s'; "
+ "av_store(arr,i,newSVpvn(phs->array_buf+phs->maxlen*i,phs->array_lengths[i])); \n",
+ i, phs->array_buf+phs->maxlen*i
+ );
+ }
+ }
+ }
+ }
+ }
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_varchar2_table_fixup_after_execute(): scalar(@arr)=%ld.\n",
+ (long)av_len(arr)+1);
+ }
+ return 1;
+}
+/* bind of SYS.DBMS_SQL.NUMBER_TABLE */
+int dbd_rebind_ph_number_table(SV *sth, imp_sth_t *imp_sth, phs_t *phs) {
+ dTHX;
+ /*D_imp_dbh_from_sth ;*/
+ sword status;
+ int trace_level = DBIS->debug;
+ AV *arr;
+ int need_allocate_rows;
+ int buflen;
+ /*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);
+ }
+ /* Default bind type for number table is double. */
+ if( ! phs->ora_internal_type ){
+ 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);
+ }
+ }
+ arr=(AV*)(SvRV(phs->sv));
+
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): array_numstruct=%d\n",
+ phs->array_numstruct);
+ }
+ /* If no number of entries to bind specified,
+ * set phs->array_numstruct to the scalar(@array) bound.
+ */
+ if( phs->array_numstruct <= 0 ){
+/* av_len() returns last array index, or -1 is array is empty */
+ int numarrayentries=av_len( arr );
+ if( numarrayentries >= 0 ){
+ phs->array_numstruct = numarrayentries+1;
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): array_numstruct=%d (calculated) \n",
+ phs->array_numstruct);
+ }
+ }
+ }
+ /* Calculate each bound structure maxlen.
+ * maxlen(int) = sizeof(int);
+ * maxlen(double) = sizeof(double);
+ */
+ switch( phs->ora_internal_type ){
+ case SQLT_INT:
+ phs->maxlen=sizeof(int);
+ break;
+ case SQLT_FLT:
+ default:
+ phs->maxlen=sizeof(double);
+ }
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): phs->maxlen calculated =%ld\n",
+ (long)phs->maxlen);
+ }
+
+ if( phs->array_numstruct == 0 ){
+ /* Oracle doesn't allow NULL buffers even for empty tables. Don't know why. */
+ phs->array_numstruct=1;
+ }
+ if( phs->ora_maxarray_numentries== 0 ){
+ /* Zero means "use current array length". */
+ phs->ora_maxarray_numentries=phs->array_numstruct;
+
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): ora_maxarray_numentries assumed=phs->array_numstruct=%d\n",
+ phs->array_numstruct);
+ }
+ }else{
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): ora_maxarray_numentries=%d\n",
+ phs->ora_maxarray_numentries);
+ }
+ }
+
+ need_allocate_rows=phs->ora_maxarray_numentries;
+
+ if( 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 */
+
+ /* Upgrade array buffer to new length */
+ if( ora_realloc_phs_array(phs,need_allocate_rows,buflen) ){
+ croak("Unable to bind %s - %d structures by %d bytes requires too much memory.",
+ phs->name, need_allocate_rows, buflen );
+ }else{
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_number_table(): ora_realloc_phs_array(,need_allocate_rows=%d,buflen=%d) succeeded.\n",
+ need_allocate_rows,buflen);
+ }
+ }
+ /* If maximum allowed bind numentries is less than allowed,
+ * do not bind full array
+ */
+ if( phs->array_numstruct > phs->ora_maxarray_numentries ){
+ phs->array_numstruct = phs->ora_maxarray_numentries;
+ }
+ /* 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(DBILOGFP, "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(DBILOGFP, "dbd_rebind_ph_number_table(): "
+ "let (double) array[%d]=%lf - 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 >= 2 ){
+ STRLEN l;
+ char *p=SvPV(item,l);
+
+ PerlIO_printf(DBILOGFP, "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(DBILOGFP, "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(DBILOGFP, "dbd_rebind_ph_number_table(): "
+ "(double) array[%d]=%lf%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(DBILOGFP, "dbd_rebind_ph_number_table(): "
+ "Copying length=? array[%d]=NULL av_fetch failed.\n", i);
+ }
+ }
+ }
+ }
+ /* Do actual bind */
+ OCIBindByName_log_stat(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
+ );
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBindByName");
+ return 0;
+ }
+ OCIBindArrayOfStruct_log_stat(phs->bndhp, imp_sth->errhp,
+ (unsigned)phs->maxlen, /* Skip parameter for the next data value */
+ sizeof (OCIInd), /* Skip parameter for the next indicator value */
+ 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;
+ }
+ if (phs->maxdata_size) {
+ OCIAttrSet_log_stat(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;
+ }
+ }
+
+ return 2;
+}
+
+
+/* Copy array data from array buffer into perl array */
+/* Returns false on error, true on success */
+int dbd_phs_ora_number_table_fixup_after_execute(phs_t *phs){
+ dTHX;
+
+ int trace_level = DBIS->debug;
+ AV *arr;
+
+ if( ( ! SvROK(phs->sv) ) || (SvTYPE(SvRV(phs->sv))!=SVt_PVAV) ) { /* Allow only array binds */
+ croak("dbd_phs_ora_number_table_fixup_after_execute(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
+ neatsvpv(phs->sv,0), phs->name);
+ }
+ if (trace_level >= 1 || dbd_verbose >= 1 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): Called for '%s' : array_numstruct=%d, maxlen=%ld \n",
+ phs->name,
+ phs->array_numstruct,
+ (long)phs->maxlen
+ );
+ }
+ /* At this point, ora_internal_type can't be default. It must be set at bind time. */
+ 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, SQLT_INT datatypes.",
+ phs->ora_internal_type);
+ }
+ arr=(AV*)(SvRV(phs->sv));
+
+ /* If no data is returned, just clear the array. */
+ if( phs->array_numstruct <= 0 ){
+ av_clear(arr);
+ return 1;
+ }
+ /* Delete extra data from array, if any */
+ while( av_len(arr) >= phs->array_numstruct ){
+ av_delete(arr,av_len(arr),G_DISCARD);
+ };
+ /* Extend array, if needed. */
+ if( av_len(arr)+1 < phs->array_numstruct ){
+ av_extend(arr,phs->array_numstruct-1);
+ }
+ /* Fill array with buffer data */
+ {
+ /* phs_t */
+ int i; /* Not to require C99 mode */
+ for(i=0;i<phs->array_numstruct;i++){
+ SV *item,**pitem;
+ pitem=av_fetch(arr,i,0);
+ if( pitem ){
+ item=*pitem;
+ }else{
+ item=NULL;
+ }
+ if( phs->array_indicators[i] == -1 ){
+ /* NULL */
+ if( item ){
+ SvSetMagicSV(item,&PL_sv_undef);
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): arr[%d] = undef; SvSetMagicSV(item,&PL_sv_undef);\n",
+ i
+ );
+ }
+ }else{
+ av_store(arr,i,&PL_sv_undef);
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): arr[%d] = undef; av_store(arr,i,&PL_sv_undef);\n",
+ i
+ );
+ }
+ }
+ }else{
+ if( (phs->array_indicators[i] == -2) || (phs->array_indicators[i] > 0) ){
+ /* Truncation occurred */
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): Placeholder '%s': data truncated at %d row.\n",
+ phs->name,i);
+ }
+ }else{
+ /* All OK. Just copy value.*/
+ }
+ if( item ){
+ switch(phs->ora_internal_type){
+ case SQLT_INT:
+ if (trace_level >= 4 || dbd_verbose >= 4 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): (int) set arr[%d] = %d \n",
+ i, *(int*)(phs->array_buf+phs->maxlen*i)
+ );
+ }
+ sv_setiv_mg(item,*(int*)(phs->array_buf+phs->maxlen*i));
+ break;
+ case SQLT_FLT:
+ if (trace_level >= 4 || dbd_verbose >= 4 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): (double) set arr[%d] = %lf \n",
+ i, *(double*)(phs->array_buf+phs->maxlen*i)
+ );
+ }
+ sv_setnv_mg(item,*(double*)(phs->array_buf+phs->maxlen*i));
+ }
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ STRLEN l;
+ char *str= SvPOK(item) ? SvPV(item,l) : "<unprintable>" ;
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): arr[%d] = '%s'\n",
+ i, str ? str : "<unprintable>"
+ );
+ }
+ }else{
+ switch(phs->ora_internal_type){
+ case SQLT_INT:
+ if (trace_level >= 4 || dbd_verbose >= 4 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): (int) store new arr[%d] = %d \n",
+ i, *(int*)(phs->array_buf+phs->maxlen*i)
+ );
+ }
+ av_store(arr,i,newSViv( *(int*)(phs->array_buf+phs->maxlen*i) ));
+ break;
+ case SQLT_FLT:
+ if (trace_level >= 4 || dbd_verbose >= 4 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): (double) store new arr[%d] = %lf \n",
+ i, *(double*)(phs->array_buf+phs->maxlen*i)
+ );
+ }
+ av_store(arr,i,newSVnv( *(double*)(phs->array_buf+phs->maxlen*i) ));
+ }
+ if (trace_level >= 3 || dbd_verbose >= 3 ){
+ STRLEN l;
+ char *str;
+ SV**pitem=av_fetch(arr,i,0);
+ if( pitem ){
+ item=*pitem;
+ }
+ str= item ? ( SvPOK(item) ? SvPV(item,l) : "<unprintable>" ) : "<undef>";
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): arr[%d] = '%s'\n",
+ i, str ? str : "<unprintable>"
+ );
+ }
+ }
+ }
+ }
+ }
+ if (trace_level >= 2 || dbd_verbose >= 2 ){
+ PerlIO_printf(DBILOGFP,
+ "dbd_phs_ora_number_table_fixup_after_execute(): scalar(@arr)=%ld.\n",
+ (long)av_len(arr)+1);
+ }
+ return 1;
+}
+
+
+
+
+static int
+dbd_rebind_ph_char(imp_sth_t *imp_sth, phs_t *phs)
+{
+ dTHX;
+ STRLEN value_len;
+ int at_exec = 0;
+ at_exec = (phs->desc_h == NULL);
+
+ if (!SvPOK(phs->sv)) { /* normalizations for special cases */
+ if (SvOK(phs->sv)) { /* ie a number, convert to string ASAP */
+ if (!(SvROK(phs->sv) && phs->is_inout))
+ sv_2pv(phs->sv, &na);
+ }
+ else /* ensure we're at least an SVt_PV (so SvPVX etc work) */
+ if(SvUPGRADE(phs->sv, SVt_PV)){} /* For gcc not to warn on unused result)*/;
+ }
+
+
+ if (DBIS->debug >= 2 || dbd_verbose >=2 ) {
+ char *val = neatsvpv(phs->sv,10);
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_char() (1): bind %s <== %.1000s (", phs->name, val);
+ if (!SvOK(phs->sv))
+ PerlIO_printf(DBILOGFP, "NULL, ");
+ PerlIO_printf(DBILOGFP, "size %ld/%ld/%d, ",(long)SvCUR(phs->sv),(long)SvLEN(phs->sv),phs->maxlen);
+ PerlIO_printf(DBILOGFP, "ptype %d(%s), otype %d %s)\n",(int)SvTYPE(phs->sv), sql_typecode_name(phs->ftype),phs->ftype,(phs->is_inout) ? ", inout" : "");
+ }
+
+ /* At the moment we always do sv_setsv() and rebind. */
+ /* Later we may optimise this so that more often we can */
+ /* just copy the value & length over and not rebind. */
+
+ if (phs->is_inout) { /* XXX */
+ if (SvREADONLY(phs->sv))
+ croak("Modification of a read-only value attempted");
+ if (imp_sth->ora_pad_empty)
+ croak("Can't use ora_pad_empty with bind_param_inout");
+ if (SvTYPE(phs->sv)!=SVt_RV || !at_exec) {
+
+ if (phs->ftype == 96){
+ SvGROW(phs->sv,(STRLEN) (unsigned int)phs->maxlen-1);
+ } else {
+ STRLEN min_len = 28;
+ (void)SvUPGRADE(phs->sv, SVt_PVNV);
+ /* ensure room for result, 28 is magic number (see sv_2pv) */
+ /* don't apply 28 char min to CHAR types - probably shouldn't */
+ /* apply it anywhere really, trying to be too helpful. */
+ /* phs->sv _is_ the real live variable, it may 'mutate' later */
+ /* pre-upgrade to high'ish type to reduce risk of SvPVX realloc/move */
+ SvGROW(phs->sv, (STRLEN)(((unsigned int) phs->maxlen <= min_len) ? min_len : (unsigned int) phs->maxlen)+1/*for null*/);
+
+ }
+ }
+
+ }
+
+ /* At this point phs->sv must be at least a PV with a valid buffer, */
+ /* even if it's undef (null) */
+ /* Here we set phs->progv, phs->indp, and value_len. */
+
+ if (SvOK(phs->sv)) {
+ phs->progv = SvPV(phs->sv, value_len);
+ phs->indp = 0;
+ } else { /* it's null but point to buffer incase it's an out var */
+ phs->progv = (phs->is_inout) ? SvPVX(phs->sv) : NULL;
+ phs->indp = -1;
+ value_len = 0;
+ }
+
+
+ if (imp_sth->ora_pad_empty && value_len==0) {
+ sv_setpv(phs->sv, " ");
+ phs->progv = SvPV(phs->sv, value_len);
+ }
+
+ phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */
+ if (SvTYPE(phs->sv) == SVt_RV && SvTYPE(SvRV(phs->sv)) == SVt_PVAV) { /* it is returning an array of scalars not a single scalar*/
+ phs->maxlen = 4000; /* Just make is a varchar max should be ok for most things*/
+
+ } else {
+ phs->maxlen = ((IV)SvLEN(phs->sv)); /* avail buffer space (64bit safe) Logicaly maxlen should never change but it does why I know not*/
+
+ }
+
+
+ if (phs->maxlen < 0) /* can happen with nulls */
+ phs->maxlen = 0;
+
+ phs->alen = value_len + phs->alen_incnull;
+
+ if (DBIS->debug >= 3 || dbd_verbose >=3) {
+ UV neatsvpvlen = (UV)DBIc_DBISTATE(imp_sth)->neatsvpvlen;
+ char *val = neatsvpv(phs->sv,10);
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph_char() (2): bind %s <== '%.*s' (size %ld/%ld, otype %d(%s), indp %d, at_exec %d)\n",
+ phs->name,
+ (int)(phs->alen > neatsvpvlen ? neatsvpvlen : phs->alen),
+ (phs->progv) ? val: "",
+ (long)phs->alen, (long)phs->maxlen, phs->ftype,sql_typecode_name(phs->ftype), phs->indp, at_exec);
+ }
+
+ return 1;
+}
+
+
+/*
+ * Rebind an "in" cursor ref to its real statement handle
+ * This allows passing cursor refs as "in" to pl/sql (but only if you got the
+ * cursor from pl/sql to begin with)
+ */
+int
+pp_rebind_ph_rset_in(SV *sth, imp_sth_t *imp_sth, phs_t *phs)
+{
+ dTHX;
+ dTHR;
+ SV * sth_csr = phs->sv;
+ D_impdata(imp_sth_csr, imp_sth_t, sth_csr);
+ sword status;
+
+ if (DBIS->debug >= 3 || dbd_verbose >=3)
+ PerlIO_printf(DBILOGFP, " pp_rebind_ph_rset_in: BEGIN\n calling OCIBindByName(stmhp=%p, bndhp=%p, errhp=%p, name=%s, csrstmhp=%p, ftype=%d)\n", imp_sth->stmhp, phs->bndhp, imp_sth->errhp, phs->name, imp_sth_csr->stmhp, phs->ftype);
+
+ OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
+ (text*)phs->name, (sb4)strlen(phs->name),
+ &imp_sth_csr->stmhp,
+ 0,
+ (ub2)phs->ftype, 0,
+ NULL,
+ 0, 0,
+ NULL,
+ (ub4)OCI_DEFAULT,
+ status
+ );
+
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBindByName SQLT_RSET");
+ return 0;
+ }
+
+ if (DBIS->debug >= 3 || dbd_verbose >=3)
+ PerlIO_printf(DBILOGFP, " pp_rebind_ph_rset_in: END\n");
+
+ return 2;
+}
+
+
+int
+pp_exec_rset(SV *sth, imp_sth_t *imp_sth, phs_t *phs, int pre_exec)
+{
+ dTHX;
+ if (pre_exec) { /* pre-execute - allocate a statement handle */
+ dSP;
+ D_imp_dbh_from_sth;
+ HV *init_attr = newHV();
+ int count;
+ sword status;
+
+ if (DBIS->debug >= 3 || dbd_verbose >=3)
+ PerlIO_printf(DBILOGFP, " pp_exec_rset bind %s - allocating new sth...\n", phs->name);
+
+
+ /* extproc deallocates everything for us */
+ if (is_extproc)
+ return 1;
+
+ if (!phs->desc_h || 1) { /* XXX phs->desc_t != OCI_HTYPE_STMT) */
+ if (phs->desc_h) {
+ OCIHandleFree_log_stat(phs->desc_h, phs->desc_t, status);
+ phs->desc_h = NULL;
+ }
+ phs->desc_t = OCI_HTYPE_STMT;
+ OCIHandleAlloc_ok(imp_sth->envhp, &phs->desc_h, phs->desc_t, status);
+ }
+
+
+ phs->progv = (char*)&phs->desc_h;
+ phs->maxlen = 0;
+
+ OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
+ (text*)phs->name, (sb4)strlen(phs->name),
+ phs->progv, 0,
+ (ub2)phs->ftype, 0, /* using &phs->indp triggers ORA-01001 errors! */
+ NULL, 0, 0, NULL, OCI_DEFAULT, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBindByName SQLT_RSET");
+ return 0;
+ }
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newRV((SV*)DBIc_MY_H(imp_dbh))));
+ XPUSHs(sv_2mortal(newRV((SV*)init_attr)));
+ PUTBACK;
+ count = perl_call_pv("DBI::_new_sth", G_ARRAY);
+ SPAGAIN;
+ if (count != 2)
+ croak("panic: DBI::_new_sth returned %d values instead of 2", count);
+ (void)POPs; /* discard inner handle */
+ sv_setsv(phs->sv, POPs); /* save outer handle */
+ SvREFCNT_dec(init_attr);
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ if (DBIS->debug >= 3 || dbd_verbose >=3)
+ PerlIO_printf(DBILOGFP, " pp_exec_rset bind %s - allocated %s...\n",
+ phs->name, neatsvpv(phs->sv, 0));
+
+ }
+ else { /* post-execute - setup the statement handle */
+ dTHR;
+ SV * sth_csr = phs->sv;
+ D_impdata(imp_sth_csr, imp_sth_t, sth_csr);
+
+ if (DBIS->debug >= 3 || dbd_verbose >=3 )
+ PerlIO_printf(DBILOGFP, " bind %s - initialising new %s for cursor 0x%lx...\n",
+ phs->name, neatsvpv(sth_csr,0), (unsigned long)phs->progv);
+
+ /* copy appropriate handles and atributes from parent statement */
+ imp_sth_csr->envhp = imp_sth->envhp;
+ imp_sth_csr->errhp = imp_sth->errhp;
+ imp_sth_csr->srvhp = imp_sth->srvhp;
+ imp_sth_csr->svchp = imp_sth->svchp;
+ imp_sth_csr->auto_lob = imp_sth->auto_lob;
+ imp_sth_csr->pers_lob = imp_sth->pers_lob;
+ imp_sth_csr->clbk_lob = imp_sth->clbk_lob;
+ imp_sth_csr->piece_size = imp_sth->piece_size;
+ imp_sth_csr->piece_lob = imp_sth->piece_lob;
+ imp_sth_csr->is_child = 1; /*no prefetching on a cursor or sp*/
+
+
+ /* assign statement handle from placeholder descriptor */
+ imp_sth_csr->stmhp = (OCIStmt*)phs->desc_h;
+ phs->desc_h = NULL; /* tell phs that we own it now */
+
+ /* force stmt_type since OCIAttrGet(OCI_ATTR_STMT_TYPE) doesn't work! */
+ imp_sth_csr->stmt_type = OCI_STMT_SELECT;
+ imp_sth_csr->rs_array_on=1; /* turn on array fetch for ref cursors */
+ DBIc_IMPSET_on(imp_sth_csr);
+
+ /* set ACTIVE so dbd_describe doesn't do explicit OCI describe */
+ DBIc_ACTIVE_on(imp_sth_csr);
+ if (!dbd_describe(sth_csr, imp_sth_csr)) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+static int
+dbd_rebind_ph_xml( SV* sth, imp_sth_t *imp_sth, phs_t *phs) {
+ dTHX;
+ dTHR;
+ OCIType *tdo = NULL;
+ sword status;
+ SV* ptr;
+
+
+ if (DBIS->debug >= 3 || dbd_verbose >=3)
+ PerlIO_printf(DBILOGFP, " in dbd_rebind_ph_xml\n");
+
+ /*go and create the XML dom from the passed in value*/
+
+ phs->sv=createxmlfromstring(sth, imp_sth, phs->sv );
+
+ if (phs->is_inout)
+ croak("OUT binding for NTY is currently unsupported");
+
+ /* ensure that the value is a support named object type */
+ /* (currently only OCIXMLType*) */
+ if ( sv_isa(phs->sv, "OCIXMLTypePtr") ) {
+ OCITypeByName(imp_sth->envhp, imp_sth->errhp, imp_sth->svchp,
+ (CONST text*)"SYS", 3,
+ (CONST text*)"XMLTYPE", 7,
+ (CONST text*)0, 0,
+ OCI_DURATION_CALLOUT, OCI_TYPEGET_HEADER,
+ &tdo);
+ ptr = SvRV(phs->sv);
+ phs->progv = (void*) SvIV(ptr);
+ phs->maxlen = sizeof(OCIXMLType*);
+ }
+ else
+ croak("Unsupported named object type for bind parameter");
+
+
+ /* bind by name */
+
+ OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
+ (text*)phs->name, (sb4)strlen(phs->name),
+ (dvoid *) NULL, /* value supplied in BindObject later */
+ 0,
+ (ub2)phs->ftype, 0,
+ NULL,
+ 0, 0,
+ NULL,
+ (ub4)OCI_DEFAULT,
+ status
+ );
+
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBindByName SQLT_NTY");
+ return 0;
+ }
+ if (DBIS->debug >= 3 || dbd_verbose >=3)
+ PerlIO_printf(DBILOGFP, " pp_rebind_ph_nty: END\n");
+
+
+ /* bind the object */
+ OCIBindObject(phs->bndhp, imp_sth->errhp,
+ (CONST OCIType*)tdo,
+ (dvoid **)&phs->progv,
+ (ub4*)NULL,
+ (dvoid **)NULL,
+ (ub4*)NULL);
+
+ return 2;
+ }
+
+
+static int
+dbd_rebind_ph(SV *sth, imp_sth_t *imp_sth, phs_t *phs)
+{
+ dTHX;
+ /*ub2 *alen_ptr = NULL;*/
+ sword status;
+ int done = 0;
+ int at_exec;
+ int trace_level = DBIS->debug;
+ ub1 csform;
+ ub2 csid;
+
+ if (trace_level >= 5 || dbd_verbose >= 5 )
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph() (1): rebinding %s as %s (%s, ftype %d (%s), csid %d, csform %d, inout %d)\n",
+ phs->name, (SvPOK(phs->sv) ? neatsvpv(phs->sv,10) : "NULL"),(SvUTF8(phs->sv) ? "is-utf8" : "not-utf8"),
+ phs->ftype,sql_typecode_name(phs->ftype),phs->csid, phs->csform, phs->is_inout);
+
+
+ switch (phs->ftype) {
+ case ORA_VARCHAR2_TABLE:
+ done = dbd_rebind_ph_varchar2_table(sth, imp_sth, phs);
+ break;
+ case ORA_NUMBER_TABLE:
+ done = dbd_rebind_ph_number_table(sth, imp_sth, phs);
+ break;
+ case SQLT_CLOB:
+ case SQLT_BLOB:
+ done = dbd_rebind_ph_lob(sth, imp_sth, phs);
+ break;
+ case SQLT_RSET:
+ done = dbd_rebind_ph_rset(sth, imp_sth, phs);
+ break;
+ case ORA_XMLTYPE:
+ done = dbd_rebind_ph_xml(sth, imp_sth, phs);
+ break;
+ default:
+ done = dbd_rebind_ph_char(imp_sth, phs);
+ }
+
+ if (done == 2) { /* the dbd_rebind_* did the OCI bind call itself successfully */
+ if (trace_level >= 3 || dbd_verbose >= 3 )
+ PerlIO_printf(DBILOGFP, " rebind %s done with ftype %d (%s)\n",
+ phs->name, phs->ftype,sql_typecode_name(phs->ftype));
+ return 1;
+ }
+
+ if (trace_level >= 3 || dbd_verbose >= 3 )
+ PerlIO_printf(DBILOGFP, " bind %s as ftype %d (%s)\n",
+ phs->name, phs->ftype,sql_typecode_name(phs->ftype));
+
+ if (done != 1) {
+ return 0; /* the rebind failed */
+ }
+
+ at_exec = (phs->desc_h == NULL);
+
+
+ OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
+ (text*)phs->name, (sb4)strlen(phs->name),
+ phs->progv,
+ phs->maxlen ? (sb4)phs->maxlen : 1, /* else bind "" fails */
+ (ub2)phs->ftype, &phs->indp,
+ NULL, /* ub2 *alen_ptr not needed with OCIBindDynamic */
+ &phs->arcode,
+ 0, /* max elements that can fit in allocated array */
+ NULL, /* (ptr to) current number of elements in array */
+ (ub4)(at_exec ? OCI_DATA_AT_EXEC : OCI_DEFAULT),
+ status
+ );
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBindByName");
+ return 0;
+ }
+ if (at_exec) {
+ OCIBindDynamic_log(phs->bndhp, imp_sth->errhp,
+ (dvoid *)phs, dbd_phs_in,
+ (dvoid *)phs, dbd_phs_out, status);
+
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBindDynamic");
+ return 0;
+ }
+ }
+
+ /* some/all of the following should perhaps move into dbd_phs_in() */
+
+ csform = phs->csform;
+
+ if (!csform && SvUTF8(phs->sv)) {
+ /* try to default csform to avoid translation through non-unicode */
+ if (CSFORM_IMPLIES_UTF8(SQLCS_IMPLICIT)) /* prefer IMPLICIT */
+ csform = SQLCS_IMPLICIT;
+ else if (CSFORM_IMPLIES_UTF8(SQLCS_NCHAR))
+ csform = SQLCS_NCHAR; /* else leave csform == 0 */
+ if (trace_level || dbd_verbose >= 1)
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph() (2): rebinding %s with UTF8 value %s", phs->name,
+ (csform == SQLCS_IMPLICIT) ? "so setting csform=SQLCS_IMPLICIT" :
+ (csform == SQLCS_NCHAR) ? "so setting csform=SQLCS_NCHAR" :
+ "but neither CHAR nor NCHAR are unicode\n");
+ }
+
+ if (csform) {
+ /* set OCI_ATTR_CHARSET_FORM before we get the default OCI_ATTR_CHARSET_ID */
+ OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
+ &csform, (ub4) 0, (ub4) OCI_ATTR_CHARSET_FORM, imp_sth->errhp, status);
+ if ( status != OCI_SUCCESS ) {
+ oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_FORM)"));
+ return 0;
+ }
+ }
+
+ if (!phs->csid_orig) { /* get the default csid Oracle would use */
+ OCIAttrGet_log_stat(phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, (ub4)0 ,
+ OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
+ }
+
+ /* if app has specified a csid then use that, else use default */
+ csid = (phs->csid) ? phs->csid : phs->csid_orig;
+
+ /* if data is utf8 but charset isn't then switch to utf8 csid */
+ if (SvUTF8(phs->sv) && !CS_IS_UTF8(csid))
+ csid = utf8_csid; /* not al32utf8_csid here on purpose */
+
+ if (trace_level >= 3 || dbd_verbose >= 3 )
+ PerlIO_printf(DBILOGFP, "dbd_rebind_ph(): bind %s <== %s "
+ "(%s, %s, csid %d->%d->%d, ftype %d (%s), csform %d->%d, maxlen %lu, maxdata_size %lu)\n",
+ phs->name, neatsvpv(phs->sv,10),
+ (phs->is_inout) ? "inout" : "in",
+ (SvUTF8(phs->sv) ? "is-utf8" : "not-utf8"),
+ phs->csid_orig, phs->csid, csid,
+ phs->ftype,sql_typecode_name(phs->ftype), phs->csform, csform,
+ (unsigned long)phs->maxlen, (unsigned long)phs->maxdata_size);
+
+
+ if (csid) {
+ OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
+ &csid, (ub4) 0, (ub4) OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
+ if ( status != OCI_SUCCESS ) {
+ oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_ID)"));
+ return 0;
+ }
+ }
+
+ if (phs->maxdata_size) {
+ OCIAttrSet_log_stat(phs->bndhp, (ub4)OCI_HTYPE_BIND,
+ neatsvpv(phs->sv,0), (ub4)phs->maxdata_size, (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 1;
+}
+
+
+int
+dbd_bind_ph(SV *sth, imp_sth_t *imp_sth, SV *ph_namesv, SV *newvalue, IV sql_type, SV *attribs, int is_inout, IV maxlen)
+{
+ dTHX;
+ SV **phs_svp;
+ STRLEN name_len;
+ char *name = Nullch;
+ char namebuf[32];
+ phs_t *phs;
+
+ /* check if placeholder was passed as a number */
+ if (SvGMAGICAL(ph_namesv)) /* eg tainted or overloaded */
+ mg_get(ph_namesv);
+
+ if (!SvNIOKp(ph_namesv)) {
+ STRLEN i;
+ name = SvPV(ph_namesv, name_len);
+ if (name_len > sizeof(namebuf)-1)
+ croak("Placeholder name %s too long", neatsvpv(ph_namesv,0));
+
+ for (i=0; i<name_len; i++) namebuf[i] = toLOWER(name[i]);
+ namebuf[i] = '\0';
+ name = namebuf;
+ }
+
+ if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) {
+ sprintf(namebuf, ":p%d", (int)SvIV(ph_namesv));
+ name = namebuf;
+ name_len = strlen(name);
+ }
+
+ assert(name != Nullch);
+
+ if (SvROK(newvalue)
+ && !IS_DBI_HANDLE(newvalue) /* dbi handle allowed for cursor variables */
+ && !SvAMAGIC(newvalue) /* overload magic allowed (untested) */
+ && !sv_derived_from(newvalue, "OCILobLocatorPtr" ) /* input LOB locator*/
+ && !(SvTYPE(SvRV(newvalue))==SVt_PVAV) /* Allow array binds */
+ )
+ croak("Can't bind a reference (%s)", neatsvpv(newvalue,0));
+
+ if (SvTYPE(newvalue) > SVt_PVAV) /* Array binding supported */
+ croak("Can't bind a non-scalar, non-array value (%s)", neatsvpv(newvalue,0));
+ if (SvTYPE(newvalue) == SVt_PVLV && is_inout) /* may allow later */
+ croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)");
+
+ if (DBIS->debug >= 2 || dbd_verbose >=2) {
+ PerlIO_printf(DBILOGFP, "dbd_bind_ph(): bind %s <== %s (type %ld (%s)",
+ name, neatsvpv(newvalue,0), (long)sql_type,sql_typecode_name(sql_type));
+ if (is_inout)
+ PerlIO_printf(DBILOGFP, ", inout 0x%lx, maxlen %ld",
+ (long)newvalue, (long)maxlen);
+ if (attribs)
+ PerlIO_printf(DBILOGFP, ", attribs: %s", neatsvpv(attribs,0));
+ PerlIO_printf(DBILOGFP, ")\n");
+ }
+
+ phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0);
+
+
+ if (phs_svp == NULL)
+ croak("Can't bind unknown placeholder '%s' (%s)", name, neatsvpv(ph_namesv,0));
+
+ /* This value is not a string, but a binary structure phs_st instead. */
+ phs = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */
+
+ if (phs->sv == &sv_undef) { /* first bind for this placeholder */
+ phs->is_inout = is_inout;
+ if (is_inout) {
+ /* phs->sv assigned in the code below */
+ ++imp_sth->has_inout_params;
+ /* build array of phs's so we can deal with out vars fast */
+ if (!imp_sth->out_params_av)
+ imp_sth->out_params_av = newAV();
+ av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp));
+ }
+
+ /*
+ * Init number of bound array entries to zero.
+ * If "ora_maxarray_numentries" bind parameter specified,
+ * it would be set below.
+ *
+ * If no ora_maxarray_numentries specified, let it be
+ * the same as scalar(@array) bound (see dbd_rebind_ph_varchar2_table() ).
+ */
+ phs->array_numstruct=0;
+
+ if (attribs) { /* only look for ora_type on first bind of var */
+ SV **svp;
+ /* Setup / Clear attributes as defined by attribs. */
+ /* XXX If attribs is EMPTY then reset attribs to default? */
+
+ if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_type",8, 0)) != NULL) {
+ int ora_type = SvIV(*svp);
+ if (!oratype_bind_ok(ora_type))
+ croak("Can't bind %s, ora_type %d not supported by DBD::Oracle", phs->name, ora_type);
+ if (sql_type)
+ croak("Can't specify both TYPE (%d) and ora_type (%d) for %s", sql_type, ora_type, phs->name);
+ phs->ftype = ora_type;
+ }
+ if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_field",9, 0)) != NULL) {
+ phs->ora_field = SvREFCNT_inc(*svp);
+ }
+ if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_csform", 10, 0)) != NULL) {
+ if (SvIV(*svp) == SQLCS_IMPLICIT || SvIV(*svp) == SQLCS_NCHAR)
+ phs->csform = (ub1)SvIV(*svp);
+ else warn("ora_csform must be 1 (SQLCS_IMPLICIT) or 2 (SQLCS_NCHAR), not %d", SvIV(*svp));
+ }
+ if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_maxdata_size", 16, 0)) != NULL) {
+ phs->maxdata_size = SvUV(*svp);
+ }
+ if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_maxarray_numentries", 23, 0)) != NULL) {
+ phs->ora_maxarray_numentries=SvUV(*svp);
+ }
+ if ( (svp=hv_fetch((HV*)SvRV(attribs), "ora_internal_type", 17, 0)) != NULL) {
+ phs->ora_internal_type=SvUV(*svp);
+ }
+ }
+
+
+ if (sql_type)
+ phs->ftype = ora_sql_type(imp_sth, phs->name, (int)sql_type);
+ /* treat Oracle7 SQLT_CUR as SQLT_RSET for Oracle8 */
+ if (phs->ftype==102)
+ phs->ftype = 116;
+
+ /* some types require the trailing null included in the length. */
+ /* SQLT_STR=5=STRING, SQLT_AVC=97=VARCHAR */
+ phs->alen_incnull = (phs->ftype==SQLT_STR || phs->ftype==SQLT_AVC);
+
+ } /* was first bind for this placeholder */
+
+ /* check later rebinds for any changes */
+ else if (is_inout != phs->is_inout) {
+ croak("Can't rebind or change param %s in/out mode after first bind (%d => %d)",
+ phs->name, phs->is_inout , is_inout);
+
+ }
+ else if (sql_type && phs->ftype != ora_sql_type(imp_sth, phs->name, (int)sql_type)) {
+ croak("Can't change TYPE of param %s to %d after initial bind",
+ phs->name, sql_type);
+
+ }
+ /* Array binding is supported for a limited number of data types. */
+
+ if( SvROK(newvalue) ){
+ if( SvTYPE(SvRV(newvalue))==SVt_PVAV ){
+ if( (phs->ftype == ORA_VARCHAR2_TABLE) ||
+ (phs->ftype == ORA_NUMBER_TABLE) ||
+ (phs->ftype == 1)) /*ORA_VARCHAR2*/ {
+ /* Supported */
+ }else{
+ /* All the other types are not supported */
+ croak("Array bind is supported only for ORA_%_TABLE types. Unable to bind '%s'.",phs->name);
+
+ }
+ }
+ }
+
+ /* Add checks for other reference types here ? */
+
+ phs->maxlen = maxlen; /* 0 if not inout */
+
+ if (!is_inout) { /* normal bind so take a (new) copy of current value */
+ if (phs->sv == &sv_undef) /* (first time bind) */
+ phs->sv = newSV(0);
+ sv_setsv(phs->sv, newvalue);
+ if (SvAMAGIC(phs->sv)) /* overloaded. XXX hack, logic ought to be pushed deeper */
+ sv_pvn_force(phs->sv, &na);
+ }
+ else if (newvalue != phs->sv) {
+ if (phs->sv)
+ SvREFCNT_dec(phs->sv);
+
+ phs->sv = SvREFCNT_inc(newvalue); /* point to live var */
+ }
+
+ return dbd_rebind_ph(sth, imp_sth, phs);
+}
+
+
+/* --- functions to 'complete' the fetch of a value --- */
+
+void
+dbd_phs_sv_complete(phs_t *phs, SV *sv, I32 debug)
+{
+ dTHX;
+ char *note = "";
+ /* XXX doesn't check arcode for error, caller is expected to */
+
+ if (phs->indp == 0) { /* is okay */
+
+ if (phs->is_inout && phs->alen == SvLEN(sv)) {
+
+ /* if the placeholder has not been assigned to then phs->alen */
+ /* is left untouched: still set to SvLEN(sv). If we use that */
+ /* then we'll get garbage bytes beyond the original contents. */
+ phs->alen = SvCUR(sv);
+ note = " UNTOUCHED?";
+ }
+
+ if (SvPVX(sv)) {
+ SvCUR_set(sv, phs->alen);
+ *SvEND(sv) = '\0';
+ SvPOK_only_UTF8(sv);
+ }
+ else { /* shouldn't happen */
+ debug = 2;
+ dbd_verbose =2;
+ note = " [placeholder has no data buffer]";
+ }
+
+ if (debug >= 2 || dbd_verbose >=2)
+ PerlIO_printf(DBILOGFP, " out %s = %s (arcode %d, ind %d, len %d)%s\n",
+ phs->name, neatsvpv(sv,0), phs->arcode, phs->indp, phs->alen, note);
+ }
+ else {
+ if (phs->indp > 0 || phs->indp == -2) { /* truncated */
+ if (SvPVX(sv)) {
+ SvCUR_set(sv, phs->alen);
+ *SvEND(sv) = '\0';
+ SvPOK_only_UTF8(sv);
+ }
+ else { /* shouldn't happen */
+ debug = 2;
+ dbd_verbose =2;
+ note = " [placeholder has no data buffer]";
+ }
+ if (debug >= 2 || dbd_verbose >=2)
+ PerlIO_printf(DBILOGFP,
+ " out %s = %s\t(TRUNCATED from %d to %ld, arcode %d)%s\n",
+ phs->name, neatsvpv(sv,0), phs->indp, (long)phs->alen, phs->arcode, note);
+ }
+ else {
+ if (phs->indp == -1) { /* is NULL */
+ (void)SvOK_off(phs->sv);
+ if (debug >= 2 || dbd_verbose >=2)
+ PerlIO_printf(DBILOGFP,
+ " out %s = undef (NULL, arcode %d)\n",
+ phs->name, phs->arcode);
+ }
+ else {
+ croak("panic dbd_phs_sv_complete: %s bad indp %d, arcode %d", phs->name, phs->indp, phs->arcode);
+ }
+ }
+ }
+}
+void
+dbd_phs_avsv_complete(phs_t *phs, I32 index, I32 debug)
+{
+ dTHX;
+ AV *av = (AV*)SvRV(phs->sv);
+ SV *sv = *av_fetch(av, index, 1);
+ dbd_phs_sv_complete(phs, sv, 0);
+ if (debug >= 2 || dbd_verbose >=2)
+ PerlIO_printf(DBILOGFP, " dbd_phs_avsv_complete out '%s'[%ld] = %s (arcode %d, ind %d, len %d)\n",
+ phs->name, (long)index, neatsvpv(sv,0), phs->arcode, phs->indp, phs->alen);
+}
+
+
+/* --- */
+
+
+int
+dbd_st_execute(SV *sth, imp_sth_t *imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */
+{
+ dTHR;
+ dTHX;
+ ub4 row_count = 0;
+ int debug = DBIS->debug;
+ int outparams = (imp_sth->out_params_av) ? AvFILL(imp_sth->out_params_av)+1 : 0;
+ D_imp_dbh_from_sth;
+ sword status;
+ int is_select = (imp_sth->stmt_type == OCI_STMT_SELECT);
+
+
+ if (debug >= 2 || dbd_verbose >= 2)
+ PerlIO_printf(DBILOGFP, " dbd_st_execute %s (out%d, lob%d)...\n",
+ oci_stmt_type_name(imp_sth->stmt_type), outparams, imp_sth->has_lobs);
+
+
+ /* Don't attempt execute for nested cursor. It would be meaningless,
+ and Oracle code has been seen to core dump */
+ if (imp_sth->nested_cursor) {
+ oci_error(sth, NULL, OCI_ERROR,
+ "explicit execute forbidden for nested cursor");
+ return -2;
+ }
+
+
+ if (outparams) { /* check validity of bind_param_inout SV's */
+ int i = outparams;
+ while(--i >= 0) {
+ phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]);
+ SV *sv = phs->sv;
+ /* Make sure we have the value in string format. Typically a number */
+ /* will be converted back into a string using the same bound buffer */
+ /* so the progv test below will not trip. */
+
+ /* is the value a null? */
+ phs->indp = (SvOK(sv)) ? 0 : -1;
+
+ if (phs->out_prepost_exec) {
+ if (!phs->out_prepost_exec(sth, imp_sth, phs, 1))
+ return -2; /* out_prepost_exec already called ora_error() */
+ }
+ else
+ if (SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVAV) {
+ if (debug >= 2 || dbd_verbose >=2)
+ PerlIO_printf(DBILOGFP,
+ " with %s = [] (len %ld/%ld, indp %d, otype %d, ptype %d)\n",
+ phs->name,
+ (long)phs->alen, (long)phs->maxlen, phs->indp,
+ phs->ftype, (int)SvTYPE(sv));
+ av_clear((AV*)SvRV(sv));
+ }
+ else
+ /* Some checks for mutated storage since we pointed oracle at it. */
+ if (SvTYPE(sv) != phs->sv_type
+ || (SvOK(sv) && !SvPOK(sv))
+ /* SvROK==!SvPOK so cursor (SQLT_CUR) handle will call dbd_rebind_ph */
+ /* that suits us for now */
+ || SvPVX(sv) != phs->progv
+ || (SvPOK(sv) && SvCUR(sv) > UB2MAXVAL)
+ ) {
+ if (!dbd_rebind_ph(sth, imp_sth, phs))
+ croak("Can't rebind placeholder %s", phs->name);
+ }
+ else {
+ /* String may have grown or shrunk since it was bound */
+ /* so tell Oracle about it's current length */
+ ub2 prev_alen = phs->alen;
+ phs->alen = (SvOK(sv)) ? SvCUR(sv) + phs->alen_incnull : 0+phs->alen_incnull;
+ if (debug >= 2 || dbd_verbose >=2)
+ PerlIO_printf(DBILOGFP,
+ " with %s = '%.*s' (len %ld(%ld)/%ld, indp %d, otype %d, ptype %d)\n",
+ phs->name, (int)phs->alen,
+ (phs->indp == -1) ? "" : SvPVX(sv),
+ (long)phs->alen, (long)prev_alen, (long)phs->maxlen, phs->indp,
+ phs->ftype, (int)SvTYPE(sv));
+ }
+ }
+ }
+
+
+ if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && !is_select) {
+ imp_sth->exe_mode=OCI_COMMIT_ON_SUCCESS;
+ /* we don't AutoCommit on select so LOB locators work */
+ } else if(imp_sth->exe_mode!=OCI_STMT_SCROLLABLE_READONLY){
+
+ imp_sth->exe_mode=OCI_DEFAULT;
+ }
+
+
+ if (debug >= 2 || dbd_verbose >= 2)
+ PerlIO_printf(DBILOGFP,"Statement Execute Mode is %d (%s)\n",imp_sth->exe_mode,oci_exe_mode(imp_sth->exe_mode));
+
+
+ OCIStmtExecute_log_stat(imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp,
+ (ub4)(is_select ? 0 : 1),
+ 0, 0, 0,(ub4)imp_sth->exe_mode,status);
+
+
+ if (status != OCI_SUCCESS) { /* may be OCI_ERROR or OCI_SUCCESS_WITH_INFO etc */
+ /* we record the error even for OCI_SUCCESS_WITH_INFO */
+ oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIStmtExecute"));
+ /* but only bail out here if not OCI_SUCCESS_WITH_INFO */
+ if (status != OCI_SUCCESS_WITH_INFO)
+ return -2;
+ }
+
+ if (is_select) {
+ DBIc_ACTIVE_on(imp_sth);
+ DBIc_ROW_COUNT(imp_sth) = 0; /* reset (possibly re-exec'ing) */
+ row_count = 0;
+ }
+ else {
+ OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
+ }
+
+ if (debug >= 2 || dbd_verbose >= 2) {
+ ub2 sqlfncode;
+ OCIAttrGet_stmhp_stat(imp_sth, &sqlfncode, 0, OCI_ATTR_SQLFNCODE, status);
+ PerlIO_printf(DBILOGFP,
+ " dbd_st_execute %s returned (%s, rpc%ld, fn%d, out%d)\n",
+ oci_stmt_type_name(imp_sth->stmt_type),
+ oci_status_name(status),
+ (long)row_count, sqlfncode, imp_sth->has_inout_params);
+ }
+
+ if (is_select && !imp_sth->done_desc) {
+ /* describe and allocate storage for results (if any needed) */
+ if (!dbd_describe(sth, imp_sth))
+ return -2; /* dbd_describe already called oci_error() */
+ }
+
+ if (imp_sth->has_lobs && imp_sth->stmt_type != OCI_STMT_SELECT) {
+ if (!post_execute_lobs(sth, imp_sth, row_count))
+ return -2; /* post_insert_lobs already called oci_error() */
+ }
+
+ if (outparams) { /* check validity of bound output SV's */
+ int i = outparams;
+ while(--i >= 0) {
+ /* phs->alen has been updated by Oracle to hold the length of the result */
+ phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]);
+ SV *sv = phs->sv;
+ if (debug >= 2 || dbd_verbose >= 2) {
+ PerlIO_printf(DBILOGFP,
+ "dbd_st_execute(): Analyzing inout parameter '%s of type=%d'\n",
+ phs->name,phs->ftype);
+ }
+ if( phs->ftype == ORA_VARCHAR2_TABLE ){
+ dbd_phs_ora_varchar2_table_fixup_after_execute(phs);
+ continue;
+ }
+ if( phs->ftype == ORA_NUMBER_TABLE ){
+ dbd_phs_ora_number_table_fixup_after_execute(phs);
+ continue;
+ }
+
+ if (phs->out_prepost_exec) {
+ if (!phs->out_prepost_exec(sth, imp_sth, phs, 0))
+ return -2; /* out_prepost_exec already called ora_error() */
+ }
+ else {
+ if (SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVAV) {
+ AV *av = (AV*)SvRV(sv);
+ I32 avlen = AvFILL(av);
+ if (avlen >= 0)
+ dbd_phs_avsv_complete(phs, avlen, debug);
+ }
+ else {
+ dbd_phs_sv_complete(phs, sv, debug);
+ }
+ }
+ }
+ }
+
+ return row_count; /* row count (0 will be returned as "0E0") */
+}
+
+static int
+do_bind_array_exec(sth, imp_sth, phs, utf8)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ phs_t *phs;
+ int utf8;
+{
+ dTHX;
+ sword status;
+ ub1 csform;
+ ub2 csid;
+ int trace_level = DBIS->debug;
+
+ OCIBindByName_log_stat(imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
+ (text*)phs->name, (sb4)strlen(phs->name),
+ 0,
+ phs->maxlen ? (sb4)phs->maxlen : 1, /* else bind "" fails */
+ (ub2)phs->ftype, 0,
+ NULL, /* ub2 *alen_ptr not needed with OCIBindDynamic */
+ 0,
+ 0, /* max elements that can fit in allocated array */
+ NULL, /* (ptr to) current number of elements in array */
+ (ub4)OCI_DATA_AT_EXEC,
+ status);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBindByName");
+ return 0;
+ }
+
+PerlIO_printf(DBILOGFP, "OCI_ATTR_CHARSET_ID=%d\n\n",phs->csid_orig);
+
+ OCIAttrGet_log_stat(phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, (ub4)0 ,
+ OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
+
+PerlIO_printf(DBILOGFP, "OCI_ATTR_CHARSET_ID=%d\n\n",phs->csid_orig);
+ OCIBindDynamic_log(phs->bndhp, imp_sth->errhp,
+ (dvoid *)phs, dbd_phs_in,
+ (dvoid *)phs, dbd_phs_out, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIBindDynamic");
+ return 0;
+ }
+
+PerlIO_printf(DBILOGFP, "do_bind_array_exec() (3a ): bind %s <== [array of values] "
+ "(%s, %s, csid %d->%d->%d, ftype %d (%s), csform %d->%d, maxlen %lu, maxdata_size %lu)\n",
+ phs->name,
+ (phs->is_inout) ? "inout" : "in",
+ (utf8 ? "is-utf8" : "not-utf8"),
+ phs->csid_orig, phs->csid, csid,
+ phs->ftype,sql_typecode_name(phs->ftype), phs->csform, csform,
+ (unsigned long)phs->maxlen, (unsigned long)phs->maxdata_size);
+
+
+ /* copied and adapted from dbd_rebind_ph */
+ csform = phs->csform;
+ if (!csform && (utf8 & ARRAY_BIND_UTF8)) {
+ /* try to default csform to avoid translation through non-unicode */
+ if (CSFORM_IMPLIES_UTF8(SQLCS_IMPLICIT)) /* prefer IMPLICIT */
+ csform = SQLCS_IMPLICIT;
+ else if (CSFORM_IMPLIES_UTF8(SQLCS_NCHAR))
+ csform = SQLCS_NCHAR; /* else leave csform == 0 */
+
+/* if (trace_level || dbd_verbose <= 1)
+ PerlIO_printf(DBILOGFP, "do_bind_array_exec() (2): rebinding %s with UTF8 value %s", phs->name,
+ (csform == SQLCS_IMPLICIT) ? "so setting csform=SQLCS_IMPLICIT" :
+ (csform == SQLCS_NCHAR) ? "so setting csform=SQLCS_NCHAR" :
+ "but neither CHAR nor NCHAR are unicode\n");*/
+ }
+
+ if (csform) {
+ /* set OCI_ATTR_CHARSET_FORM before we get the default OCI_ATTR_CHARSET_ID */
+ OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,&csform, (ub4) 0, (ub4) OCI_ATTR_CHARSET_FORM, imp_sth->errhp, status);
+ if ( status != OCI_SUCCESS ) {
+ oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_FORM)"));
+ return 0;
+ }
+ }
+
+ if (!phs->csid_orig) { /* get the default csid Oracle would use */
+ OCIAttrGet_log_stat(phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, (ub4)0 ,
+ OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
+ }
+
+ /* if app has specified a csid then use that, else use default */
+
+ csid = (phs->csid) ? phs->csid : phs->csid_orig;
+ /* if data is utf8 but charset isn't then switch to utf8 csid if possible */
+
+ PerlIO_printf(DBILOGFP, " csid=%d utf8=%d \n",csid,utf8);
+
+ PerlIO_printf(DBILOGFP, " ARRAY_BIND_UTF8=%d CS_IS_NOT_UTF8=%d \n",ARRAY_BIND_UTF8,CS_IS_NOT_UTF8(csid));
+
+ PerlIO_printf(DBILOGFP, " ARRAY_BIND_UTF8=%d CS_IS_NOT_UTF8=%d \n",ARRAY_BIND_UTF8,CS_IS_UTF8(csid));
+ if ((utf8 & ARRAY_BIND_UTF8) && CS_IS_NOT_UTF8(csid)) {
+ /* if the specified or default csid is not utf8 _compatible_ AND we have */
+ /* mixed utf8 and native (non-utf8) data, then it's a fatal problem */
+ /* utf8 _compatible_ means, can be upgraded to utf8, ie. utf8 or ascii */
+
+ PerlIO_printf(DBILOGFP, " phs->csid=%d phs->csform=%d \n", phs->csid , phs->csform);
+ PerlIO_printf(DBILOGFP, " csid=%d \n", csid);
+
+ csid = (utf8 && !CS_IS_UTF8(csid)) ? utf8_csid : CSFORM_IMPLIED_CSID(csform);
+ phs->csid = csid;
+ phs->csform = csform;
+
+
+ PerlIO_printf(DBILOGFP, " out phs->csid=%d phs->csform=%d \n", phs->csid , phs->csform);
+ PerlIO_printf(DBILOGFP, " out csid=%d \n", csid);
+
+
+
+/*# if ((utf8 & ARRAY_BIND_NATIVE) && !CS_IS_UTF8_COMPATIBLE(csid)) {*/
+ PerlIO_printf(DBILOGFP, "Can't mix utf8 and non-utf8 in array bind\n");
+ /* croak("Can't mix utf8 and non-utf8 in array bind");*/
+ /* } else {
+ csid = utf8_csid; not al32utf8_csid here on purpose
+ }*/
+ }
+
+
+#ifdef OCI_ATTR_CHARSET_ID
+
+ PerlIO_printf(DBILOGFP, "OCI_ATTR_CHARSET_ID is set \n");
+
+
+#else
+ /* Effectively only used so AL32UTF8 works properly */
+ PerlIO_printf(DBILOGFP, "OCI_ATTR_CHARSET_ID is Not set \n");
+
+
+#endif /* OCI_ATTR_CHARSET_ID */
+ /* if data is utf8 but charset isn't then switch to utf8 csid */
+
+ if (trace_level >= 3 || dbd_verbose <= 3 )
+ PerlIO_printf(DBILOGFP, "do_bind_array_exec() (3): bind %s <== [array of values] "
+ "(%s, %s, csid %d->%d->%d, ftype %d (%s), csform %d->%d, maxlen %lu, maxdata_size %lu)\n",
+ phs->name,
+ (phs->is_inout) ? "inout" : "in",
+ (utf8 ? "is-utf8" : "not-utf8"),
+ phs->csid_orig, phs->csid, csid,
+ phs->ftype,sql_typecode_name(phs->ftype), phs->csform, csform,
+ (unsigned long)phs->maxlen, (unsigned long)phs->maxdata_size);
+
+
+ if (csid) {
+ OCIAttrSet_log_stat(phs->bndhp, (ub4) OCI_HTYPE_BIND,
+ &csid, (ub4) 0, (ub4) OCI_ATTR_CHARSET_ID, imp_sth->errhp, status);
+ if ( status != OCI_SUCCESS ) {
+ oci_error(sth, imp_sth->errhp, status, ora_sql_error(imp_sth,"OCIAttrSet (OCI_ATTR_CHARSET_ID)"));
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+static void
+init_bind_for_array_exec(phs)
+ phs_t *phs;
+{
+ dTHX;
+ if (phs->sv == &sv_undef) { /* first bind for this placeholder */
+ phs->is_inout = 0;
+ phs->maxlen = 1;
+ /* treat Oracle7 SQLT_CUR as SQLT_RSET for Oracle8 */
+ if (phs->ftype==102)
+ phs->ftype = 116;
+ /* some types require the trailing null included in the length. */
+ /* SQLT_STR=5=STRING, SQLT_AVC=97=VARCHAR */
+ phs->alen_incnull = (phs->ftype==SQLT_STR || phs->ftype==SQLT_AVC);
+ }
+}
+
+ int
+ora_st_execute_array(sth, imp_sth, tuples, tuples_status, columns, exe_count)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ SV *tuples;
+ SV *tuples_status;
+ SV *columns;
+ ub4 exe_count;
+{
+ dTHX;
+ dTHR;
+ /*ub4 row_count = 0;*/
+ int debug = DBIS->debug;
+ D_imp_dbh_from_sth;
+ sword status, exe_status;
+ int is_select = (imp_sth->stmt_type == OCI_STMT_SELECT);
+ AV *tuples_av, *tuples_status_av, *columns_av;
+ ub4 oci_mode;
+ ub4 num_errs;
+ int i,j;
+ int autocommit = DBIc_has(imp_dbh,DBIcf_AutoCommit);
+ SV **sv_p;
+ phs_t **phs;
+ SV *sv;
+ AV *av;
+ int param_count;
+ char namebuf[30];
+ STRLEN len;
+ int outparams = (imp_sth->out_params_av) ? AvFILL(imp_sth->out_params_av)+1 : 0;
+ int *utf8_flgs;
+
+ if (debug >= 2 || dbd_verbose <=2)
+ PerlIO_printf(DBILOGFP, " ora_st_execute_array %s count=%d (%s %s %s)...\n",
+ oci_stmt_type_name(imp_sth->stmt_type), exe_count,
+ neatsvpv(tuples,0), neatsvpv(tuples_status,0),
+ neatsvpv(columns, 0));
+
+ if (is_select) {
+ croak("ora_st_execute_array(): SELECT statement not supported "
+ "for array operation.");
+ }
+
+ if (imp_sth->has_lobs) {
+ croak("ora_st_execute_array(): LOBs not "
+ "supported for array operation.");
+ }
+
+ /* Check that the `tuples' parameter is an array ref, find the length,
+ and store it in the statement handle for the OCI callback. */
+ if(!SvROK(tuples) || SvTYPE(SvRV(tuples)) != SVt_PVAV) {
+ croak("ora_st_execute_array(): Not an array reference.");
+ }
+ tuples_av = (AV*)SvRV(tuples);
+
+ /* Check the `columns' parameter. */
+ if(SvTRUE(columns)) {
+ if(!SvROK(columns) || SvTYPE(SvRV(columns)) != SVt_PVAV) {
+ croak("ora_st_execute_array(): columns not an array peference.");
+ }
+ columns_av = (AV*)SvRV(columns);
+ } else {
+ columns_av = NULL;
+ }
+ /* Check the `tuples_status' parameter. */
+ if(SvTRUE(tuples_status)) {
+ if(!SvROK(tuples_status) || SvTYPE(SvRV(tuples_status)) != SVt_PVAV) {
+ croak("ora_st_execute_array(): tuples_status not an array reference.");
+ }
+ tuples_status_av = (AV*)SvRV(tuples_status);
+ av_fill(tuples_status_av, exe_count - 1);
+ /* Fill in 'unknown' exe count in every element (know not how to get
+ individual execute row counts from OCI). */
+ for(i = 0; (unsigned int) i < exe_count; i++) {
+ av_store(tuples_status_av, i, newSViv((IV)-1));
+ }
+ } else {
+ tuples_status_av = NULL;
+ }
+
+ /* Nothing to do if no tuples. */
+ if(exe_count <= 0)
+ return 0;
+
+ /* Ensure proper OCIBindByName() calls for all placeholders.
+ if(!ora_st_bind_for_array_exec(sth, imp_sth, tuples_av, exe_count,
+ DBIc_NUM_PARAMS(imp_sth), columns_av))
+ return -2;
+
+ fix for Perl undefined warning. Moved out of function back out to main code
+ Still ensures proper OCIBindByName*/
+
+ param_count=DBIc_NUM_PARAMS(imp_sth);
+ phs = safemalloc(param_count*sizeof(*phs));
+ utf8_flgs = safemalloc(param_count*sizeof(int));
+ memset(phs, 0, param_count*sizeof(*phs));
+ memset(utf8_flgs, 0, param_count*sizeof(int));
+
+
+ for(j = 0; (unsigned int) j < exe_count; j++) {
+
+ sv_p = av_fetch(tuples_av, j, 0);
+ if(sv_p == NULL) {
+ Safefree(phs);
+ Safefree(utf8_flgs);
+ croak("Cannot fetch tuple %d", j);
+ }
+ sv = *sv_p;
+ if(!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV) {
+ Safefree(phs);
+ Safefree(utf8_flgs);
+ croak("Not an array ref in element %d", j);
+ }
+ av = (AV*)SvRV(sv);
+ for(i = 0; i < param_count; i++) {
+ if(!phs[i]) {
+ SV **phs_svp;
+ sprintf(namebuf, ":p%d", i+1);
+ phs_svp = hv_fetch(imp_sth->all_params_hv,
+ namebuf, strlen(namebuf), 0);
+ if (phs_svp == NULL) {
+ Safefree(phs);
+ Safefree(utf8_flgs);
+ croak("Can't execute for non-existent placeholder :%d", i);
+ }
+ phs[i] = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */
+ if(phs[i]->idx < 0) {
+ Safefree(phs);
+ Safefree(utf8_flgs);
+ croak("Placeholder %d not of ?/:1 type", i);
+ }
+ init_bind_for_array_exec(phs[i]);
+ }
+ sv_p = av_fetch(av, phs[i]->idx, 0);
+ if(sv_p == NULL) {
+ Safefree(phs);
+ Safefree(utf8_flgs);
+ croak("Cannot fetch value for param %d in entry %d", i, j);
+ }
+
+ sv = *sv_p;
+
+ /*check to see if value sv is a null (undef) if it is upgrade it*/
+ if (!SvOK(sv)) {
+ if(SvUPGRADE(sv, SVt_PV)){} /* For GCC not to warn on unused result */
+ }
+ else {
+ SvPV(sv, len);
+ }
+
+
+ /* Find the value length, and increase maxlen if needed. */
+ if(SvROK(sv)) {
+ Safefree(phs);
+ Safefree(utf8_flgs);
+ croak("Can't bind a reference (%s) for param %d, entry %d",
+ neatsvpv(sv,0), i, j);
+ }
+ if(len > (unsigned int) phs[i]->maxlen)
+ phs[i]->maxlen = len;
+
+ /* update the utf8_flgs for this value */
+
+ PerlIO_printf(DBILOGFP, "\n SvUTF8(sv)=%d. and sv=%s..\n",SvUTF8(sv),neatsvpv(sv,1));
+
+
+
+
+ if (SvUTF8(sv)) {
+ /*STRLEN len2;
+ char* xx;
+ xx=SvPVutf8( sv, len2);*/
+ utf8_flgs[i] |= ARRAY_BIND_UTF8;
+ }
+ else {
+ /*STRLEN len2;
+ char* xx;
+ bool is_utf8;
+ xx=SvPVutf8( sv, len2);
+ PerlIO_printf(DBILOGFP, " xx=%s,len2=%d...\n",xx,len2);
+
+ is_utf8=is_utf8_string((U8*)sv,1);
+
+ PerlIO_printf(DBILOGFP, "is_utf8=%d...\n",is_utf8);
+*/
+
+ utf8_flgs[i] |= ARRAY_BIND_NATIVE;
+
+ }
+
+
+
+ /* Do OCI bind calls on last iteration. */
+ if( ((unsigned int) j ) == exe_count - 1 ) {
+ if(!do_bind_array_exec(sth, imp_sth, phs[i], utf8_flgs[i])) {
+ Safefree(phs);
+ Safefree(utf8_flgs);
+ }
+ }
+ }
+ }
+ Safefree(phs);
+ Safefree(utf8_flgs);
+
+ /* Store array of bind typles, for use in OCIBindDynamic() callback. */
+ imp_sth->bind_tuples = tuples_av;
+ imp_sth->rowwise = (columns_av == NULL);
+
+ oci_mode = OCI_BATCH_ERRORS;
+ if(autocommit)
+ oci_mode |= OCI_COMMIT_ON_SUCCESS;
+
+ OCIStmtExecute_log_stat(imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp,
+ exe_count, 0, 0, 0, oci_mode, exe_status);
+
+ imp_sth->bind_tuples = NULL;
+
+ if (exe_status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, exe_status, ora_sql_error(imp_sth,"OCIStmtExecute"));
+ if(exe_status != OCI_SUCCESS_WITH_INFO)
+ return -2;
+ }
+
+ if (outparams){
+ i=outparams;
+ while(--i >= 0) {
+ phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]);
+ SV *sv = phs->sv;
+ if (SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVAV) {
+ AV *av = (AV*)SvRV(sv);
+ I32 avlen = AvFILL(av);
+ for (j=0;j<=avlen;j++){
+ SV *sv2 = *av_fetch(av, j, 1);
+ dbd_phs_avsv_complete(phs, j, debug);
+ }
+ }
+ }
+ }
+
+ OCIAttrGet_stmhp_stat(imp_sth, &num_errs, 0, OCI_ATTR_NUM_DML_ERRORS, status);
+
+ if (debug >= 6 || dbd_verbose >= 6)
+ PerlIO_printf(DBILOGFP, " ora_st_execute_array %d errors in batch.\n",
+ num_errs);
+
+ if(num_errs && tuples_status_av) {
+ OCIError *row_errhp, *tmp_errhp;
+ ub4 row_off;
+ SV *err_svs[2];
+ /*AV *err_av;*/
+ sb4 err_code;
+
+ err_svs[0] = newSViv((IV)0);
+ err_svs[1] = newSVpvn("", 0);
+ 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++) {
+ OCIParamGet_log_stat(imp_sth->errhp, OCI_HTYPE_ERROR,
+ tmp_errhp, (dvoid *)&row_errhp,
+ (ub4)i, status);
+ OCIAttrGet_log_stat(row_errhp, OCI_HTYPE_ERROR, &row_off, 0,
+ OCI_ATTR_DML_ROW_OFFSET, imp_sth->errhp, status);
+ if (debug >= 6 || dbd_verbose >= 6)
+ PerlIO_printf(DBILOGFP, " ora_st_execute_array error in row %d.\n",
+ row_off);
+ sv_setpv(err_svs[1], "");
+ 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))));
+ }
+ OCIHandleFree_log_stat(tmp_errhp, OCI_HTYPE_ERROR, status);
+ OCIHandleFree_log_stat(row_errhp, OCI_HTYPE_ERROR, status);
+
+ /* Do a commit here if autocommit is set, since Oracle
+ doesn't do that for us when some rows are in error. */
+ if(autocommit) {
+ OCITransCommit_log_stat(imp_sth->svchp, imp_sth->errhp,
+ OCI_DEFAULT, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCITransCommit");
+ return -2;
+ }
+ }
+ }
+
+ 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;
+ }
+}
+
+
+
+
+int
+dbd_st_blob_read(SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset)
+{
+ dTHX;
+ ub4 retl = 0;
+ SV *bufsv;
+ imp_fbh_t *fbh = &imp_sth->fbh[field];
+ int ftype = fbh->ftype;
+
+ bufsv = SvRV(destrv);
+ sv_setpvn(bufsv,"",0); /* ensure it's writable string */
+
+#ifdef UTF8_SUPPORT
+ if (ftype == 112 && CS_IS_UTF8(ncharsetid) ) {
+ return ora_blob_read_mb_piece(sth, imp_sth, fbh, bufsv,
+ offset, len, destoffset);
+ }
+#endif /* UTF8_SUPPORT */
+
+ SvGROW(bufsv, (STRLEN)destoffset+len+1); /* SvGROW doesn't do +1 */
+
+ retl = ora_blob_read_piece(sth, imp_sth, fbh, bufsv,
+ offset, len, destoffset);
+ if (!SvOK(bufsv)) { /* ora_blob_read_piece recorded error */
+ ora_free_templob(sth, imp_sth, (OCILobLocator*)fbh->desc_h);
+ return 0;
+ }
+ ftype = ftype; /* no unused */
+
+ if (DBIS->debug >= 3 || dbd_verbose >=3)
+ PerlIO_printf(DBILOGFP,
+ " blob_read field %d+1, ftype %d, offset %ld, len %ld, destoffset %ld, retlen %ld\n",
+ field, imp_sth->fbh[field].ftype, offset, len, destoffset, (long)retl);
+
+ SvCUR_set(bufsv, destoffset+retl);
+
+ *SvEND(bufsv) = '\0'; /* consistent with perl sv_setpvn etc */
+
+ return 1;
+}
+
+
+int
+dbd_st_rows(SV *sth, imp_sth_t *imp_sth)
+{
+ dTHX;
+ ub4 row_count = 0;
+ sword status;
+ OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCIAttrGet OCI_ATTR_ROW_COUNT");
+ return -1;
+ }
+ return row_count;
+}
+
+
+int
+dbd_st_finish(SV *sth, imp_sth_t *imp_sth)
+{
+ dTHR;
+ dTHX;
+ D_imp_dbh_from_sth;
+ sword status;
+ int num_fields = DBIc_NUM_FIELDS(imp_sth);
+ int i;
+
+
+ if (DBIc_DBISTATE(imp_sth)->debug >= 6 || dbd_verbose >= 6)
+ PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_st_finish\n");
+
+ if (!DBIc_ACTIVE(imp_sth))
+ return 1;
+
+ /* Cancel further fetches from this cursor. */
+ /* We don't close the cursor till DESTROY (dbd_st_destroy). */
+ /* The application may re execute(...) it. */
+
+ /* Turn off ACTIVE here regardless of errors below. */
+ DBIc_ACTIVE_off(imp_sth);
+
+ for(i=0; i < num_fields; ++i) {
+ imp_fbh_t *fbh = &imp_sth->fbh[i];
+ if (fbh->fetch_cleanup) fbh->fetch_cleanup(sth, fbh);
+ }
+
+ if (dirty) /* don't walk on the wild side */
+ return 1;
+
+ if (!DBIc_ACTIVE(imp_dbh)) /* no longer connected */
+ return 1;
+
+ /*fetching on a cursor with row =0 will explicitly free any
+ server side resources this is what the next statment does,
+ not sure if we need this for non scrolling cursors they should die on
+ a OER(1403) no records)*/
+
+ OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0,
+ OCI_FETCH_NEXT,0, status);
+
+ if (status != OCI_SUCCESS && status != OCI_SUCCESS_WITH_INFO) {
+ oci_error(sth, imp_sth->errhp, status, "Finish OCIStmtFetch");
+ return 0;
+ }
+ return 1;
+}
+
+
+void
+ora_free_fbh_contents(imp_fbh_t *fbh)
+{
+ dTHX;
+ if (fbh->fb_ary)
+ fb_ary_free(fbh->fb_ary);
+ sv_free(fbh->name_sv);
+ if (fbh->desc_h)
+ OCIDescriptorFree_log(fbh->desc_h, fbh->desc_t);
+ if (fbh->obj)
+ Safefree(fbh->obj);
+
+}
+
+void
+ora_free_phs_contents(phs_t *phs)
+{
+ dTHX;
+ if (phs->desc_h)
+ OCIDescriptorFree_log(phs->desc_h, phs->desc_t);
+ if( phs->array_buf ){
+ free(phs->array_buf);
+ phs->array_buf=NULL;
+ }
+ if( phs->array_indicators ){
+ free(phs->array_indicators);
+ phs->array_indicators=NULL;
+ }
+ if( phs->array_lengths ){
+ free(phs->array_lengths);
+ phs->array_lengths=NULL;
+ }
+
+ phs->array_buflen=0;
+ phs->array_numallocated=0;
+ sv_free(phs->ora_field);
+ sv_free(phs->sv);
+}
+
+void
+ora_free_templob(SV *sth, imp_sth_t *imp_sth, OCILobLocator *lobloc)
+{
+ dTHX;
+#if defined(OCI_HTYPE_DIRPATH_FN_CTX) /* >= 9.0 */
+ boolean is_temporary = 0;
+ sword status;
+ OCILobIsTemporary_log_stat(imp_sth->envhp, imp_sth->errhp, lobloc, &is_temporary, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCILobIsTemporary");
+ return;
+ }
+
+ if (is_temporary) {
+ if (DBIS->debug >= 3 || dbd_verbose >=3 ) {
+ PerlIO_printf(DBILOGFP, " OCILobFreeTemporary %s\n", oci_status_name(status));
+ }
+ OCILobFreeTemporary_log_stat(imp_sth->svchp, imp_sth->errhp, lobloc, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCILobFreeTemporary");
+ return;
+ }
+ }
+#endif
+}
+
+
+void
+dbd_st_destroy(SV *sth, imp_sth_t *imp_sth)
+{
+ int fields;
+ int i;
+ sword status;
+ dTHX ;
+
+ /* Don't free the OCI statement handle for a nested cursor. It will
+ be reused by Oracle on the next fetch. Indeed, we never
+ free these handles. Experiment shows that Oracle frees them
+ when they are no longer needed.
+ */
+ /* get rid of describe handle if used*/
+
+ /* if we are using a scrolling cursor we should get rid of the
+ cursor by fetching row 0 */
+
+ if (imp_sth->exe_mode==OCI_STMT_SCROLLABLE_READONLY){
+ OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0,OCI_FETCH_NEXT,0, status);
+ }
+
+ if (imp_sth->dschp){
+ OCIHandleFree_log_stat(imp_sth->dschp, OCI_HTYPE_DESCRIBE, status);
+ }
+
+
+ if (DBIc_DBISTATE(imp_sth)->debug >= 6 || dbd_verbose >= 6 )
+ PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_st_destroy %s\n",
+ (dirty) ? "(OCIHandleFree skipped during global destruction)" :
+ (imp_sth->nested_cursor) ?"(OCIHandleFree skipped for nested cursor)" : "");
+
+ if (!dirty) { /* XXX not ideal, leak may be a problem in some cases */
+ if (!imp_sth->nested_cursor) {
+ OCIHandleFree_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, status);
+ if (status != OCI_SUCCESS)
+ oci_error(sth, imp_sth->errhp, status, "OCIHandleFree");
+ }
+ }
+
+ /* Free off contents of imp_sth */
+
+ if (imp_sth->lob_refetch)
+ ora_free_lob_refetch(sth, imp_sth);
+
+ fields = DBIc_NUM_FIELDS(imp_sth);
+ imp_sth->in_cache = 0;
+ imp_sth->eod_errno = 1403;
+ for(i=0; i < fields; ++i) {
+ imp_fbh_t *fbh = &imp_sth->fbh[i];
+ ora_free_fbh_contents(fbh);
+
+ }
+ Safefree(imp_sth->fbh);
+ if (imp_sth->fbh_cbuf)
+ Safefree(imp_sth->fbh_cbuf);
+ Safefree(imp_sth->statement);
+
+ if (imp_sth->out_params_av)
+ sv_free((SV*)imp_sth->out_params_av);
+
+ if (imp_sth->all_params_hv) {
+ HV *hv = imp_sth->all_params_hv;
+ SV *sv;
+ char *key;
+ I32 retlen;
+ hv_iterinit(hv);
+ while( (sv = hv_iternextsv(hv, &key, &retlen)) != NULL ) {
+ if (sv != &sv_undef) {
+ phs_t *phs = (phs_t*)(void*)SvPVX(sv);
+ if (phs->desc_h && phs->desc_t == OCI_DTYPE_LOB)
+ ora_free_templob(sth, imp_sth, (OCILobLocator*)phs->desc_h);
+
+
+ ora_free_phs_contents(phs);
+ }
+ }
+ sv_free((SV*)imp_sth->all_params_hv);
+ }
+
+ DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
+
+}
+
+
+int
+dbd_st_STORE_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv)
+{
+ dTHX;
+ STRLEN kl;
+ SV *cachesv = NULL;
+ char *key = SvPV(keysv,kl);
+ if( imp_sth ) { /* For GCC not to warn on unused argument */}
+/*
+ int on = SvTRUE(valuesv);
+ int oraperl = DBIc_COMPAT(imp_sth); */
+
+ if (strEQ(key, "ora_fetchtest")) {
+ ora_fetchtest = SvIV(valuesv);
+ }
+ else
+ return FALSE;
+
+ if (cachesv) /* cache value for later DBI 'quick' fetch? */
+ hv_store((HV*)SvRV(sth), key, kl, cachesv, 0);
+ return TRUE;
+}
+
+
+SV *
+dbd_st_FETCH_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv)
+{
+ dTHX;
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ int i;
+ SV *retsv = NULL;
+ /* Default to caching results for DBI dispatch quick_FETCH */
+ int cacheit = TRUE;
+ /* int oraperl = DBIc_COMPAT(imp_sth); */
+
+ if (kl==13 && strEQ(key, "NUM_OF_PARAMS")) /* handled by DBI */
+ return Nullsv;
+
+ if (!imp_sth->done_desc && !dbd_describe(sth, imp_sth)) {
+ STRLEN lna;
+ /* dbd_describe has already called ora_error() */
+ /* we can't return Nullsv here because the xs code will */
+ /* then just pass the attribute name to DBI for FETCH. */
+ croak("Describe failed during %s->FETCH(%s): %ld: %s",
+ SvPV(sth,na), key, (long)SvIV(DBIc_ERR(imp_sth)),
+ SvPV(DBIc_ERRSTR(imp_sth),lna)
+ );
+ }
+
+ i = DBIc_NUM_FIELDS(imp_sth);
+
+ if (kl==4 && strEQ(key, "NAME")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0)
+ av_store(av, i, newSVpv((char*)imp_sth->fbh[i].name,0));
+
+ } else if (kl==11 && strEQ(key, "ParamValues")) {
+ HV *pvhv = newHV();
+ if (imp_sth->all_params_hv) {
+ SV *sv;
+ char *key;
+ I32 keylen;
+ hv_iterinit(imp_sth->all_params_hv);
+ while ( (sv = hv_iternextsv(imp_sth->all_params_hv, &key, &keylen)) ) {
+ phs_t *phs = (phs_t*)(void*)SvPVX(sv); /* placeholder struct */
+ hv_store(pvhv, key, keylen, newSVsv(phs->sv), 0);
+ }
+ }
+ retsv = newRV_noinc((SV*)pvhv);
+ cacheit = FALSE;
+
+ } else if (kl==11 && strEQ(key, "ora_lengths")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0)
+ av_store(av, i, newSViv((IV)imp_sth->fbh[i].disize));
+
+ } else if (kl==9 && strEQ(key, "ora_types")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0)
+ av_store(av, i, newSViv(imp_sth->fbh[i].dbtype));
+
+ } else if (kl==4 && strEQ(key, "TYPE")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0)
+ av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).dbtype));
+
+ } else if (kl==5 && strEQ(key, "SCALE")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0)
+ av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).scale));
+
+ } else if (kl==9 && strEQ(key, "PRECISION")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0)
+ av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).prec));
+
+#ifdef XXX
+ } else if (kl==9 && strEQ(key, "ora_rowid")) {
+ /* return current _binary_ ROWID (oratype 11) uncached */
+ /* Use { ora_type => 11 } when binding to a placeholder */
+ retsv = newSVpv((char*)&imp_sth->cda->rid, sizeof(imp_sth->cda->rid));
+ cacheit = FALSE;
+#endif
+
+ } else if (kl==17 && strEQ(key, "ora_est_row_width")) {
+ retsv = newSViv(imp_sth->est_width);
+ cacheit = TRUE;
+
+ } else if (kl==8 && strEQ(key, "NULLABLE")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0)
+ av_store(av, i, boolSV(imp_sth->fbh[i].nullok));
+
+ } else {
+ return Nullsv;
+ }
+ if (cacheit) { /* cache for next time (via DBI quick_FETCH) */
+ SV **svp = hv_fetch((HV*)SvRV(sth), key, kl, 1);
+ sv_free(*svp);
+ *svp = retsv;
+ (void)SvREFCNT_inc(retsv); /* so sv_2mortal won't free it */
+ }
+ return sv_2mortal(retsv);
+}
+
+/* --------------------------------------- */
+
+static sql_fbh_t
+ora2sql_type(imp_fbh_t* fbh) {
+ sql_fbh_t sql_fbh;
+ sql_fbh.dbtype = fbh->dbtype;
+ sql_fbh.prec = fbh->prec;
+ sql_fbh.scale = fbh->scale;
+
+ switch(fbh->dbtype) { /* oracle Internal (not external) types */
+ case SQLT_NUM:
+ if (fbh->scale == -127) { /* FLOAT, REAL, DOUBLE_PRECISION */
+ sql_fbh.dbtype = SQL_DOUBLE;
+ sql_fbh.scale = 0; /* better: undef */
+ if (fbh->prec == 0) { /* NUMBER; s. Oracle Bug# 2755842, 2235818 */
+ sql_fbh.prec = 126;
+ }
+ }
+ else if (fbh->scale == 0) {
+ if (fbh->prec == 0) { /* NUMBER */
+ sql_fbh.dbtype = SQL_DOUBLE;
+ sql_fbh.prec = 126;
+ }
+ else { /* INTEGER, NUMBER(p,0) */
+ sql_fbh.dbtype = SQL_DECIMAL; /* better: SQL_INTEGER */
+ }
+ }
+ else { /* NUMBER(p,s) */
+ sql_fbh.dbtype = SQL_DECIMAL; /* better: SQL_NUMERIC */
+ }
+ break;
+#ifdef SQLT_IBDOUBLE
+ case SQLT_BDOUBLE:
+ case SQLT_BFLOAT:
+ case SQLT_IBDOUBLE:
+ case SQLT_IBFLOAT:
+ sql_fbh.dbtype = SQL_DOUBLE;
+ sql_fbh.prec = 126;
+ break;
+#endif
+ case SQLT_CHR: sql_fbh.dbtype = SQL_VARCHAR; break;
+ case SQLT_LNG: sql_fbh.dbtype = SQL_LONGVARCHAR; break; /* long */
+ case SQLT_DAT: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP;break;
+ case SQLT_BIN: sql_fbh.dbtype = SQL_BINARY; break; /* raw */
+ case SQLT_LBI: sql_fbh.dbtype = SQL_LONGVARBINARY; break; /* long raw */
+ case SQLT_AFC: sql_fbh.dbtype = SQL_CHAR; break; /* Ansi fixed char */
+ case SQLT_CLOB: sql_fbh.dbtype = SQL_CLOB; break;
+ case SQLT_BLOB: sql_fbh.dbtype = SQL_BLOB; break;
+#ifdef SQLT_TIMESTAMP_TZ
+ case SQLT_DATE: sql_fbh.dbtype = SQL_DATE; break;
+ case SQLT_TIME: sql_fbh.dbtype = SQL_TIME; break;
+ case SQLT_TIME_TZ: sql_fbh.dbtype = SQL_TYPE_TIME_WITH_TIMEZONE; break;
+ case SQLT_TIMESTAMP: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP; break;
+ case SQLT_TIMESTAMP_TZ: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE; break;
+ case SQLT_TIMESTAMP_LTZ: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE; break;
+ case SQLT_INTERVAL_YM: sql_fbh.dbtype = SQL_INTERVAL_YEAR_TO_MONTH; break;
+ case SQLT_INTERVAL_DS: sql_fbh.dbtype = SQL_INTERVAL_DAY_TO_SECOND; break;
+#endif
+ default: sql_fbh.dbtype = -9000 - fbh->dbtype; /* else map type into DBI reserved standard range */
+ }
+ return sql_fbh;
+}
+
+static void
+dump_env_to_trace() {
+ dTHX;
+ PerlIO *fp = DBILOGFP;
+ int i = 0;
+ char *p;
+#ifndef __BORLANDC__
+ extern char **environ;
+#endif
+ PerlIO_printf(fp, "Environment variables:\n");
+ do {
+ p = (char*)environ[i++];
+ PerlIO_printf(fp,"\t%s\n",p);
+ } while ((char*)environ[i] != '\0');
+}
+
Modified: dbd-oracle/branches/utf8_ea/dbdimp.h
==============================================================================
--- dbd-oracle/branches/utf8_ea/dbdimp.h (original)
+++ dbd-oracle/branches/utf8_ea/dbdimp.h Mon Sep 29 10:34:35 2008
@@ -1,376 +1,379 @@
-/*
- Copyright (c) 1994-2006 Tim Bunce
- Copyright (c) 2006-2008 John Scoles (The Pythian Group), Canada
-
- See the COPYRIGHT section in the Oracle.pm file for terms.
-
-*/
-
-/* ====== define data types ====== */
-
-typedef struct imp_fbh_st imp_fbh_t;
-
-
-struct imp_drh_st {
- dbih_drc_t com; /* MUST be first element in structure */
- OCIEnv *envhp;
- int proc_handles; /* If true, the envhp handle is owned by ProC
- and must not be freed. */
- SV *ora_long;
- SV *ora_trunc;
- SV *ora_cache;
- SV *ora_cache_o; /* for ora_open() cache override */
-};
-
-
-/* Define dbh implementor data structure */
-struct imp_dbh_st {
- dbih_dbc_t com; /* MUST be first element in structure */
-
-#ifdef USE_ITHREADS
- int refcnt ; /* keep track of duped handles. MUST be first after com */
- struct imp_dbh_st * shared_dbh ; /* pointer to shared space from which to dup and keep refcnt */
- SV * shared_dbh_priv_sv ;
-#endif
-
- void *(*get_oci_handle) _((imp_dbh_t *imp_dbh, int handle_type, int flags));
- OCIEnv *envhp; /* copy of drh pointer */
- OCIError *errhp;
- OCIServer *srvhp;
- OCISvcCtx *svchp;
- OCISession *authp;
- int proc_handles; /* If true, srvhp, svchp, and authp handles
- are owned by ProC and must not be freed. */
- int RowCacheSize;
- int ph_type; /* default oratype for placeholders */
- ub1 ph_csform; /* default charset for placeholders */
- int parse_error_offset; /* position in statement of last error */
- int max_nested_cursors; /* limit on cached nested cursors per stmt */
- int array_chunk_size; /* the max size for an array bind */
-
-};
-
-#define DBH_DUP_OFF sizeof(dbih_dbc_t)
-#define DBH_DUP_LEN (sizeof(struct imp_dbh_st) - sizeof(dbih_dbc_t))
-
-
-typedef struct lob_refetch_st lob_refetch_t; /* Define sth implementor data structure */
-
-
-/*statement structure */
-struct imp_sth_st {
-
- dbih_stc_t com; /* MUST be first element in structure */
-
- void *(*get_oci_handle) _((imp_sth_t *imp_sth, int handle_type, int flags));
- OCIEnv *envhp; /* copy of dbh pointer */
- OCIError *errhp; /* copy of dbh pointer */
- OCIServer *srvhp; /* copy of dbh pointer */
- OCISvcCtx *svchp; /* copy of dbh pointer */
- OCIStmt *stmhp; /* oci statement handle */
- OCIDescribe *dschp; /* oci describe handle */
- int is_child; /* if this is child from a ref cursor or SP*/
- ub2 stmt_type; /* OCIAttrGet OCI_ATTR_STMT_TYPE */
- U16 auto_lob; /* use auto lobs*/
- int pers_lob; /*use dblink for lobs only for 10g Release 2. or later*/
- int clbk_lob; /*use dblink for lobs only for 10g Release 2. or later*/
- int piece_lob; /*use piece fetch for lobs*/
- ub4 piece_size; /*used in callback to set the size of the piece to get*/
- int has_lobs; /* Statement has bound LOBS*/
-
- lob_refetch_t *lob_refetch;
- int nested_cursor; /* cursors fetched from SELECTs */
- AV *bind_tuples; /* Bind tuples in array execute, or NULL */
- int rowwise; /* If true, bind_tuples is list of */
- /* tuples, otherwise list of columns. */
-
- /* Input Details */
- char *statement; /* sql (see sth_scan) */
- HV *all_params_hv; /* all params, keyed by name */
- AV *out_params_av; /* quick access to inout params */
- int ora_pad_empty; /* convert ""->" " when binding */
-
- /* Select Column Output Details */
- int done_desc; /* have we described this sth yet ? */
- imp_fbh_t *fbh; /* array of imp_fbh_t structs */
- char *fbh_cbuf; /* memory for all field names */
- int t_dbsize; /* raw data width of a row */
- UV long_readlen; /* local copy to handle oraperl */
- HV *fbh_tdo_hv; /* hash of row #(0 based) and tdo object name from ora_oci_type_names hash */
- /* Select Row Cache Details */
- sb4 cache_rows;
- int in_cache;
- int next_entry;
- int eod_errno;
- int est_width; /* est'd avg row width on-the-wire */
- /* (In/)Out Parameter Details */
- bool has_inout_params;
- /* execute mode*/
- /* will be using this alot later me thinks */
- ub4 exe_mode;
- /* fetch scrolling values */
- int fetch_orient;
- int fetch_offset;
- int fetch_position;
- int prefetch_memory; /* OCI_PREFETCH_MEMORY*/
- /* array fetch: state variables */
- bool rs_array_on; /* if array to be used */
- int rs_array_size; /* array size */
- int rs_array_num_rows; /* num rows in last fetch */
- int rs_array_idx; /* index of current row */
- sword rs_array_status; /* status of last fetch */
-};
-#define IMP_STH_EXECUTING 0x0001
-
-
-typedef struct fb_ary_st fb_ary_t; /* field buffer array */
-struct fb_ary_st { /* field buffer array EXPERIMENTAL */
- ub4 bufl; /* length of data buffer */
- ub4 cb_bufl; /* length of piece of data fetched in callback.*/
- ub4 piece_count;/*# of pieces retrieved*/
- sb2 *aindp; /* null/trunc indicator variable */
- ub1 *abuf; /* data buffer (points to sv data) */
- ub1 *cb_abuf; /*yet another buffer for picewise callbacks this means I only need to allocate memory once a prepare rather than at each fetch*/
- ub2 *arlen; /* length of returned data */
- ub2 *arcode; /* field level error status */
-};
-
-
-typedef struct fbh_obj_st fbh_obj_t; /*Ebbedded Object Descriptor */
-
-struct fbh_obj_st { /* embedded object or table will work recursively*/
- text *type_name; /*object's name (TDO)*/
- ub4 type_namel; /*length of the name*/
- OCIParam *parmdp; /*Describe attributes of the object OCI_DTYPE_PARAM*/
- OCIParam *parmap; /*Describe attributes of the object OCI_ATTR_COLLECTION_ELEMENT OCI_ATTR_PARAM*/
- OCIType *tdo; /*object's TDO handle */
- OCITypeCode typecode; /*object's OOCI_ATTR_TYPECODE */
- OCITypeCode col_typecode; /*if collection this is its OCI_ATTR_COLLECTION_TYPECODE */
- OCITypeCode element_typecode; /*if collection this is its element's OCI_ATTR_TYPECODE*/
- OCIRef *obj_ref; /*if an embeded object this is ref handle to its TDO*/
- OCIInd *obj_ind; /*Null indictator for object */
- OCIComplexObject *obj_value; /*the actual value from the DB*/
- OCIType *obj_type; /*if an embeded object this is the OCIType returned by a OCIObjectPin*/
- fbh_obj_t *fields; /*one object for each field/property*/
- int field_count; /*The number of fields Not really needed but nice to have*/
- AV *value; /*The value to send back to Perl This way there are no memory leaks*/
-};
-
-struct imp_fbh_st { /* field buffer EXPERIMENTAL */
- imp_sth_t *imp_sth; /* 'parent' statement */
- int field_num; /* 0..n-1 */
-
- /* Oracle's description of the field */
- OCIParam *parmdp;
- OCIDefine *defnp;
- void *desc_h; /* descriptor if needed (LOBs etc) */
- ub4 desc_t; /* OCI type of descriptor */
- ub4 define_mode; /*the normal case for a define*/
- int (*fetch_func) _((SV *sth, imp_fbh_t *fbh, SV *dest_sv));
- void (*fetch_cleanup) _((SV *sth, imp_fbh_t *fbh));
- ub2 dbtype; /* actual type of field (see ftype) */
- ub2 dbsize;
- ub2 prec; /* XXX docs say ub1 but ub2 is needed */
- sb1 scale;
- ub1 nullok;
- char *name;
- SV *name_sv; /* only set for OCI8 */
- /* OCI docs say OCI_ATTR_CHAR_USED is ub4, they're wrong */
- ub1 len_char_used; /* OCI_ATTR_CHAR_USED */
- ub2 len_char_size; /* OCI_ATTR_CHAR_SIZE */
- ub2 csid; /* OCI_ATTR_CHARSET_ID */
- ub1 csform; /* OCI_ATTR_CHARSET_FORM */
-
- ub4 disize; /* max display/buffer size */
- ub4 piece_size; /*used in callback to set the size of the piece to get*/
-
- char *bless; /* for Oracle::OCI style handle data */
- void *special; /* hook for special purposes (LOBs etc) */
- int pers_lob; /*for persistant lobs 10g Release 2. or later*/
- int clbk_lob; /*for persistant lobs 10g Release 2. or later*/
- int piece_lob; /*use piecewise fetch for lobs*/
- /* Our storage space for the field data as it's fetched */
- sword ftype; /* external datatype we wish to get */
- fb_ary_t *fb_ary ; /* field buffer array */
- /* if this is an embedded object we use this */
- fbh_obj_t *obj;
-
-
- };
-
- /* Placeholder structure */
- /* Note: phs_t is serialized into scalar value, and de-serialized then. */
- /* Be carefull! */
-
-typedef struct phs_st phs_t; /* scalar placeholder */
-
-struct phs_st { /* scalar placeholder EXPERIMENTAL */
- imp_sth_t *imp_sth; /* 'parent' statement */
- sword ftype; /* external OCI field type */
-
- SV *sv; /* the scalar holding the value */
- U32 sv_type; /* original sv type at time of bind */
- ub2 csid_orig; /* original oracle default csid */
- ub2 csid; /* 0 for automatic */
- ub1 csform; /* 0 for automatic */
- ub4 maxdata_size; /* set OCI_ATTR_MAXDATA_SIZE if >0 */
- bool is_inout;
-
- IV maxlen; /* max possible len (=allocated buffer) */
- /* Note: for array bind = buffer for each entry */
- OCIBind *bndhp;
- void *desc_h; /* descriptor if needed (LOBs etc) */
- ub4 desc_t; /* OCI type of desc_h */
- ub4 alen;
- ub2 arcode;
- int idx; /* 0-based index for ?/:1 style, or -1 */
-
- sb2 indp; /* null indicator */
- char *progv;
-
- int (*out_prepost_exec)_((SV *, imp_sth_t *, phs_t *, int pre_exec));
- SV *ora_field; /* from attribute (for LOB binds) */
- ub4 alen_incnull; /* 0 or 1 if alen should include null */
- /* Array bind support */
- char * array_buf; /* Temporary buffer = malloc(array_buflen) */
- int array_buflen; /* Allocated length of array_buf */
- int array_numstruct; /* Number of bound structures in buffer */
- OCIInd * array_indicators; /* Indicator array = malloc( array_numallocated * sizeof(OCIInd) ) */
- unsigned short *array_lengths; /* Array entries lengths = malloc( array_numallocated * sizeof(unsigned short) ) */
- int array_numallocated; /* Allocated number of indicators/lengths */
- int ora_maxarray_numentries; /* Number of entries to send allocated to Oracle. (may be less, than total allocated) */
-
- /* Support for different internal C-types, representing Oracle data */
- int ora_internal_type; /* Which C-type would be bound instead of SQLT_CHR. */
-
- char name[1]; /* struct is malloc'd bigger as needed */
-};
-
-
-/* ------ define functions and external variables ------ */
-
-extern int ora_fetchtest;
-extern int dbd_verbose;
-
-extern ub2 charsetid;
-extern ub2 ncharsetid;
-extern ub2 us7ascii_csid;
-extern ub2 utf8_csid;
-extern ub2 we8mswin1252; /*default for windows */
-extern ub2 al32utf8_csid;
-extern ub2 al16utf16_csid;
-
-#define CS_IS_UTF8( cs ) \
- ( ( cs == utf8_csid ) || ( cs == al32utf8_csid ) )
-
-#define CS_IS_UTF8_COMPATIBLE( cs ) \
- ( CS_IS_UTF8(cs) || ( (cs) == us7ascii_csid ) || ( (cs) == we8mswin1252 ) )
-
-
-#define CS_IS_UTF16( cs ) ( cs == al16utf16_csid )
-
-#define CSFORM_IMPLIED_CSID(csform) \
- ((csform==SQLCS_NCHAR) ? ncharsetid : charsetid)
-
-#define CSFORM_IMPLIES_UTF8(csform) \
- CS_IS_UTF8( CSFORM_IMPLIED_CSID( csform ) )
-
-
-void dbd_init_oci _((dbistate_t *dbistate));
-void dbd_preparse _((imp_sth_t *imp_sth, char *statement));
-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));
-
-int ora_db_reauthenticate _((SV *dbh, imp_dbh_t *imp_dbh, char *uid, char *pwd));
-
-void dbd_phs_sv_complete _((phs_t *phs, SV *sv, I32 debug));
-void dbd_phs_avsv_complete _((phs_t *phs, I32 index, I32 debug));
-
-int pp_exec_rset _((SV *sth, imp_sth_t *imp_sth, phs_t *phs, int pre_exec));
-int pp_rebind_ph_rset_in _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
-
-#define OTYPE_IS_LONG(t) ((t)==8 || (t)==24 || (t)==94 || (t)==95)
-
-int oci_error_err _((SV *h, OCIError *errhp, sword status, char *what, sb4 force_err));
-#define oci_error(h, errhp, status, what) oci_error_err(h, errhp, status, what, 0)
-char *oci_stmt_type_name _((int stmt_type));
-char *oci_typecode_name _((int typecode));
-char *sql_typecode_name _((int dbtype));
-char *oci_status_name _((sword status));
-char *oci_mode _((ub4 mode));
-char *oci_bind_options _((ub4 options));
-char *oci_define_options _((ub4 options));
-char *oci_hdtype_name _((ub4 hdtype));
-char *oci_exe_mode _((ub4 mode));
-char *oci_col_return_codes _((int rc));
-int dbd_rebind_ph_lob _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
-
-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 * ora_create_xml _((SV *dbh, char *source));
-
-void ora_free_lob_refetch _((SV *sth, imp_sth_t *imp_sth));
-void dbd_phs_avsv_complete _((phs_t *phs, I32 index, I32 debug));
-void dbd_phs_sv_complete _((phs_t *phs, SV *sv, I32 debug));
-int post_execute_lobs _((SV *sth, imp_sth_t *imp_sth, ub4 row_count));
-ub4 ora_parse_uid _((imp_dbh_t *imp_dbh, char **uidp, char **pwdp));
-char *ora_sql_error _((imp_sth_t *imp_sth, char *msg));
-char *ora_env_var(char *name, char *buf, unsigned long size);
-
-#ifdef __CYGWIN32__
-void ora_cygwin_set_env(char *name, char *value);
-#endif /* __CYGWIN32__ */
-
-sb4 dbd_phs_in _((dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index,
- dvoid **bufpp, ub4 *alenp, ub1 *piecep, dvoid **indpp));
-sb4 dbd_phs_out _((dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index,
- dvoid **bufpp, ub4 **alenpp, ub1 *piecep,
- dvoid **indpp, ub2 **rcodepp));
-sb4 presist_lob_fetch_cbk _((dvoid *octxp, OCIDefine *dfnhp, ub4 iter, dvoid **bufpp,
- ub4 **alenpp, ub1 *piecep, dvoid **indpp, ub2 **rcpp));
-int dbd_rebind_ph_rset _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
-
-void * oci_db_handle(imp_dbh_t *imp_dbh, int handle_type, int flags);
-void * oci_st_handle(imp_sth_t *imp_sth, int handle_type, int flags);
-void fb_ary_free(fb_ary_t *fb_ary);
-
-
-
-
-/* These defines avoid name clashes for multiple statically linked DBD's */
-
-#define dbd_init ora_init
-#define dbd_db_login ora_db_login
-#define dbd_db_login6 ora_db_login6
-#define dbd_db_do ora_db_do
-#define dbd_db_commit ora_db_commit
-#define dbd_db_rollback ora_db_rollback
-#define dbd_db_cancel ora_db_cancel
-#define dbd_db_disconnect ora_db_disconnect
-#define dbd_db_destroy ora_db_destroy
-#define dbd_db_STORE_attrib ora_db_STORE_attrib
-#define dbd_db_FETCH_attrib ora_db_FETCH_attrib
-#define dbd_st_prepare ora_st_prepare
-#define dbd_st_rows ora_st_rows
-#define dbd_st_cancel ora_st_cancel
-#define dbd_st_execute ora_st_execute
-#define dbd_st_fetch ora_st_fetch
-#define dbd_st_finish ora_st_finish
-#define dbd_st_destroy ora_st_destroy
-#define dbd_st_blob_read ora_st_blob_read
-#define dbd_st_STORE_attrib ora_st_STORE_attrib
-#define dbd_st_FETCH_attrib ora_st_FETCH_attrib
-#define dbd_describe ora_describe
-#define dbd_bind_ph ora_bind_ph
-#include "ocitrace.h"
-
-/* end */
-
+/*
+ Copyright (c) 1994-2006 Tim Bunce
+ Copyright (c) 2006-2008 John Scoles (The Pythian Group), Canada
+
+ See the COPYRIGHT section in the Oracle.pm file for terms.
+
+*/
+
+/* ====== define data types ====== */
+
+typedef struct imp_fbh_st imp_fbh_t;
+
+
+struct imp_drh_st {
+ dbih_drc_t com; /* MUST be first element in structure */
+ OCIEnv *envhp;
+ int proc_handles; /* If true, the envhp handle is owned by ProC
+ and must not be freed. */
+ SV *ora_long;
+ SV *ora_trunc;
+ SV *ora_cache;
+ SV *ora_cache_o; /* for ora_open() cache override */
+};
+
+
+/* Define dbh implementor data structure */
+struct imp_dbh_st {
+ dbih_dbc_t com; /* MUST be first element in structure */
+
+#ifdef USE_ITHREADS
+ int refcnt ; /* keep track of duped handles. MUST be first after com */
+ struct imp_dbh_st * shared_dbh ; /* pointer to shared space from which to dup and keep refcnt */
+ SV * shared_dbh_priv_sv ;
+#endif
+
+ void *(*get_oci_handle) _((imp_dbh_t *imp_dbh, int handle_type, int flags));
+ OCIEnv *envhp; /* copy of drh pointer */
+ OCIError *errhp;
+ OCIServer *srvhp;
+ OCISvcCtx *svchp;
+ OCISession *authp;
+ int proc_handles; /* If true, srvhp, svchp, and authp handles
+ are owned by ProC and must not be freed. */
+ int RowCacheSize;
+ int ph_type; /* default oratype for placeholders */
+ ub1 ph_csform; /* default charset for placeholders */
+ int parse_error_offset; /* position in statement of last error */
+ int max_nested_cursors; /* limit on cached nested cursors per stmt */
+ int array_chunk_size; /* the max size for an array bind */
+
+};
+
+#define DBH_DUP_OFF sizeof(dbih_dbc_t)
+#define DBH_DUP_LEN (sizeof(struct imp_dbh_st) - sizeof(dbih_dbc_t))
+
+
+typedef struct lob_refetch_st lob_refetch_t; /* Define sth implementor data structure */
+
+
+/*statement structure */
+struct imp_sth_st {
+
+ dbih_stc_t com; /* MUST be first element in structure */
+
+ void *(*get_oci_handle) _((imp_sth_t *imp_sth, int handle_type, int flags));
+ OCIEnv *envhp; /* copy of dbh pointer */
+ OCIError *errhp; /* copy of dbh pointer */
+ OCIServer *srvhp; /* copy of dbh pointer */
+ OCISvcCtx *svchp; /* copy of dbh pointer */
+ OCIStmt *stmhp; /* oci statement handle */
+ OCIDescribe *dschp; /* oci describe handle */
+ int is_child; /* if this is child from a ref cursor or SP*/
+ ub2 stmt_type; /* OCIAttrGet OCI_ATTR_STMT_TYPE */
+ U16 auto_lob; /* use auto lobs*/
+ int pers_lob; /*use dblink for lobs only for 10g Release 2. or later*/
+ int clbk_lob; /*use dblink for lobs only for 10g Release 2. or later*/
+ int piece_lob; /*use piece fetch for lobs*/
+ ub4 piece_size; /*used in callback to set the size of the piece to get*/
+ int has_lobs; /* Statement has bound LOBS*/
+
+ lob_refetch_t *lob_refetch;
+ int nested_cursor; /* cursors fetched from SELECTs */
+ AV *bind_tuples; /* Bind tuples in array execute, or NULL */
+ int rowwise; /* If true, bind_tuples is list of */
+ /* tuples, otherwise list of columns. */
+
+ /* Input Details */
+ char *statement; /* sql (see sth_scan) */
+ HV *all_params_hv; /* all params, keyed by name */
+ AV *out_params_av; /* quick access to inout params */
+ int ora_pad_empty; /* convert ""->" " when binding */
+
+ /* Select Column Output Details */
+ int done_desc; /* have we described this sth yet ? */
+ imp_fbh_t *fbh; /* array of imp_fbh_t structs */
+ char *fbh_cbuf; /* memory for all field names */
+ int t_dbsize; /* raw data width of a row */
+ UV long_readlen; /* local copy to handle oraperl */
+ HV *fbh_tdo_hv; /* hash of row #(0 based) and tdo object name from ora_oci_type_names hash */
+ /* Select Row Cache Details */
+ sb4 cache_rows;
+ int in_cache;
+ int next_entry;
+ int eod_errno;
+ int est_width; /* est'd avg row width on-the-wire */
+ /* (In/)Out Parameter Details */
+ bool has_inout_params;
+ /* execute mode*/
+ /* will be using this alot later me thinks */
+ ub4 exe_mode;
+ /* fetch scrolling values */
+ int fetch_orient;
+ int fetch_offset;
+ int fetch_position;
+ int prefetch_memory; /* OCI_PREFETCH_MEMORY*/
+ /* array fetch: state variables */
+ bool rs_array_on; /* if array to be used */
+ int rs_array_size; /* array size */
+ int rs_array_num_rows; /* num rows in last fetch */
+ int rs_array_idx; /* index of current row */
+ sword rs_array_status; /* status of last fetch */
+};
+#define IMP_STH_EXECUTING 0x0001
+
+
+typedef struct fb_ary_st fb_ary_t; /* field buffer array */
+struct fb_ary_st { /* field buffer array EXPERIMENTAL */
+ ub4 bufl; /* length of data buffer */
+ ub4 cb_bufl; /* length of piece of data fetched in callback.*/
+ ub4 piece_count;/*# of pieces retrieved*/
+ sb2 *aindp; /* null/trunc indicator variable */
+ ub1 *abuf; /* data buffer (points to sv data) */
+ ub1 *cb_abuf; /*yet another buffer for picewise callbacks this means I only need to allocate memory once a prepare rather than at each fetch*/
+ ub2 *arlen; /* length of returned data */
+ ub2 *arcode; /* field level error status */
+};
+
+
+typedef struct fbh_obj_st fbh_obj_t; /*Ebbedded Object Descriptor */
+
+struct fbh_obj_st { /* embedded object or table will work recursively*/
+ text *type_name; /*object's name (TDO)*/
+ ub4 type_namel; /*length of the name*/
+ OCIParam *parmdp; /*Describe attributes of the object OCI_DTYPE_PARAM*/
+ OCIParam *parmap; /*Describe attributes of the object OCI_ATTR_COLLECTION_ELEMENT OCI_ATTR_PARAM*/
+ OCIType *tdo; /*object's TDO handle */
+ OCITypeCode typecode; /*object's OOCI_ATTR_TYPECODE */
+ OCITypeCode col_typecode; /*if collection this is its OCI_ATTR_COLLECTION_TYPECODE */
+ OCITypeCode element_typecode; /*if collection this is its element's OCI_ATTR_TYPECODE*/
+ OCIRef *obj_ref; /*if an embeded object this is ref handle to its TDO*/
+ OCIInd *obj_ind; /*Null indictator for object */
+ OCIComplexObject *obj_value; /*the actual value from the DB*/
+ OCIType *obj_type; /*if an embeded object this is the OCIType returned by a OCIObjectPin*/
+ fbh_obj_t *fields; /*one object for each field/property*/
+ int field_count; /*The number of fields Not really needed but nice to have*/
+ AV *value; /*The value to send back to Perl This way there are no memory leaks*/
+};
+
+struct imp_fbh_st { /* field buffer EXPERIMENTAL */
+ imp_sth_t *imp_sth; /* 'parent' statement */
+ int field_num; /* 0..n-1 */
+
+ /* Oracle's description of the field */
+ OCIParam *parmdp;
+ OCIDefine *defnp;
+ void *desc_h; /* descriptor if needed (LOBs etc) */
+ ub4 desc_t; /* OCI type of descriptor */
+ ub4 define_mode; /*the normal case for a define*/
+ int (*fetch_func) _((SV *sth, imp_fbh_t *fbh, SV *dest_sv));
+ void (*fetch_cleanup) _((SV *sth, imp_fbh_t *fbh));
+ ub2 dbtype; /* actual type of field (see ftype) */
+ ub2 dbsize;
+ ub2 prec; /* XXX docs say ub1 but ub2 is needed */
+ sb1 scale;
+ ub1 nullok;
+ char *name;
+ SV *name_sv; /* only set for OCI8 */
+ /* OCI docs say OCI_ATTR_CHAR_USED is ub4, they're wrong */
+ ub1 len_char_used; /* OCI_ATTR_CHAR_USED */
+ ub2 len_char_size; /* OCI_ATTR_CHAR_SIZE */
+ ub2 csid; /* OCI_ATTR_CHARSET_ID */
+ ub1 csform; /* OCI_ATTR_CHARSET_FORM */
+
+ ub4 disize; /* max display/buffer size */
+ ub4 piece_size; /*used in callback to set the size of the piece to get*/
+
+ char *bless; /* for Oracle::OCI style handle data */
+ void *special; /* hook for special purposes (LOBs etc) */
+ int pers_lob; /*for persistant lobs 10g Release 2. or later*/
+ int clbk_lob; /*for persistant lobs 10g Release 2. or later*/
+ int piece_lob; /*use piecewise fetch for lobs*/
+ /* Our storage space for the field data as it's fetched */
+ sword ftype; /* external datatype we wish to get */
+ fb_ary_t *fb_ary ; /* field buffer array */
+ /* if this is an embedded object we use this */
+ fbh_obj_t *obj;
+
+
+ };
+
+ /* Placeholder structure */
+ /* Note: phs_t is serialized into scalar value, and de-serialized then. */
+ /* Be carefull! */
+
+typedef struct phs_st phs_t; /* scalar placeholder */
+
+struct phs_st { /* scalar placeholder EXPERIMENTAL */
+ imp_sth_t *imp_sth; /* 'parent' statement */
+ sword ftype; /* external OCI field type */
+
+ SV *sv; /* the scalar holding the value */
+ U32 sv_type; /* original sv type at time of bind */
+ ub2 csid_orig; /* original oracle default csid */
+ ub2 csid; /* 0 for automatic */
+ ub1 csform; /* 0 for automatic */
+ ub4 maxdata_size; /* set OCI_ATTR_MAXDATA_SIZE if >0 */
+ bool is_inout;
+
+ IV maxlen; /* max possible len (=allocated buffer) */
+ /* Note: for array bind = buffer for each entry */
+ OCIBind *bndhp;
+ void *desc_h; /* descriptor if needed (LOBs etc) */
+ ub4 desc_t; /* OCI type of desc_h */
+ ub4 alen;
+ ub2 arcode;
+ int idx; /* 0-based index for ?/:1 style, or -1 */
+
+ sb2 indp; /* null indicator */
+ char *progv;
+
+ int (*out_prepost_exec)_((SV *, imp_sth_t *, phs_t *, int pre_exec));
+ SV *ora_field; /* from attribute (for LOB binds) */
+ ub4 alen_incnull; /* 0 or 1 if alen should include null */
+ /* Array bind support */
+ char * array_buf; /* Temporary buffer = malloc(array_buflen) */
+ int array_buflen; /* Allocated length of array_buf */
+ int array_numstruct; /* Number of bound structures in buffer */
+ OCIInd * array_indicators; /* Indicator array = malloc( array_numallocated * sizeof(OCIInd) ) */
+ unsigned short *array_lengths; /* Array entries lengths = malloc( array_numallocated * sizeof(unsigned short) ) */
+ int array_numallocated; /* Allocated number of indicators/lengths */
+ int ora_maxarray_numentries; /* Number of entries to send allocated to Oracle. (may be less, than total allocated) */
+
+ /* Support for different internal C-types, representing Oracle data */
+ int ora_internal_type; /* Which C-type would be bound instead of SQLT_CHR. */
+
+ char name[1]; /* struct is malloc'd bigger as needed */
+};
+
+
+/* ------ define functions and external variables ------ */
+
+extern int ora_fetchtest;
+extern int dbd_verbose;
+
+extern ub2 charsetid;
+extern ub2 ncharsetid;
+extern ub2 us7ascii_csid;
+extern ub2 utf8_csid;
+extern ub2 we8mswin1252; /*default for windows */
+extern ub2 al32utf8_csid;
+extern ub2 al16utf16_csid;
+
+#define CS_IS_NOT_UTF8(cs)\
+ ( ( cs == us7ascii_csid ) )
+
+#define CS_IS_UTF8( cs ) \
+ ( ( cs == utf8_csid ) || ( cs == al32utf8_csid )|| ( cs == we8mswin1252 ) )
+
+/*#define CS_IS_UTF8_COMPATIBLE( cs ) \
+ ( CS_IS_UTF8(cs) || ( (cs) == us7ascii_csid ) || ( (cs) == we8mswin1252 ) )
+*/
+
+#define CS_IS_UTF16( cs ) ( cs == al16utf16_csid )
+
+#define CSFORM_IMPLIED_CSID(csform) \
+ ((csform==SQLCS_NCHAR) ? ncharsetid : charsetid)
+
+#define CSFORM_IMPLIES_UTF8(csform) \
+ CS_IS_UTF8( CSFORM_IMPLIED_CSID( csform ) )
+
+
+void dbd_init_oci _((dbistate_t *dbistate));
+void dbd_preparse _((imp_sth_t *imp_sth, char *statement));
+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));
+
+int ora_db_reauthenticate _((SV *dbh, imp_dbh_t *imp_dbh, char *uid, char *pwd));
+
+void dbd_phs_sv_complete _((phs_t *phs, SV *sv, I32 debug));
+void dbd_phs_avsv_complete _((phs_t *phs, I32 index, I32 debug));
+
+int pp_exec_rset _((SV *sth, imp_sth_t *imp_sth, phs_t *phs, int pre_exec));
+int pp_rebind_ph_rset_in _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
+
+#define OTYPE_IS_LONG(t) ((t)==8 || (t)==24 || (t)==94 || (t)==95)
+
+int oci_error_err _((SV *h, OCIError *errhp, sword status, char *what, sb4 force_err));
+#define oci_error(h, errhp, status, what) oci_error_err(h, errhp, status, what, 0)
+char *oci_stmt_type_name _((int stmt_type));
+char *oci_typecode_name _((int typecode));
+char *sql_typecode_name _((int dbtype));
+char *oci_status_name _((sword status));
+char *oci_mode _((ub4 mode));
+char *oci_bind_options _((ub4 options));
+char *oci_define_options _((ub4 options));
+char *oci_hdtype_name _((ub4 hdtype));
+char *oci_exe_mode _((ub4 mode));
+char *oci_col_return_codes _((int rc));
+int dbd_rebind_ph_lob _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
+
+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 * ora_create_xml _((SV *dbh, char *source));
+
+void ora_free_lob_refetch _((SV *sth, imp_sth_t *imp_sth));
+void dbd_phs_avsv_complete _((phs_t *phs, I32 index, I32 debug));
+void dbd_phs_sv_complete _((phs_t *phs, SV *sv, I32 debug));
+int post_execute_lobs _((SV *sth, imp_sth_t *imp_sth, ub4 row_count));
+ub4 ora_parse_uid _((imp_dbh_t *imp_dbh, char **uidp, char **pwdp));
+char *ora_sql_error _((imp_sth_t *imp_sth, char *msg));
+char *ora_env_var(char *name, char *buf, unsigned long size);
+
+#ifdef __CYGWIN32__
+void ora_cygwin_set_env(char *name, char *value);
+#endif /* __CYGWIN32__ */
+
+sb4 dbd_phs_in _((dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index,
+ dvoid **bufpp, ub4 *alenp, ub1 *piecep, dvoid **indpp));
+sb4 dbd_phs_out _((dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index,
+ dvoid **bufpp, ub4 **alenpp, ub1 *piecep,
+ dvoid **indpp, ub2 **rcodepp));
+sb4 presist_lob_fetch_cbk _((dvoid *octxp, OCIDefine *dfnhp, ub4 iter, dvoid **bufpp,
+ ub4 **alenpp, ub1 *piecep, dvoid **indpp, ub2 **rcpp));
+int dbd_rebind_ph_rset _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
+
+void * oci_db_handle(imp_dbh_t *imp_dbh, int handle_type, int flags);
+void * oci_st_handle(imp_sth_t *imp_sth, int handle_type, int flags);
+void fb_ary_free(fb_ary_t *fb_ary);
+
+
+
+
+/* These defines avoid name clashes for multiple statically linked DBD's */
+
+#define dbd_init ora_init
+#define dbd_db_login ora_db_login
+#define dbd_db_login6 ora_db_login6
+#define dbd_db_do ora_db_do
+#define dbd_db_commit ora_db_commit
+#define dbd_db_rollback ora_db_rollback
+#define dbd_db_cancel ora_db_cancel
+#define dbd_db_disconnect ora_db_disconnect
+#define dbd_db_destroy ora_db_destroy
+#define dbd_db_STORE_attrib ora_db_STORE_attrib
+#define dbd_db_FETCH_attrib ora_db_FETCH_attrib
+#define dbd_st_prepare ora_st_prepare
+#define dbd_st_rows ora_st_rows
+#define dbd_st_cancel ora_st_cancel
+#define dbd_st_execute ora_st_execute
+#define dbd_st_fetch ora_st_fetch
+#define dbd_st_finish ora_st_finish
+#define dbd_st_destroy ora_st_destroy
+#define dbd_st_blob_read ora_st_blob_read
+#define dbd_st_STORE_attrib ora_st_STORE_attrib
+#define dbd_st_FETCH_attrib ora_st_FETCH_attrib
+#define dbd_describe ora_describe
+#define dbd_bind_ph ora_bind_ph
+#include "ocitrace.h"
+
+/* end */
+
lmpx.com only provides a reader for public news (NNTP) servers. It is not
affiliated with the servers or forums shown here and is not responsible for
the content of articles, which is written by their respective authors.