LMPX.COM |
Home | Linux | Mysql | PHP | XML | ||
|
|
|||
From: byterock@cvs.perl.org Date: Mon Sep 29 11:34:37 2008 Subject: [svn:dbd-oracle] r11905 - dbd-oracle/branches/utf8_ea
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. alex@alemate.ru */
-/*
- *
- * 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. */
-