[svn:dbd-oracle] r15188 - dbd-oracle/branches/FAN
[email protected] Mon, 27 Feb 2012 10:37:23 -0800 (PST)
| Newsgroups | perl.dbd.oracle.changes |
|---|---|
| Message-ID | <[email protected]> |
Author: byterock
Date: Mon Feb 27 10:37:22 2012
New Revision: 15188
Modified:
dbd-oracle/branches/FAN/dbdimp.c
dbd-oracle/branches/FAN/dbdimp.h
Log:
revert as well
Modified: dbd-oracle/branches/FAN/dbdimp.c
==============================================================================
--- dbd-oracle/branches/FAN/dbdimp.c (original)
+++ dbd-oracle/branches/FAN/dbdimp.c Mon Feb 27 10:37:22 2012
@@ -1,4394 +0,0 @@
-/*
- vim: sw=4:ts=8
- dbdimp.c
-
- Copyright (c) 1994-2006 Tim Bunce Ireland
- Copyright (c) 2006-2008 John Scoles (The Pythian Group), Canada
-
- See the COPYRIGHT section in the Oracle.pm file for terms.
-
-*/
-
-#ifdef WIN32
-#define strcasecmp strcmpi
-#endif
-
-#ifdef __CYGWIN32__
-#include "w32api/windows.h"
-#include "w32api/winbase.h"
-#endif /* __CYGWIN32__ */
-
-#include "Oracle.h"
-#include "pthread.h"
-
-
-/* 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; /* not ProC but ExtProc.pm */
-int dbd_verbose = 0; /* DBD only debugging*/
-int oci_warn = 0; /* show oci warnings */
-int ora_objects = 0; /* get oracle embedded objects as instance of DBD::Oracle::Object */
-int ora_ncs_buff_mtpl = 4; /* a mulitplyer for ncs clob buffers */
-
-/* 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;
-
-
-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)
-{
-
- dTHX;
- /* The disconnect_all concept is flawed and needs more work */
- if (!PL_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;
-}
-
-#ifdef THIS_IS_NOT_CURRENTLY_USED
-static int
-oratype_rebind_ok(int dbtype) /* all are vrcar any way so just use it */
-{
- /* 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 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 */
- case 113: /* SQLT_BLOB / long */
- return SQLT_BIN;
- case 112: /* SQLT_CLOB / long */
- return SQLT_CHR;
- }
-
- return dbtype;
-}
-#endif /* THIS_IS_NOT_CURRENTLY_USED */
-/* --- 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)
-{
-
- dTHX;
- sword status;
- SV **svp;
- shared_sv * shared_dbh_ssv = NULL ;
- imp_dbh_t * shared_dbh = NULL ;
- D_imp_drh_from_dbh;
- ub2 new_charsetid = 0;
- ub2 new_ncharsetid = 0;
- int forced_new_environment = 0;
-#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
-
-#ifdef ORA_OCI_112
- /*check to see if the user is connecting with DRCP */
- if (DBD_ATTRIB_TRUE(attr,"ora_drcp",8,svp))
- imp_dbh->using_drcp = 1;
-
- /* some connection pool atributes */
-
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_drcp_class", 14)) && SvOK(*svp)) {
- STRLEN svp_len;
- if (!SvPOK(*svp))
- croak("ora_drcp_class is not a string");
- imp_dbh->pool_class = (text *) SvPV (*svp, svp_len );
- imp_dbh->pool_classl= (ub4) svp_len;
- }
- if (DBD_ATTRIB_TRUE(attr,"ora_drcp_min",12,svp))
- DBD_ATTRIB_GET_IV( attr, "ora_drcp_min", 12, svp, imp_dbh->pool_min);
- if (DBD_ATTRIB_TRUE(attr,"ora_drcp_max",12,svp))
- DBD_ATTRIB_GET_IV( attr, "ora_drcp_max", 12, svp, imp_dbh->pool_max);
- if (DBD_ATTRIB_TRUE(attr,"ora_drcp_incr",13,svp))
- DBD_ATTRIB_GET_IV( attr, "ora_drcp_incr", 13, svp, imp_dbh->pool_incr);
-
-
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_driver_name", 15)) && SvOK(*svp)) {
- STRLEN svp_len;
- if (!SvPOK(*svp))
- croak("ora_driver_name is not a string");
- imp_dbh->driver_name = (char *) SvPV (*svp, svp_len );
- imp_dbh->driver_namel= (ub4) svp_len;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->driver_name,imp_dbh->driver_namel,OCI_ATTR_DRIVER_NAME,imp_dbh->errhp, status);
- }
- else {
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION,(text*)"DBDO1.28",7,OCI_ATTR_DRIVER_NAME,imp_dbh->errhp, status);
- }
-
- /* HA Events */
-
- imp_dbh->using_ha = 0;
-
- if (DBD_ATTRIB_TRUE(attr,"ora_ha",6,svp)){
- imp_dbh->using_ha = 1;
-
-
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_ha_function", 15)) && SvOK(*svp)) {
- STRLEN svp_len;
- if (!SvPOK(*svp))
- croak("ora_ha_function is not a string");
- imp_dbh->ha_function = (char *) SvPV (*svp, svp_len );
-
- }
- }
-
-
-#endif /*ORA_OCI_112*/
-
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_action", 10)) && SvOK(*svp)) {
- STRLEN svp_len;
- if (!SvPOK(*svp))
- croak("ora_action is not a string");
- imp_dbh->action = (char *) SvPV (*svp, svp_len );
- imp_dbh->actionl= (ub4) svp_len;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->action,imp_dbh->actionl,OCI_ATTR_ACTION,imp_dbh->errhp, status);
- }
-
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_module_name", 15)) && SvOK(*svp)) {
- STRLEN svp_len;
- if (!SvPOK(*svp))
- croak("ora_module_name is not a string");
- imp_dbh->module_name = (char *) SvPV (*svp, svp_len );
- imp_dbh->module_namel= (ub4) svp_len;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->module_name,imp_dbh->module_namel,OCI_ATTR_MODULE,imp_dbh->errhp, status);
-
- }
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_client_identifier", 21)) && SvOK(*svp)) {
- STRLEN svp_len;
- if (!SvPOK(*svp))
- croak("ora_client_identifier is not a string");
- imp_dbh->client_identifier = (char *) SvPV (*svp, svp_len );
- imp_dbh->client_identifierl= (ub4) svp_len;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->client_identifier,imp_dbh->client_identifierl,OCI_ATTR_CLIENT_IDENTIFIER,imp_dbh->errhp, status);
-
- }
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_client_info", 15)) && SvOK(*svp)) {
- STRLEN svp_len;
- if (!SvPOK(*svp))
- croak("ora_client_info is not a string");
- imp_dbh->client_info = (char *) SvPV (*svp, svp_len );
- imp_dbh->client_infol= (ub4) svp_len;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->client_info,imp_dbh->client_infol,OCI_ATTR_CLIENT_INFO,imp_dbh->errhp, status);
-
- }
-
- /* TAF Events */
-
- imp_dbh->using_taf = 0;
-
- if (DBD_ATTRIB_TRUE(attr,"ora_taf",7,svp)){
- imp_dbh->using_taf = 1;
- imp_dbh->taf_sleep = 5; /* 5 second default */
-
- DBD_ATTRIB_GET_IV( attr, "ora_taf_sleep", 13, svp, imp_dbh->taf_sleep);
-
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_taf_function", 16)) && SvOK(*svp)) {
- STRLEN svp_len;
- if (!SvPOK(*svp))
- croak("ora_taf_function is not a string");
- imp_dbh->taf_function = (char *) SvPV (*svp, svp_len );
-
- }
- }
-
- imp_dbh->server_version = 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);
-
- /* check to see if success_warn is set. This will */
- /* warn after some sucessfull operations for tuning results */
- if (DBD_ATTRIB_TRUE(attr,"ora_oci_success_warn",20,svp))
- DBD_ATTRIB_GET_IV( attr, "ora_oci_success_warn", 20, svp, oci_warn);
-
- /* check to see if ora_objects set*/
- /* with this set any embedded types will go into a DBD::Oracle::Object */
- /* rather than just an ref array */
- if (DBD_ATTRIB_TRUE(attr,"ora_objects",11,svp))
- DBD_ATTRIB_GET_IV( attr, "ora_objects",11, svp, ora_objects);
-
- if (DBIS->debug >= 6 || dbd_verbose >= 6 )
- dump_env_to_trace();
-
- /* 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 >= 3 )
- 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 >= 3 )
- 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 >= 3 )
- PerlIO_printf(DBILOGFP, " dbd_db_login: use shared Oracle database handles.\n");
- } else {
- shared_dbh = NULL ;
- }
- }
-#endif
-
- imp_dbh->get_oci_handle = oci_db_handle;
-
- if ((svp=DBD_ATTRIB_GET_SVP(attr, "ora_envhp", 9)) && SvOK(*svp)) {
- if (!SvTRUE(*svp)) {
- imp_dbh->envhp = NULL; /* force new environment */
- forced_new_environment = 1;
- }
- }
- if (!imp_dbh->envhp ) {
- SV **init_mode_sv;
- ub4 init_mode = OCI_THREADED|OCI_EVENTS|OCI_OBJECT; /* needed for LOBs (8.0.4) */
-
- DBD_ATTRIB_GET_IV(attr, "ora_init_mode",13, init_mode_sv, init_mode);
-
- {
- size_t rsize = 0;
- /* Get CLIENT char and nchar charset id values */
- OCINlsEnvironmentVariableGet_log_stat( &charsetid,(size_t) 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,(size_t) 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, (dvoid *) 0,(dvoid * (*)(dvoid *,size_t)) 0, (dvoid * (*)(dvoid *, dvoid *, size_t)) 0, (void (*)(dvoid *, dvoid *)) 0, (size_t)0, (dvoid **)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;
- }
- if (!imp_drh->envhp) /* cache first envhp info drh as future default */
- imp_drh->envhp = imp_dbh->envhp;
-
- 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, OCI_EVENTS, 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;
- }
- if (!imp_drh->envhp) /* cache first envhp info drh as future default */
- imp_drh->envhp = imp_dbh->envhp;
- }
-
- /* 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");
- }
-
- }
-
- if (shared_dbh_ssv) { /*is this a cached or shared handle from DBI*/
- if (!imp_dbh->envhp) { /*no hande so create a new one*/
- 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;
- }
- }
- }
-
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->errhp, OCI_HTYPE_ERROR, status);
- 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;
- }
-
- /* 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);
-#ifdef ORA_OCI_112
- if (imp_dbh->using_drcp)
- PerlIO_printf(DBILOGFP," Useing DRCP Connection\n ");
-#endif
- }
-
- if (!shared_dbh) {
-
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->srvhp, OCI_HTYPE_SERVER, 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->errhp, OCI_HTYPE_ERROR, status);
- return 0;
- }
-
- {
- SV **sess_mode_type_sv;
- ub4 sess_mode_type = OCI_DEFAULT;
- ub4 cred_type;
- DBD_ATTRIB_GET_IV(attr, "ora_session_mode",16, sess_mode_type_sv, sess_mode_type);
-
-#ifdef ORA_OCI_112
-
- if (imp_dbh->using_drcp) { /* connect uisng a DRCP */
- ub4 purity = OCI_ATTR_PURITY_SELF;
- /* pool Default values */
- if (!imp_dbh->pool_min )
- imp_dbh->pool_min = 4;
- if (!imp_dbh->pool_max )
- imp_dbh->pool_max = 40;
- if (!imp_dbh->pool_incr)
- imp_dbh->pool_incr = 2;
-
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->poolhp, OCI_HTYPE_SPOOL, status);
-
- OCISessionPoolCreate_log_stat(imp_dbh->envhp,
- imp_dbh->errhp,
- imp_dbh->poolhp,
- (OraText **) &imp_dbh->pool_name,
- (ub4 *) &imp_dbh->pool_namel,
- (OraText *) dbname,
- strlen(dbname),
- imp_dbh->pool_min,
- imp_dbh->pool_max,
- imp_dbh->pool_incr,
- (OraText *) uid,
- strlen(uid),
- (OraText *) pwd,
- strlen(pwd),
- status);
-
- if (status != OCI_SUCCESS) {
-
- oci_error(dbh, imp_dbh->errhp, status, "OCISessionPoolCreate");
- OCIServerDetach_log_stat(imp_dbh->srvhp, imp_dbh->errhp, OCI_DEFAULT, status);
- OCIHandleFree_log_stat(imp_dbh->poolhp, OCI_HTYPE_SPOOL,status);
- OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
- OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
- return 0;
- }
-
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->authp, OCI_HTYPE_AUTHINFO, status);
-
- OCIAttrSet_log_stat(imp_dbh->authp, (ub4) OCI_HTYPE_AUTHINFO,
- &purity, (ub4) 0,(ub4) OCI_ATTR_PURITY, imp_dbh->errhp, status);
-
- if (imp_dbh->pool_class) /*pool_class may or may not be used */
- OCIAttrSet_log_stat(imp_dbh->authp, (ub4) OCI_HTYPE_AUTHINFO,
- (OraText *) imp_dbh->pool_class, (ub4) imp_dbh->pool_classl,
- (ub4) OCI_ATTR_CONNECTION_CLASS, imp_dbh->errhp, status);
-
- cred_type = ora_parse_uid(imp_dbh, &uid, &pwd);
-
- OCISessionGet_log_stat(imp_dbh->envhp, imp_dbh->errhp, &imp_dbh->svchp, imp_dbh->authp,
- imp_dbh->pool_name, (ub4)strlen((char *)imp_dbh->pool_name), status);
-
- if (status != OCI_SUCCESS) {
-
- oci_error(dbh, imp_dbh->errhp, status, "OCISessionGet");
- OCIServerDetach_log_stat(imp_dbh->srvhp, imp_dbh->errhp, OCI_DEFAULT, status);
- OCISessionPoolDestroy(imp_dbh->poolhp, imp_dbh->errhp,status);
- OCIHandleFree_log_stat(imp_dbh->poolhp, OCI_HTYPE_SPOOL,status);
- OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, status);
- OCIHandleFree_log_stat(imp_dbh->errhp, OCI_HTYPE_ERROR, status);
- return 0;
- }
-
- if (DBIS->debug >= 4 || dbd_verbose >= 4 ) {
- PerlIO_printf(DBILOGFP,"Using DRCP with session settings min=%d, max=%d, and increment=%d\n",imp_dbh->pool_min,
- imp_dbh->pool_max,
- imp_dbh->pool_incr);
- if (imp_dbh->pool_class)
- PerlIO_printf(DBILOGFP,"with connection class=%s\n",imp_dbh->pool_class);
- }
-
- }
- else {
-#endif /* ORA_OCI_112 */
-
- OCIHandleAlloc_ok(imp_dbh->envhp, &imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
- OCIServerAttach_log_stat(imp_dbh, dbname,OCI_DEFAULT, status);
-
- 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->seshp, OCI_HTYPE_SESSION, status);
-
- cred_type = ora_parse_uid(imp_dbh, &uid, &pwd);
-
- OCISessionBegin_log_stat( imp_dbh->svchp, imp_dbh->errhp, imp_dbh->seshp,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->seshp, 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);
- if (forced_new_environment)
- OCIHandleFree_log_stat(imp_dbh->envhp, OCI_HTYPE_ENV, status);
- return 0;
- }
-
- OCIAttrSet_log_stat(imp_dbh->svchp, (ub4) OCI_HTYPE_SVCCTX,
- imp_dbh->seshp, (ub4) 0,(ub4) OCI_ATTR_SESSION, imp_dbh->errhp, status);
-#ifdef ORA_OCI_112
- }
-#endif
- }
-
- }
-
- 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
-
- /* set up TAF callback if wanted */
-
-
-
- if (imp_dbh->using_taf){
- bool can_taf;
- OCIAttrGet_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, &can_taf, NULL,
- OCI_ATTR_TAF_ENABLED, imp_dbh->errhp, status);
-
- if (!can_taf){
- croak("You are attempting to enable TAF on a server that is not TAF Enabled \n");
- }
-
- if (DBIS->debug >= 4 || dbd_verbose >= 4 ) {
- PerlIO_printf(DBILOGFP,"Setting up TAF with wait time of %d seconds\n",imp_dbh->taf_sleep);
- }
- status = reg_taf_callback(imp_dbh);
- if (status != OCI_SUCCESS) {
- oci_error(dbh, NULL, status,
- "Setting TAF Callback Failed! ");
- return 0;
- }
- }
-
-#ifdef ORA_OCI_112
- /* set up HA evnets callback if requested */
-
- if (imp_dbh->using_ha){
-
- if (DBIS->debug >= 4 || dbd_verbose >= 4 ) {
- PerlIO_printf(DBILOGFP,"Setting up HA Event Callback!");
- }
-
- status = reg_ha_callback(imp_dbh);
-
- if (status != OCI_SUCCESS) {
- oci_error(dbh, NULL, status,"Setting HA Event Callback Failed! ");
- return 0;
- }
- }
-
-#endif /* ORA_OCI_112 */
- 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_st_bind_col(SV *sth, imp_sth_t *imp_sth, SV *col, SV *ref, IV type, SV *attribs) {
- dTHX;
- int field;
-
- if (!SvIOK(col)) {
- croak ("Invalid column number") ;
- }
-
- field = SvIV(col);
-
- if ((field < 1) || (field > DBIc_NUM_FIELDS(imp_sth))) {
- croak("cannot bind to non-existent field %d", field);
- }
-
- imp_sth->fbh[field-1].req_type = type;
- imp_sth->fbh[field-1].bind_flags = 0; /* default to none */
-
-#if DBIXS_REVISION >= 13590
- /* DBIXS 13590 added StrictlyTyped and DiscardString attributes */
- if (attribs) {
- HV *attr_hash;
- SV **attr;
-
- if (!SvROK(attribs)) {
- croak ("attributes is not a reference");
- }
- else if (SvTYPE(SvRV(attribs)) != SVt_PVHV) {
- croak ("attributes not a hash reference");
- }
- attr_hash = (HV *)SvRV(attribs);
-
- attr = hv_fetch(attr_hash, "StrictlyTyped", (U32)13, 0);
- if (attr && SvTRUE(*attr)) {
- imp_sth->fbh[field-1].bind_flags |= DBIstcf_STRICT;
- }
-
- attr = hv_fetch(attr_hash, "DiscardString", (U32)13, 0);
- if (attr && SvTRUE(*attr)) {
- imp_sth->fbh[field-1].bind_flags |= DBIstcf_DISCARD_STRING;
- }
- }
-#endif /* DBIXS_REVISION >= 13590 */
- return 1;
-}
-
-int
-dbd_db_disconnect(SV *dbh, imp_dbh_t *imp_dbh)
-{
- dTHX;
-
- 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 ) {
- sword s_se, s_sd;
-#ifdef ORA_OCI_112
- if (imp_dbh->using_drcp) {
- OCISessionRelease_log_stat(imp_dbh->svchp, imp_dbh->errhp,s_se);
- }
- else {
-#endif
- OCISessionEnd_log_stat(imp_dbh->svchp, imp_dbh->errhp, imp_dbh->seshp,
- OCI_DEFAULT, s_se);
-#ifdef ORA_OCI_112
- }
-#endif
- 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) {
- sword status;
-
- if (DBIc_ACTIVE(imp_dbh))
- dbd_db_disconnect(dbh, imp_dbh);
- if (is_extproc)
- goto dbd_db_destroy_out;
-
- if (imp_dbh->using_taf){
- OCIFocbkStruct tafailover;
- tafailover.fo_ctx = NULL;
- tafailover.callback_function = NULL;
- OCIAttrSet_log_stat(imp_dbh->srvhp, (ub4) OCI_HTYPE_SERVER,
- (dvoid *) &tafailover, (ub4) 0,
- (ub4) OCI_ATTR_FOCBK, imp_dbh->errhp, status);
-
- }
-#ifdef ORA_OCI_112
-
- if (imp_dbh->using_ha){
- OCIFocbkStruct ha_failover;
- ha_failover.fo_ctx = NULL;
- ha_failover.callback_function = NULL;
- OCIAttrSet_log_stat(imp_dbh->srvhp, (ub4) OCI_HTYPE_SERVER,
- (dvoid *) &ha_failover, (ub4) 0,
- (ub4) OCI_ATTR_FOCBK, imp_dbh->errhp, status);
-
- }
-
-
- if (imp_dbh->using_drcp) {
- OCIHandleFree_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,status);
- OCISessionPoolDestroy_log_stat(imp_dbh->poolhp, imp_dbh->errhp,status);
- OCIHandleFree_log_stat(imp_dbh->poolhp, OCI_HTYPE_SPOOL,status);
- }
- else {
-#endif
- OCIHandleFree_log_stat(imp_dbh->seshp, OCI_HTYPE_SESSION,status);
- OCIHandleFree_log_stat(imp_dbh->svchp, OCI_HTYPE_SVCCTX, status);
-
-#ifdef ORA_OCI_112
- }
-#endif
- OCIHandleFree_log_stat(imp_dbh->srvhp, OCI_HTYPE_SERVER, 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;
- STRLEN vl;
- sword status;
- char *key = SvPV(keysv,kl);
- int on = SvTRUE(valuesv);
- int cacheit = 1;
-
- if (kl==17 && strEQ(key, "ora_ncs_buff_mtpl") ) {
- ora_ncs_buff_mtpl = SvIV (valuesv);
- }
-#ifdef ORA_OCI_112
- else if (kl==15 && strEQ(key, "ora_driver_name") ) {
- imp_dbh->driver_name = (char *) SvPV (valuesv, vl );
- imp_dbh->driver_namel= (ub4) vl;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->driver_name,imp_dbh->driver_namel,OCI_ATTR_DRIVER_NAME,imp_dbh->errhp, status);
- }
- else if (kl==8 && strEQ(key, "ora_drcp") ) {
- imp_dbh->using_drcp = 1;
- }
- else if (kl==14 && strEQ(key, "ora_drcp_class") ) {
- STRLEN vl;
- imp_dbh->pool_class = (text *) SvPV (valuesv, vl );
- imp_dbh->pool_classl= (ub4) vl;
- }
- else if (kl==12 && strEQ(key, "ora_drcp_min") ) {
- imp_dbh->pool_min = SvIV (valuesv);
- }
- else if (kl==12 && strEQ(key, "ora_drcp_max") ) {
- imp_dbh->pool_max = SvIV (valuesv);
- }
- else if (kl==13 && strEQ(key, "ora_drcp_incr") ) {
- imp_dbh->pool_incr = SvIV (valuesv);
- }
- else if (kl==6 && strEQ(key, "ora_ha") ) {
- imp_dbh->using_ha = 1;
- }
- else if (kl==15 && strEQ(key, "ora_ha_function") ) {
- imp_dbh->ha_function = (char *) SvPV (valuesv, vl );
- }
-
-#endif
- else if (kl==7 && strEQ(key, "ora_taf") ) {
- imp_dbh->using_taf = 1;
- }
- else if (kl==16 && strEQ(key, "ora_taf_function") ) {
- imp_dbh->taf_function = (char *) SvPV (valuesv, vl );
- }
- else if (kl==13 && strEQ(key, "ora_taf_sleep") ) {
- imp_dbh->taf_sleep = SvIV (valuesv);
- }
- else if (kl==10 && strEQ(key, "ora_action") ) {
- imp_dbh->action = (char *) SvPV (valuesv, vl );
- imp_dbh->actionl= (ub4) vl;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->action,imp_dbh->actionl,OCI_ATTR_ACTION,imp_dbh->errhp, status);
-
- }
- else if (kl==10 && strEQ(key, "ora_action") ) {
- imp_dbh->action = (char *) SvPV (valuesv, vl );
- imp_dbh->actionl= (ub4) vl;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->action,imp_dbh->actionl,OCI_ATTR_ACTION,imp_dbh->errhp, status);
-
- }
- else if (kl==21 && strEQ(key, "ora_client_identifier") ) {
- imp_dbh->client_identifier = (char *) SvPV (valuesv, vl );
- imp_dbh->client_identifierl= (ub4) vl;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->client_identifier,imp_dbh->client_identifierl,OCI_ATTR_CLIENT_IDENTIFIER,imp_dbh->errhp, status);
-
- }
- else if (kl==15 && strEQ(key, "ora_client_info") ) {
- imp_dbh->client_info = (char *) SvPV (valuesv, vl );
- imp_dbh->client_infol= (ub4) vl;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->client_info,imp_dbh->client_infol,OCI_ATTR_CLIENT_INFO,imp_dbh->errhp, status);
- }
- else if (kl==15 && strEQ(key, "ora_module_name") ) {
- imp_dbh->module_name = (char *) SvPV (valuesv, vl );
- imp_dbh->module_namel= (ub4) vl;
- OCIAttrSet_log_stat(imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->module_name,imp_dbh->module_namel,OCI_ATTR_MODULE,imp_dbh->errhp, status);
-
- }
- else if (kl==20 && strEQ(key, "ora_oci_success_warn") ) {
- oci_warn = SvIV (valuesv);
- }
- else if (kl==11 && strEQ(key, "ora_objects")) {
- ora_objects = SvIV (valuesv);
- }
- else 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? */
- (void)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==18 && strEQ(key, "ora_ncs_buff_mtpl") ) {
- retsv = newSViv (ora_ncs_buff_mtpl);
- }
-#ifdef ORA_OCI_112
- else if (kl==15 && strEQ(key, "ora_driver_name") ) {
- retsv = newSVpv((char *)imp_dbh->driver_name,0);
- }
- else if (kl==8 && strEQ(key, "ora_drcp") ) {
- retsv = newSViv(imp_dbh->using_drcp);
- }
- else if (kl==14 && strEQ(key, "ora_drcp_class") ) {
- retsv = newSVpv((char *)imp_dbh->pool_class, 0);
- }
- else if (kl==12 && strEQ(key, "ora_drcp_min") ) {
- retsv = newSViv(imp_dbh->pool_min);
- }
- else if (kl==12 && strEQ(key, "ora_drcp_max") ) {
- retsv = newSViv(imp_dbh->pool_max);
- }
- else if (kl==13 && strEQ(key, "ora_drcp_incr") ) {
- retsv = newSViv(imp_dbh->pool_incr);
- }
- else if (kl==6 && strEQ(key, "ora_ha") ) {
- retsv = newSViv(imp_dbh->using_ha);
- }
- else if (kl==15 && strEQ(key, "ora_ha_function") ) {
- retsv = newSVpv((char *)imp_dbh->ha_function,0);
- }
-#endif
- else if (kl==7 && strEQ(key, "ora_taf") ) {
- retsv = newSViv(imp_dbh->using_taf);
- }
- else if (kl==16 && strEQ(key, "ora_taf_function") ) {
- retsv = newSVpv((char *)imp_dbh->taf_function,0);
- }
- else if (kl==13 && strEQ(key, "ora_taf_sleep") ) {
- retsv = newSViv(imp_dbh->taf_sleep);
- }
- else if (kl==10 && strEQ(key, "ora_action")) {
- retsv = newSVpv((char *)imp_dbh->action,0);
- }
- else if (kl==21 && strEQ(key, "ora_client_identifier")) {
- retsv = newSVpv((char *)imp_dbh->client_identifier,0);
- }
- else if (kl==15 && strEQ(key, "ora_client_info")) {
- retsv = newSVpv((char *)imp_dbh->client_info,0);
- }
- else if (kl==15 && strEQ(key, "ora_module_name")) {
- retsv = newSVpv((char *)imp_dbh->module_name,0);
- }
- else if (kl==20 && strEQ(key, "ora_oci_success_warn")) {
- retsv = newSViv (oci_warn);
- }
- else if (kl==11 && strEQ(key, "ora_objects")) {
- retsv = newSViv (ora_objects);
- }
- else 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==11 && strEQ(key, "RowsInCache")) {
- retsv = newSViv(imp_dbh->RowsInCache);
- }
- 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 == &PL_sv_yes || retsv == &PL_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;
-
- OCIXMLType *xml = NULL;
- STRLEN len;
- ub4 buflen;
- 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 %lu long\n",(unsigned long)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);
- buflen = len;
- OCILobWriteAppend_log_stat(imp_dbh->svchp, imp_dbh->errhp, src_ptr,
- &buflen, 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;
-char 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 = &PL_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);
- (void)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 >= 3 )
- PerlIO_printf(DBILOGFP, " dbd_preparse scanned %d distinct placeholders\n",
- (int)DBIc_NUM_PARAMS(imp_sth));
- }
-}
-
-
-static int
-ora_sql_type(imp_sth_t *imp_sth, char *name, int sql_type)
-{
- /* XXX should detect DBI reserved standard type range here */
-
- switch (sql_type) {
- case SQL_NUMERIC:
- case SQL_DECIMAL:
- case SQL_INTEGER:
- case SQL_BIGINT:
- case SQL_TINYINT:
- case SQL_SMALLINT:
- case SQL_FLOAT:
- case SQL_REAL:
- case SQL_DOUBLE:
- case SQL_VARCHAR:
- return 1; /* Oracle VARCHAR2 */
-
- case SQL_CHAR:
- return 96; /* Oracle CHAR */
-
- case SQL_BINARY:
- case SQL_VARBINARY:
- return 23; /* Oracle RAW */
-
- case SQL_LONGVARBINARY:
- return 24; /* Oracle LONG RAW */
-
- case SQL_LONGVARCHAR:
- return 8; /* Oracle LONG */
-
- case SQL_UDT:
- return 108; /* Oracle NTY */
-
- case SQL_CLOB:
- return 112; /* Oracle CLOB */
-
- case SQL_BLOB:
- return 113; /* Oracle BLOB */
-
- case SQL_DATE:
- case SQL_TIME:
- case SQL_TIMESTAMP:
- default:
- if (imp_sth && DBIc_WARN(imp_sth) && name)
- warn("SQL type %d for '%s' is not fully supported, bound as SQL_VARCHAR instead",
- sql_type, name);
- return ora_sql_type(imp_sth, name, SQL_VARCHAR);
- }
-}
-
-
-
-/* ############### Array bind ######################################### */
-/* Added by Alexander V Alekseev. [email protected] */
-/*
- *
- * Realloc temporary array buffer to match required number of entries
- * and buffer size.
- *
- * Return value: croaks on error. false (=0 ) on success.
- * */
-int ora_realloc_phs_array(phs_t *phs,int newentries, int newbufsize){
-
- dTHX;
-
- 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;
- int numarrayentries;
- 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 >= 3 ){
- 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.
- */
- /* av_len() returns last array index, or -1 is array is empty */
- numarrayentries=av_len( arr );
-
- if( numarrayentries >= 0 ){
- phs->array_numstruct = numarrayentries+1;
- if (trace_level >= 2 || dbd_verbose >= 3 ){
- 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 >= 3 ){
- 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 >= 3 )
- 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 >= 3 ){
- PerlIO_printf(DBILOGFP, "dbd_rebind_ph_varchar2_table(): phs->maxlen calculated =%ld\n",
- (long)maxlen);
- }
- } else{
- if (trace_level >= 2 || dbd_verbose >= 3 ){
- 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 >= 3 ){
- 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=%lu array[%d]='%s'.\n",
- (unsigned long)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=%lu array[%d]=NULL (length==0 or ! str) .\n",
- (unsigned long)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 */
- (unsigned)sizeof (OCIInd), /* Skip parameter for the next indicator value */
- (unsigned)sizeof(unsigned short), /* Skip parameter for the next actual length value */
- 0, /* Skip parameter for the next column-level error code */
- status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindArrayOfStruct");
- return 0;
- }
- /* 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 (%s)->%d (%s), 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,oci_csform_name(phs->csform), csform,oci_csform_name(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_varchar_table_posy_exe(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_varchar_table_posy_exe(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
- neatsvpv(phs->sv,0), phs->name);
- }
- if (trace_level >= 1 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_varchar_table_posy_exe(): 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_varchar_table_posy_exe(): 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_varchar_table_posy_exe(): 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 >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_varchar_table_posy_exe(): 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_varchar_table_posy_exe(): 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_varchar_table_posy_exe(): 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 >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_varchar_table_posy_exe(): 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 numarrayentries;
- /*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 >= 3 ){
- 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.*/
- /* av_len() returns last array index, or -1 is array is empty */
- numarrayentries=av_len( arr );
-
- if( numarrayentries >= 0 ){
- phs->array_numstruct = numarrayentries+1;
- if (trace_level >= 2 || dbd_verbose >= 3 ){
- 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 >= 3 ){
- 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 >= 3 ){
- 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 >= 3 ){
- 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 >= 3 ){
- 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 >= 3 ){
- 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 */
- (unsigned)sizeof(OCIInd), /* Skip parameter for the next indicator value */
- (unsigned)sizeof(unsigned short), /* Skip parameter for the next actual length value */
- 0, /* Skip parameter for the next column-level error code */
- status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIBindArrayOfStruct");
- return 0;
- }
- 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_number_table_post_exe(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_number_table_post_exe(): bad bind variable. ARRAY reference required, but got %s for '%s'.",
- neatsvpv(phs->sv,0), phs->name);
- }
- if (trace_level >= 1 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_number_table_post_exe(): 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_number_table_post_exe(): 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_number_table_post_exe(): 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 >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_number_table_post_exe(): 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_number_table_post_exe(): (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_number_table_post_exe(): (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_number_table_post_exe(): 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_number_table_post_exe(): (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_number_table_post_exe(): (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_number_table_post_exe(): arr[%d] = '%s'\n",
- i, str ? str : "<unprintable>"
- );
- }
- }
- }
- }
- }
- if (trace_level >= 2 || dbd_verbose >= 3 ){
- PerlIO_printf(DBILOGFP,
- "dbd_phs_number_table_post_exe(): 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, &PL_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 >= 3 ) {
- 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/%ld, ",(long)SvCUR(phs->sv),(long)SvLEN(phs->sv),(long)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;
-
- 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,
- NULL, /* 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 */
- dTHX;
- 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;
- 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;
-
-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(%s), 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,oci_csform_name(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 >= 3)
- 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(%s)->%d(%s), 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, oci_csform_name(phs->csform), csform, oci_csform_name(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 >= 3 ) {
- PerlIO_printf(DBILOGFP, "dbd_bind_ph(1): 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 == &PL_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 (%"IVdf") 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 %"IVdf"", 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 = ORA_RSET;
-
- /* 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 %"IVdf" 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 */
-
- /* Reload array-size-related attributes */
- if (attribs) {
- SV **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);
- }
- }
- }
- 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 == &PL_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, &PL_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 =3;
- note = " [placeholder has no data buffer]";
- }
-
- if (debug >= 2 || dbd_verbose >= 3 )
- 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 =3;
- note = " [placeholder has no data buffer]";
- }
- if (debug >= 2 || dbd_verbose >= 3 )
- 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 >= 3 )
- 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 >= 3 )
- 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) */
-{
-
- 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 >= 3 )
- 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 >= 3 )
- 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 >= 3 )
- 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 >= 3 )
- 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;
- /*reinit the rs_array as well
- as we may have more thatn one exe on a prepare*/
- rs_array_init(imp_sth);
- }
- else {
- OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
- }
-
- if (debug >= 2 || dbd_verbose >= 3 ) {
- 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 >= 3 ) {
- PerlIO_printf(DBILOGFP,
- "dbd_st_execute(): Analyzing inout a parameter '%s of type=%d name=%s'\n",
- phs->name,phs->ftype,sql_typecode_name(phs->ftype));
- }
- if( phs->ftype == ORA_VARCHAR2_TABLE ){
- dbd_phs_varchar_table_posy_exe(phs);
- continue;
- }
- if( phs->ftype == ORA_NUMBER_TABLE ){
- dbd_phs_number_table_post_exe(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,parma_index,tuples_utf8_av,tuples_status_av)
- SV *sth;
- imp_sth_t *imp_sth;
- phs_t *phs;
- int utf8;
- AV *tuples_utf8_av,*tuples_status_av;
- int parma_index;
- {
- dTHX;
- sword status;
- ub1 csform;
- ub2 csid;
- int trace_level = DBIS->debug;
- int i;
- 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 >= 3 )
- 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_NOT_UTF8_COMPATIBLE(csid)) {
- oratext charsetname[OCI_NLS_MAXBUFSZ];
- OCINlsCharSetIdToName(imp_sth->envhp,charsetname, sizeof(charsetname),csid );
-
- for(i=0;i<av_len(tuples_utf8_av)+1;i++){
- SV *err_svs[3];
- SV *item;
- item=*(av_fetch(tuples_utf8_av,i,0));
- err_svs[0] = newSViv((IV)0);
- err_svs[1] = newSVpvf("DBD Oracle Warning: You have mixed utf8 and non-utf8 in an array bind in parameter#%d. This may result in corrupt data. The Query charset id=%d, name=%s",parma_index+1,csid,charsetname);
- err_svs[2] = newSVpvn("S1000", 0);
- av_store(tuples_status_av,SvIV(item),newRV_noinc((SV *)(av_make(3, err_svs))));
- }
-
-
-
- }
- 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 (%s)->%d (%s), 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,oci_csform_name(phs->csform), csform,oci_csform_name(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 == &PL_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 = ORA_RSET;
- /* some types require the trailing null included in the length. */
- /* SQLT_STR=5=STRING, SQLT_AVC=97=VARCHAR */
- phs->alen_incnull = (phs->ftype==SQLT_STR || phs->ftype==SQLT_AVC);
- }
-}
-
-int
-ora_st_execute_array(sth, imp_sth, tuples, tuples_status, columns, exe_count, err_count)
- SV *sth;
- imp_sth_t *imp_sth;
- SV *tuples;
- SV *tuples_status;
- SV *columns;
- ub4 exe_count;
- SV *err_count;
-{
- dTHX;
-
- ub4 row_count = 0;
- int debug = DBIS->debug;
- D_imp_dbh_from_sth;
- sword status, exe_status;
- int is_select = (imp_sth->stmt_type == OCI_STMT_SELECT);
- AV *tuples_av, *tuples_status_av, *columns_av,*tuples_utf8_av;
- ub4 oci_mode;
- ub4 num_errs;
- int i,j;
- int autocommit = DBIc_has(imp_dbh,DBIcf_AutoCommit);
- SV **sv_p;
- phs_t **phs;
- SV *sv;
- AV *av;
- int param_count;
- char namebuf[30];
- STRLEN len;
- int outparams = (imp_sth->out_params_av) ? AvFILL(imp_sth->out_params_av)+1 : 0;
- int *utf8_flgs;
- tuples_utf8_av=newAV();
-
- if (debug >= 2 || dbd_verbose >= 3 )
- PerlIO_printf(DBILOGFP, " ora_st_execute_array %s count=%d (%s %s %s)...\n",
- oci_stmt_type_name(imp_sth->stmt_type), exe_count,
- neatsvpv(tuples,0), neatsvpv(tuples_status,0),
- neatsvpv(columns, 0));
-
- if (is_select) {
- croak("ora_st_execute_array(): SELECT statement not supported "
- "for array operation.");
- }
-
- if (imp_sth->has_lobs) {
- croak("ora_st_execute_array(): LOBs not "
- "supported for array operation.");
- }
-
- /* Check that the `tuples' parameter is an array ref, find the length,
- and store it in the statement handle for the OCI callback. */
- if(!SvROK(tuples) || SvTYPE(SvRV(tuples)) != SVt_PVAV) {
- croak("ora_st_execute_array(): Not an array reference.");
- }
- tuples_av = (AV*)SvRV(tuples);
-
- /* Check the `columns' parameter. */
- if(SvTRUE(columns)) {
- if(!SvROK(columns) || SvTYPE(SvRV(columns)) != SVt_PVAV) {
- croak("ora_st_execute_array(): columns not an array peference.");
- }
- columns_av = (AV*)SvRV(columns);
- } else {
- columns_av = NULL;
- }
- /* Check the `tuples_status' parameter. */
- if(SvTRUE(tuples_status)) {
- if(!SvROK(tuples_status) || SvTYPE(SvRV(tuples_status)) != SVt_PVAV) {
- croak("ora_st_execute_array(): tuples_status not an array reference.");
- }
- tuples_status_av = (AV*)SvRV(tuples_status);
- av_fill(tuples_status_av, exe_count - 1);
-
- } else {
- tuples_status_av = NULL;
- }
-
- /* Nothing to do if no tuples. */
- if(exe_count <= 0)
- return 0;
-
- /* Ensure proper OCIBindByName() calls for all placeholders.
- if(!ora_st_bind_for_array_exec(sth, imp_sth, tuples_av, exe_count,
- DBIc_NUM_PARAMS(imp_sth), columns_av))
- return -2;
-
- fix for Perl undefined warning. Moved out of function back out to main code
- Still ensures proper OCIBindByName*/
-
- param_count=DBIc_NUM_PARAMS(imp_sth);
- phs = safemalloc(param_count*sizeof(*phs));
- utf8_flgs = safemalloc(param_count*sizeof(int));
- memset(phs, 0, param_count*sizeof(*phs));
- memset(utf8_flgs, 0, param_count*sizeof(int));
-
- for(j = 0; (unsigned int) j < exe_count; j++) {
- /* Fill in 'unknown' exe count in every element (know not how to get
- individual execute row counts from OCI).
- Moved it here as there is no need to iterate twice over it
- this should speed it up somewhat for large binds*/
-
- if (SvTRUE(tuples_status)){
- av_store(tuples_status_av, j, newSViv((IV)-1));
- }
- sv_p = av_fetch(tuples_av, j, 0);
- if(sv_p == NULL) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Cannot fetch tuple %d", j);
- }
- sv = *sv_p;
- if(!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Not an array ref in element %d", j);
- }
- av = (AV*)SvRV(sv);
- for(i = 0; i < param_count; i++) {
- if(!phs[i]) {
- SV **phs_svp;
- sprintf(namebuf, ":p%d", i+1);
- phs_svp = hv_fetch(imp_sth->all_params_hv,
- namebuf, strlen(namebuf), 0);
- if (phs_svp == NULL) {
- Safefree(utf8_flgs);
- Safefree(phs);
- croak("Can't execute for non-existent placeholder :%d", i);
- }
- phs[i] = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */
- if(phs[i]->idx < 0) {
- Safefree(phs);
- croak("Placeholder %d not of ?/:1 type", i);
- }
- init_bind_for_array_exec(phs[i]);
- }
- sv_p = av_fetch(av, phs[i]->idx, 0);
- if(sv_p == NULL) {
- Safefree(utf8_flgs);
- Safefree(phs);
- croak("Cannot fetch value for param %d in entry %d", i, j);
- }
-
- sv = *sv_p;
-
- /*check to see if value sv is a null (undef) if it is upgrade it*/
- if (!SvOK(sv)) {
- if(SvUPGRADE(sv, SVt_PV)){} /* For GCC not to warn on unused result */
- }
- else {
- SvPV(sv, len);
- }
-
-
- /* Find the value length, and increase maxlen if needed. */
- if(SvROK(sv)) {
- Safefree(phs);
- Safefree(utf8_flgs);
- croak("Can't bind a reference (%s) for param %d, entry %d",
- neatsvpv(sv,0), i, j);
- }
- if(len > (unsigned int) phs[i]->maxlen)
- phs[i]->maxlen = len;
-
- /* update the utf8_flgs for this value */
- if (SvUTF8(sv)) {
- utf8_flgs[i] |= ARRAY_BIND_UTF8;
- if (SvTRUE(tuples_status)){
- av_push(tuples_utf8_av,newSViv(j));
- }
-
-
- }
- else {
- utf8_flgs[i] |= ARRAY_BIND_NATIVE;
-
- }
- /* Do OCI bind calls on last iteration. */
- if( ((unsigned int) j ) == exe_count - 1 ) {
- do_bind_array_exec(sth, imp_sth, phs[i], utf8_flgs[i],i,tuples_utf8_av,tuples_status_av);
- }
- }
- }
- Safefree(phs);
- Safefree(utf8_flgs);
- /* Store array of bind typles, for use in OCIBindDynamic() callback. */
- imp_sth->bind_tuples = tuples_av;
- imp_sth->rowwise = (columns_av == NULL);
-
- oci_mode = OCI_BATCH_ERRORS;
- if(autocommit)
- oci_mode |= OCI_COMMIT_ON_SUCCESS;
-
- OCIStmtExecute_log_stat(imp_sth->svchp, imp_sth->stmhp, imp_sth->errhp,
- exe_count, 0, 0, 0, oci_mode, exe_status);
-
- OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
-
-
- imp_sth->bind_tuples = NULL;
-
- if (exe_status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, exe_status, ora_sql_error(imp_sth,"OCIStmtExecute"));
- if(exe_status != OCI_SUCCESS_WITH_INFO)
- return -2;
- }
- if (outparams){
- i=outparams;
- while(--i >= 0) {
- phs_t *phs = (phs_t*)(void*)SvPVX(AvARRAY(imp_sth->out_params_av)[i]);
- SV *sv = phs->sv;
- if (SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVAV) {
- AV *av = (AV*)SvRV(sv);
- I32 avlen = AvFILL(av);
- for (j=0;j<=avlen;j++){
- dbd_phs_avsv_complete(phs, j, debug);
- }
- }
- }
- }
-
- OCIAttrGet_stmhp_stat(imp_sth, &num_errs, 0, OCI_ATTR_NUM_DML_ERRORS, status);
-
- if (debug >= 6 || dbd_verbose >= 6 )
- PerlIO_printf(DBILOGFP, " ora_st_execute_array %d errors in batch.\n",
- num_errs);
-
- if(num_errs && tuples_status_av) {
- OCIError *row_errhp, *tmp_errhp;
- ub4 row_off;
- SV *err_svs[3];
- /*AV *err_av;*/
- sb4 err_code;
- sv_setiv(err_count,num_errs);
- err_svs[0] = newSViv((IV)0);
- err_svs[1] = newSVpvn("", 0);
- err_svs[2] = newSVpvn("S1000",5);
- OCIHandleAlloc_ok(imp_sth->envhp, &row_errhp, OCI_HTYPE_ERROR, status);
- OCIHandleAlloc_ok(imp_sth->envhp, &tmp_errhp, OCI_HTYPE_ERROR, status);
- for(i = 0; (unsigned int) i < num_errs; i++) {
- OCIParamGet_log_stat(imp_sth->errhp, OCI_HTYPE_ERROR,
- tmp_errhp, (dvoid *)&row_errhp,
- (ub4)i, status);
- OCIAttrGet_log_stat(row_errhp, OCI_HTYPE_ERROR, &row_off, 0,
- OCI_ATTR_DML_ROW_OFFSET, imp_sth->errhp, status);
- if (debug >= 6 || dbd_verbose >= 6 )
- PerlIO_printf(DBILOGFP, " ora_st_execute_array error in row %d.\n",
- row_off);
- sv_setpv(err_svs[1], "");
- err_code = oci_error_get(row_errhp, exe_status, NULL, err_svs[1], debug);
- sv_setiv(err_svs[0], (IV)err_code);
- av_store(tuples_status_av, row_off,
- newRV_noinc((SV *)(av_make(3, err_svs))));
- }
- OCIHandleFree_log_stat(tmp_errhp, OCI_HTYPE_ERROR, status);
- OCIHandleFree_log_stat(row_errhp, OCI_HTYPE_ERROR, status);
-
- /* Do a commit here if autocommit is set, since Oracle
- doesn't do that for us when some rows are in error. */
- if(autocommit) {
- OCITransCommit_log_stat(imp_sth->svchp, imp_sth->errhp,
- OCI_DEFAULT, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCITransCommit");
- return -2;
- }
- }
- }
-
- if(num_errs) {
- return -2;
- } else {
-
- return row_count;
- }
-}
-
-
-
-
-int
-dbd_st_blob_read(SV *sth, imp_sth_t *imp_sth, int field, long offset, long len, SV *destrv, long destoffset)
-{
- dTHX;
- ub4 retl = 0;
- SV *bufsv;
- imp_fbh_t *fbh = &imp_sth->fbh[field];
- int ftype = fbh->ftype;
-
- bufsv = SvRV(destrv);
- sv_setpvn(bufsv,"",0); /* ensure it's writable string */
-
-#ifdef UTF8_SUPPORT
- if (ftype == 112 && CS_IS_UTF8(ncharsetid) ) {
- return ora_blob_read_mb_piece(sth, imp_sth, fbh, bufsv,
- offset, len, destoffset);
- }
-#endif /* UTF8_SUPPORT */
-
- SvGROW(bufsv, (STRLEN)destoffset+len+1); /* SvGROW doesn't do +1 */
-
- retl = ora_blob_read_piece(sth, imp_sth, fbh, bufsv,
- offset, len, destoffset);
- if (!SvOK(bufsv)) { /* ora_blob_read_piece recorded error */
- ora_free_templob(sth, imp_sth, (OCILobLocator*)fbh->desc_h);
- return 0;
- }
- ftype = ftype; /* no unused */
-
- if (DBIS->debug >= 3 || dbd_verbose >= 3 )
- PerlIO_printf(DBILOGFP,
- " blob_read field %d+1, ftype %d, offset %ld, len %ld, destoffset %ld, retlen %ld\n",
- field, imp_sth->fbh[field].ftype, offset, len, destoffset, (long)retl);
-
- SvCUR_set(bufsv, destoffset+retl);
-
- *SvEND(bufsv) = '\0'; /* consistent with perl sv_setpvn etc */
-
- return 1;
-}
-
-
-int
-dbd_st_rows(SV *sth, imp_sth_t *imp_sth)
-{
- dTHX;
- ub4 row_count = 0;
- sword status;
- OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCIAttrGet OCI_ATTR_ROW_COUNT");
- return -1;
- }
- return row_count;
-}
-
-
-int
-dbd_st_finish(SV *sth, imp_sth_t *imp_sth)
-{
-
- dTHX;
- D_imp_dbh_from_sth;
- sword status;
- int num_fields = DBIc_NUM_FIELDS(imp_sth);
- int i;
-
-
- if (DBIc_DBISTATE(imp_sth)->debug >= 6 || dbd_verbose >= 6 )
- PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_st_finish\n");
-
- if (!DBIc_ACTIVE(imp_sth))
- return 1;
-
- /* Cancel further fetches from this cursor. */
- /* We don't close the cursor till DESTROY (dbd_st_destroy). */
- /* The application may re execute(...) it. */
-
- /* Turn off ACTIVE here regardless of errors below. */
- DBIc_ACTIVE_off(imp_sth);
-
- for(i=0; i < num_fields; ++i) {
- imp_fbh_t *fbh = &imp_sth->fbh[i];
- if (fbh->fetch_cleanup) fbh->fetch_cleanup(sth, fbh);
- }
-
- if (PL_dirty) /* don't walk on the wild side */
- return 1;
-
- if (!DBIc_ACTIVE(imp_dbh)) /* no longer connected */
- return 1;
-
- /*fetching on a cursor with row =0 will explicitly free any
- server side resources this is what the next statment does,
- not sure if we need this for non scrolling cursors they should die on
- a OER(1403) no records)*/
-
- OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0,
- OCI_FETCH_NEXT,0, status);
-
- if (status != OCI_SUCCESS && status != OCI_SUCCESS_WITH_INFO) {
- oci_error(sth, imp_sth->errhp, status, "Finish OCIStmtFetch");
- return 0;
- }
- return 1;
-}
-
-
-void
-ora_free_fbh_contents(imp_fbh_t *fbh)
-{
- dTHX;
- if (fbh->fb_ary)
- fb_ary_free(fbh->fb_ary);
- sv_free(fbh->name_sv);
- if (fbh->desc_h)
- OCIDescriptorFree_log(fbh->desc_h, fbh->desc_t);
- if (fbh->obj)
- Safefree(fbh->obj);
-
-}
-
-void
-ora_free_phs_contents(phs_t *phs)
-{
- dTHX;
- if (phs->desc_h)
- OCIDescriptorFree_log(phs->desc_h, phs->desc_t);
- if( phs->array_buf ){
- free(phs->array_buf);
- phs->array_buf=NULL;
- }
- if( phs->array_indicators ){
- free(phs->array_indicators);
- phs->array_indicators=NULL;
- }
- if( phs->array_lengths ){
- free(phs->array_lengths);
- phs->array_lengths=NULL;
- }
-
- phs->array_buflen=0;
- phs->array_numallocated=0;
- sv_free(phs->ora_field);
- sv_free(phs->sv);
-}
-
-void
-ora_free_templob(SV *sth, imp_sth_t *imp_sth, OCILobLocator *lobloc)
-{
- dTHX;
-#if defined(OCI_HTYPE_DIRPATH_FN_CTX) /* >= 9.0 */
- boolean is_temporary = 0;
- sword status;
- OCILobIsTemporary_log_stat(imp_sth->envhp, imp_sth->errhp, lobloc, &is_temporary, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCILobIsTemporary");
- return;
- }
-
- if (is_temporary) {
- if (DBIS->debug >= 3 || dbd_verbose >= 3 ) {
- PerlIO_printf(DBILOGFP, " OCILobFreeTemporary %s\n", oci_status_name(status));
- }
- OCILobFreeTemporary_log_stat(imp_sth->svchp, imp_sth->errhp, lobloc, status);
- if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCILobFreeTemporary");
- return;
- }
- }
-#endif
-}
-
-
-void
-dbd_st_destroy(SV *sth, imp_sth_t *imp_sth)
-{
- int fields;
- int i;
- sword status;
- dTHX ;
-
- /* Don't free the OCI statement handle for a nested cursor. It will
- be reused by Oracle on the next fetch. Indeed, we never
- free these handles. Experiment shows that Oracle frees them
- when they are no longer needed.
- */
- /* get rid of describe handle if used*/
-
- /* if we are using a scrolling cursor we should get rid of the
- cursor by fetching row 0 */
-
- if (imp_sth->exe_mode==OCI_STMT_SCROLLABLE_READONLY){
- OCIStmtFetch_log_stat(imp_sth->stmhp, imp_sth->errhp, 0,OCI_FETCH_NEXT,0, status);
- }
-
- if (imp_sth->dschp){
- OCIHandleFree_log_stat(imp_sth->dschp, OCI_HTYPE_DESCRIBE, status);
- }
-
-
- if (DBIc_DBISTATE(imp_sth)->debug >= 6 || dbd_verbose >= 6 )
- PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_st_destroy %s\n",
- (PL_dirty) ? "(OCIHandleFree skipped during global destruction)" :
- (imp_sth->nested_cursor) ?"(OCIHandleFree skipped for nested cursor)" : "");
-
- if (!PL_dirty) { /* XXX not ideal, leak may be a problem in some cases */
- if (!imp_sth->nested_cursor) {
- OCIHandleFree_log_stat(imp_sth->stmhp, OCI_HTYPE_STMT, status);
- if (status != OCI_SUCCESS)
- oci_error(sth, imp_sth->errhp, status, "OCIHandleFree");
- }
- }
-
- /* Free off contents of imp_sth */
-
- if (imp_sth->lob_refetch)
- ora_free_lob_refetch(sth, imp_sth);
-
- fields = DBIc_NUM_FIELDS(imp_sth);
- imp_sth->in_cache = 0;
- imp_sth->eod_errno = 1403;
- for(i=0; i < fields; ++i) {
- imp_fbh_t *fbh = &imp_sth->fbh[i];
- ora_free_fbh_contents(fbh);
- }
- Safefree(imp_sth->fbh);
- if (imp_sth->fbh_cbuf)
- Safefree(imp_sth->fbh_cbuf);
- Safefree(imp_sth->statement);
-
- if (imp_sth->out_params_av)
- sv_free((SV*)imp_sth->out_params_av);
-
- if (imp_sth->all_params_hv) {
- HV *hv = imp_sth->all_params_hv;
- SV *sv;
- char *key;
- I32 retlen;
- hv_iterinit(hv);
- while( (sv = hv_iternextsv(hv, &key, &retlen)) != NULL ) {
- if (sv != &PL_sv_undef) {
- phs_t *phs = (phs_t*)(void*)SvPVX(sv);
- if (phs->desc_h && phs->desc_t == OCI_DTYPE_LOB)
- ora_free_templob(sth, imp_sth, (OCILobLocator*)phs->desc_h);
- ora_free_phs_contents(phs);
- }
- }
- sv_free((SV*)imp_sth->all_params_hv);
- }
-
- DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
-
-}
-
-
-int
-dbd_st_STORE_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv)
-{
- dTHX;
- STRLEN kl;
- SV *cachesv = NULL;
- char *key = SvPV(keysv,kl);
- if( imp_sth ) { /* For GCC not to warn on unused argument */}
-/* int on = SvTRUE(valuesv);
- int oraperl = DBIc_COMPAT(imp_sth); */
- if (strEQ(key, "ora_fetchtest")) {
- ora_fetchtest = SvIV(valuesv);
- }
- else
- return FALSE;
-
- if (cachesv) /* cache value for later DBI 'quick' fetch? */
- (void)hv_store((HV*)SvRV(sth), key, kl, cachesv, 0);
- return TRUE;
-}
-
-
-SV *
-dbd_st_FETCH_attrib(SV *sth, imp_sth_t *imp_sth, SV *keysv)
-{
- dTHX;
- STRLEN kl;
- char *key = SvPV(keysv,kl);
- int i;
- SV *retsv = NULL;
- /* Default to caching results for DBI dispatch quick_FETCH */
- int cacheit = TRUE;
- /* int oraperl = DBIc_COMPAT(imp_sth); */
-
- if (kl==13 && strEQ(key, "NUM_OF_PARAMS")) /* handled by DBI */
- return Nullsv;
-
- if (!imp_sth->done_desc && !dbd_describe(sth, imp_sth)) {
- STRLEN lna;
- /* dbd_describe has already called ora_error() */
- /* we can't return Nullsv here because the xs code will */
- /* then just pass the attribute name to DBI for FETCH. */
- croak("Describe failed during %s->FETCH(%s): %ld: %s",
- SvPV(sth,PL_na), key, (long)SvIV(DBIc_ERR(imp_sth)),
- SvPV(DBIc_ERRSTR(imp_sth),lna)
- );
- }
-
- i = DBIc_NUM_FIELDS(imp_sth);
-
- if (kl==4 && strEQ(key, "NAME")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSVpv((char*)imp_sth->fbh[i].name,0));
-
- }
- else if (kl==11 && strEQ(key, "ParamValues")) {
- HV *pvhv = newHV();
- if (imp_sth->all_params_hv) {
- SV *sv;
- char *key;
- I32 keylen;
- hv_iterinit(imp_sth->all_params_hv);
- while ( (sv = hv_iternextsv(imp_sth->all_params_hv, &key, &keylen)) ) {
- phs_t *phs = (phs_t*)(void*)SvPVX(sv); /* placeholder struct */
- (void)hv_store(pvhv, key, keylen, newSVsv(phs->sv), 0);
- }
- }
- retsv = newRV_noinc((SV*)pvhv);
- cacheit = FALSE;
-
- }
- else if (kl==11 && strEQ(key, "ora_lengths")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv((IV)imp_sth->fbh[i].disize));
- }
- else if (kl==9 && strEQ(key, "ora_types")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(imp_sth->fbh[i].dbtype));
- }
- else if (kl==4 && strEQ(key, "TYPE")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).dbtype));
- }
- else if (kl==5 && strEQ(key, "SCALE")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).scale));
- }
- else if (kl==9 && strEQ(key, "PRECISION")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(ora2sql_type(imp_sth->fbh+i).prec));
-#ifdef XXX
- }
- else if (kl==9 && strEQ(key, "ora_rowid")) {
- /* return current _binary_ ROWID (oratype 11) uncached */
- /* Use { ora_type => 11 } when binding to a placeholder */
- retsv = newSVpv((char*)&imp_sth->cda->rid, sizeof(imp_sth->cda->rid));
- cacheit = FALSE;
-#endif
- }
- else if (kl==17 && strEQ(key, "ora_est_row_width")) {
- retsv = newSViv(imp_sth->est_width);
- cacheit = TRUE;
- }
- else if (kl==11 && strEQ(key, "RowsInCache")) {
- retsv = newSViv(imp_sth->RowsInCache);
- cacheit = FALSE;
-
- }else if (kl==12 && strEQ(key, "RowCacheSize")) {
- retsv = newSViv(imp_sth->RowCacheSize);
- cacheit = FALSE;
- }
- else if (kl==8 && strEQ(key, "NULLABLE")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, boolSV(imp_sth->fbh[i].nullok));
- }
- else if (kl==13 && strEQ(key, "len_char_size")) {
- AV *av = newAV();
- retsv = newRV(sv_2mortal((SV*)av));
- while(--i >= 0)
- av_store(av, i, newSViv(imp_sth->fbh[i].len_char_size));
- }
- else {
- return Nullsv;
- }
- if (cacheit) { /* cache for next time (via DBI quick_FETCH) */
- SV **svp = hv_fetch((HV*)SvRV(sth), key, kl, 1);
- sv_free(*svp);
- *svp = retsv;
- (void)SvREFCNT_inc(retsv); /* so sv_2mortal won't free it */
- }
- return sv_2mortal(retsv);
-}
-
-/* --------------------------------------- */
-
-static sql_fbh_t
-ora2sql_type(imp_fbh_t* fbh) {
- sql_fbh_t sql_fbh;
- sql_fbh.dbtype = fbh->dbtype;
- sql_fbh.prec = fbh->prec;
- sql_fbh.scale = fbh->scale;
-
- switch(fbh->dbtype) { /* oracle Internal (not external) types */
- case SQLT_NUM:
- if (fbh->scale == -127) { /* FLOAT, REAL, DOUBLE_PRECISION */
- sql_fbh.dbtype = SQL_DOUBLE;
- sql_fbh.scale = 0; /* better: undef */
- if (fbh->prec == 0) { /* NUMBER; s. Oracle Bug# 2755842, 2235818 */
- sql_fbh.prec = 126;
- }
- }
- else if (fbh->scale == 0) {
- if (fbh->prec == 0) { /* NUMBER */
- sql_fbh.dbtype = SQL_DOUBLE;
- sql_fbh.prec = 126;
- }
- else { /* INTEGER, NUMBER(p,0) */
- sql_fbh.dbtype = SQL_DECIMAL; /* better: SQL_INTEGER */
- }
- }
- else { /* NUMBER(p,s) */
- sql_fbh.dbtype = SQL_DECIMAL; /* better: SQL_NUMERIC */
- }
- break;
-#ifdef SQLT_IBDOUBLE
- case SQLT_BDOUBLE:
- case SQLT_BFLOAT:
- case SQLT_IBDOUBLE:
- case SQLT_IBFLOAT:
- sql_fbh.dbtype = SQL_DOUBLE;
- sql_fbh.prec = 126;
- break;
-#endif
- case SQLT_CHR: sql_fbh.dbtype = SQL_VARCHAR; break;
- case SQLT_LNG: sql_fbh.dbtype = SQL_LONGVARCHAR; break; /* long */
- case SQLT_DAT: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP;break;
- case SQLT_BIN: sql_fbh.dbtype = SQL_BINARY; break; /* raw */
- case SQLT_LBI: sql_fbh.dbtype = SQL_LONGVARBINARY; break; /* long raw */
- case SQLT_AFC: sql_fbh.dbtype = SQL_CHAR; break; /* Ansi fixed char */
- case SQLT_CLOB: sql_fbh.dbtype = SQL_CLOB; break;
- case SQLT_BLOB: sql_fbh.dbtype = SQL_BLOB; break;
-#ifdef SQLT_TIMESTAMP_TZ
- case SQLT_DATE: sql_fbh.dbtype = SQL_DATE; break;
- case SQLT_TIME: sql_fbh.dbtype = SQL_TIME; break;
- case SQLT_TIME_TZ: sql_fbh.dbtype = SQL_TYPE_TIME_WITH_TIMEZONE; break;
- case SQLT_TIMESTAMP: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP; break;
- case SQLT_TIMESTAMP_TZ: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE; break;
- case SQLT_TIMESTAMP_LTZ: sql_fbh.dbtype = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE; break;
- case SQLT_INTERVAL_YM: sql_fbh.dbtype = SQL_INTERVAL_YEAR_TO_MONTH; break;
- case SQLT_INTERVAL_DS: sql_fbh.dbtype = SQL_INTERVAL_DAY_TO_SECOND; break;
-#endif
- default: sql_fbh.dbtype = -9000 - fbh->dbtype; /* else map type into DBI reserved standard range */
- }
- return sql_fbh;
-}
-
-static void
-dump_env_to_trace() {
- dTHX;
- PerlIO *fp = DBILOGFP;
- int i = 0;
- char *p;
-
-#if defined (__APPLE__)
- #include <crt_externs.h>
- #define environ (*_NSGetEnviron())
-#elif defined (__BORLANDC__)
- extern char **environ;
-#endif
-
-
- PerlIO_printf(fp, "Environment variables:\n");
- do {
- p = (char*)environ[i++];
- PerlIO_printf(fp,"\t%s\n",p);
- } while ((char*)environ[i] != '\0');
-}
-
Modified: dbd-oracle/branches/FAN/dbdimp.h
==============================================================================
--- dbd-oracle/branches/FAN/dbdimp.h (original)
+++ dbd-oracle/branches/FAN/dbdimp.h Mon Feb 27 10:37:22 2012
@@ -1,441 +0,0 @@
-/*
- Copyright (c) 1994-2006 Tim Bunce
- Copyright (c) 2006-2011 John Scoles (The Pythian Group), Canada
- Copyright (c) 2011 John Scoles
- See the COPYRIGHT section in the Oracle.pm file for terms.
-
-*/
-
-/* ====== define data types ====== */
-
-/*--------------------------FAN Callback Structure ---------------------*/
-
-typedef struct ha_ctx_st ha_ctx_t;
-
-struct ha_ctx_st {
- PerlInterpreter *ctx_perl;
- imp_dbh_t *imp_dbh;
- char *function;
-};
-
-/*--------------------------TAF Callback Structure ---------------------*/
-
-typedef struct taf_callback_st taf_callback_t;
-
-struct taf_callback_st {
- char *function; /*User supplied perl TAF functiomn*/
- int sleep;
-};
-
-typedef struct imp_fbh_st imp_fbh_t;
-
-
-struct imp_drh_st {
- dbih_drc_t com; /* MUST be first element in structure */
- OCIEnv *envhp;
- SV *ora_long;
- SV *ora_trunc;
- SV *ora_cache;
- SV *ora_cache_o; /* for ora_open() cache override */
-};
-
-
-/* Define dbh implementor data structure */
-struct imp_dbh_st {
- dbih_dbc_t com; /* MUST be first element in structure */
-
-#ifdef USE_ITHREADS
- int refcnt ; /* keep track of duped handles. MUST be first after com */
- struct imp_dbh_st * shared_dbh ; /* pointer to shared space from which to dup and keep refcnt */
- SV * shared_dbh_priv_sv ;
-#endif
-
- void *(*get_oci_handle) _((imp_dbh_t *imp_dbh, int handle_type, int flags));
- OCIEnv *envhp; /* copy of drh pointer */
- OCIError *errhp;
- OCIServer *srvhp;
- OCISvcCtx *svchp;
- OCISession *seshp;
-#ifdef ORA_OCI_112
- OCIAuthInfo *authp;
- OCISPool *poolhp;
- text *pool_name;
- ub4 pool_namel;
- bool using_drcp;
- text *pool_class;
- ub4 pool_classl;
- ub4 pool_min;
- ub4 pool_max;
- ub4 pool_incr;
- char *driver_name;/*driver name user defined*/
- ub4 driver_namel;
- bool using_ha; /*HA events */
- char *ha_function; /*HA function */
-#endif
- bool using_taf; /*TAF stuff*/
- char *taf_function; /*User supplied TAF function*/
- int taf_sleep;
- char *client_info; /*user defined*/
- ub4 client_infol;
- char *module_name; /*module user defined */
- ub4 module_namel;
- char *client_identifier; /*user defined*/
- ub4 client_identifierl;
- char *action; /*user defined*/
- ub4 actionl;
- int RowCacheSize; /* both of these are defined by DBI spec*/
- int RowsInCache; /* this vaue is RO and cannot be set*/
- int ph_type; /* default oratype for placeholders */
- ub1 ph_csform; /* default charset for placeholders */
- int parse_error_offset; /* position in statement of last error */
- int max_nested_cursors; /* limit on cached nested cursors per stmt */
- int array_chunk_size; /* the max size for an array bind */
- ub4 server_version; /* version of Oracle server */
-};
-
-#define DBH_DUP_OFF sizeof(dbih_dbc_t)
-#define DBH_DUP_LEN (sizeof(struct imp_dbh_st) - sizeof(dbih_dbc_t))
-
-
-
-typedef struct lob_refetch_st lob_refetch_t; /* Define sth implementor data structure */
-
-
-/*statement structure */
-struct imp_sth_st {
-
- dbih_stc_t com; /* MUST be first element in structure */
-
- void *(*get_oci_handle) _((imp_sth_t *imp_sth, int handle_type, int flags));
- OCIEnv *envhp; /* copy of dbh pointer */
- OCIError *errhp; /* copy of dbh pointer */
- OCIServer *srvhp; /* copy of dbh pointer */
- OCISvcCtx *svchp; /* copy of dbh pointer */
- OCIStmt *stmhp; /* oci statement handle */
- OCIDescribe *dschp; /* oci describe handle */
- int is_child; /* if this is child from a ref cursor or SP*/
- ub2 stmt_type; /* OCIAttrGet OCI_ATTR_STMT_TYPE */
- U16 auto_lob; /* use auto lobs*/
- int pers_lob; /*use dblink for lobs only for 10g Release 2. or later*/
- int clbk_lob; /*use dblink for lobs only for 10g Release 2. or later*/
- int piece_lob; /*use piece fetch for lobs*/
- ub4 piece_size; /*used in callback to set the size of the piece to get*/
- int has_lobs; /*Statement has bound LOBS */
- int ret_lobs; /*Statement returns LOBS */
- lob_refetch_t *lob_refetch;
- int nested_cursor; /* cursors fetched from SELECTs */
- AV *bind_tuples; /* Bind tuples in array execute, or NULL */
- int rowwise; /* If true, bind_tuples is list of */
- /* tuples, otherwise list of columns. */
- /* Input Details */
- char *statement; /* sql (see sth_scan) */
- HV *all_params_hv; /* all params, keyed by name */
- AV *out_params_av; /* quick access to inout params */
- int ora_pad_empty; /* convert ""->" " when binding */
-
- /* Select Column Output Details */
- int done_desc; /* have we described this sth yet ? */
- imp_fbh_t *fbh; /* array of imp_fbh_t structs */
- char *fbh_cbuf; /* memory for all field names */
- int t_dbsize; /* raw data width of a row */
- UV long_readlen; /* local copy to handle oraperl */
- HV *fbh_tdo_hv; /* hash of row #(0 based) and tdo object name from ora_oci_type_names hash */
- /* Select Row Cache Details */
- sb4 cache_rows;
- int in_cache;
- int next_entry;
- int eod_errno;
- int est_width; /* est'd avg row width on-the-wire */
- /* (In/)Out Parameter Details */
- bool has_inout_params;
- /* execute mode*/
- /* will be using this alot later me thinks */
- ub4 exe_mode;
- /* fetch scrolling values */
- int fetch_orient;
- int fetch_offset;
- int fetch_position;
- int prefetch_memory; /* OCI_PREFETCH_MEMORY*/
- int prefetch_rows; /* OCI_PREFETCH_ROWS */
- /* array fetch: state variables */
- int row_cache_off;
- int rs_fetch_count; /*fetch count*/
- int rs_array_size; /*array size local value for RowCacheSize as I do not want to change RowCacheSize */
- int rs_array_num_rows; /* num rows in last fetch */
- int rs_array_idx; /* index of current row */
- sword rs_array_status; /* status of last fetch */
- int RowCacheSize; /* both of these are defined by DBI spec*/
- int RowsInCache; /* this vaue is RO and cannot be set*/
-
-};
-#define IMP_STH_EXECUTING 0x0001
-
-
-typedef struct fb_ary_st fb_ary_t; /* field buffer array */
-struct fb_ary_st { /* field buffer array EXPERIMENTAL */
- ub4 bufl; /* length of data buffer */
- ub4 cb_bufl; /* length of piece of data fetched in callback.*/
- ub4 piece_count;/*# of pieces retrieved*/
- sb2 *aindp; /* null/trunc indicator variable */
- ub1 *abuf; /* data buffer (points to sv data) */
- ub1 *cb_abuf; /*yet another buffer for picewise callbacks this means I only need to allocate memory once a prepare rather than at each fetch*/
- ub2 *arlen; /* length of returned data */
- ub2 *arcode; /* field level error status */
-};
-
-
-typedef struct fbh_obj_st fbh_obj_t; /*Ebbedded Object Descriptor */
-
-struct fbh_obj_st { /* embedded object or table will work recursively*/
- text *type_name; /*object's name (TDO)*/
- ub4 type_namel; /*length of the name*/
- OCIParam *parmdp; /*Describe attributes of the object OCI_DTYPE_PARAM*/
- OCIParam *parmap; /*Describe attributes of the object OCI_ATTR_COLLECTION_ELEMENT OCI_ATTR_PARAM*/
- OCIType *tdo; /*object's TDO handle */
- OCITypeCode typecode; /*object's OOCI_ATTR_TYPECODE */
- OCITypeCode col_typecode; /*if collection this is its OCI_ATTR_COLLECTION_TYPECODE */
- OCITypeCode element_typecode; /*if collection this is its element's OCI_ATTR_TYPECODE*/
- OCIRef *obj_ref; /*if an embeded object this is ref handle to its TDO*/
- OCIInd *obj_ind; /*Null indictator for object */
- OCIComplexObject *obj_value; /*the actual value from the DB*/
- OCIType *obj_type; /*if an embeded object this is the OCIType returned by a OCIObjectPin*/
- ub1 is_final_type; /*object's OCI_ATTR_IS_FINAL_TYPE*/
- fbh_obj_t *fields; /*one object for each field/property*/
- ub2 field_count; /*The number of fields Not really needed but nice to have*/
- fbh_obj_t *next_subtype; /*There is strored information about subtypes for inteherited objects*/
- AV *value; /*The value to send back to Perl This way there are no memory leaks*/
- SV *full_type_name; /*Perl value of full type name = schema_name "." type_name*/
-
-};
-
-struct imp_fbh_st { /* field buffer EXPERIMENTAL */
- imp_sth_t *imp_sth; /* 'parent' statement */
- int field_num; /* 0..n-1 */
-
- /* Oracle's description of the field */
- OCIParam *parmdp;
- OCIDefine *defnp;
- void *desc_h; /* descriptor if needed (LOBs etc) */
- ub4 desc_t; /* OCI type of descriptor */
- ub4 define_mode; /*the normal case for a define*/
- int (*fetch_func) _((SV *sth, imp_fbh_t *fbh, SV *dest_sv));
- void (*fetch_cleanup) _((SV *sth, imp_fbh_t *fbh));
- ub2 dbtype; /* actual type of field (see ftype) */
- ub2 dbsize;
- ub2 prec; /* XXX docs say ub1 but ub2 is needed */
- sb1 scale;
- ub1 nullok;
- char *name;
- SV *name_sv; /* only set for OCI8 */
- /* OCI docs say OCI_ATTR_CHAR_USED is ub4, they're wrong */
- ub1 len_char_used; /* OCI_ATTR_CHAR_USED */
- ub2 len_char_size; /* OCI_ATTR_CHAR_SIZE */
- ub2 csid; /* OCI_ATTR_CHARSET_ID */
- ub1 csform; /* OCI_ATTR_CHARSET_FORM */
- ub4 disize; /* max display/buffer size */
- ub4 piece_size; /*used in callback to set the size of the piece to get*/
- char *bless; /* for Oracle::OCI style handle data */
- void *special; /* hook for special purposes (LOBs etc) */
- int pers_lob; /*for persistant lobs 10g Release 2. or later*/
- int clbk_lob; /*for persistant lobs 10g Release 2. or later*/
- int piece_lob; /*use piecewise fetch for lobs*/
-
- /* Our storage space for the field data as it's fetched */
-
- sword ftype; /* external datatype we wish to get */
- IV req_type; /* type passed to bind_col */
- UV bind_flags; /* flags passed to bind_col */
- fb_ary_t *fb_ary ; /* field buffer array */
- /* if this is an embedded object we use this */
- fbh_obj_t *obj;
-
-
- };
-
- /* Placeholder structure */
- /* Note: phs_t is serialized into scalar value, and de-serialized then. */
- /* Be carefull! */
-
-typedef struct phs_st phs_t; /* scalar placeholder */
-
-struct phs_st { /* scalar placeholder EXPERIMENTAL */
- imp_sth_t *imp_sth; /* 'parent' statement */
- sword ftype; /* external OCI field type */
-
- SV *sv; /* the scalar holding the value */
- U32 sv_type; /* original sv type at time of bind */
- ub2 csid_orig; /* original oracle default csid */
- ub2 csid; /* 0 for automatic */
- ub1 csform; /* 0 for automatic */
- ub4 maxdata_size; /* set OCI_ATTR_MAXDATA_SIZE if >0 */
- bool is_inout;
-
- IV maxlen; /* max possible len (=allocated buffer) */
- /* Note: for array bind = buffer for each entry */
- OCIBind *bndhp;
- void *desc_h; /* descriptor if needed (LOBs etc) */
- ub4 desc_t; /* OCI type of desc_h */
- ub4 alen;
- ub2 arcode;
- int idx; /* 0-based index for ?/:1 style, or -1 */
-
- sb2 indp; /* null indicator */
- char *progv;
-
- int(*out_prepost_exec)_((SV *, imp_sth_t *, phs_t *, int pre_exec));
- SV *ora_field; /* from attribute (for LOB binds) */
- ub4 alen_incnull; /* 0 or 1 if alen should include null */
- /* Array bind support */
- char *array_buf; /* Temporary buffer = malloc(array_buflen) */
- int array_buflen; /* Allocated length of array_buf */
- int array_numstruct; /* Number of bound structures in buffer */
- OCIInd *array_indicators; /* Indicator array = malloc( array_numallocated * sizeof(OCIInd) ) */
- unsigned short *array_lengths; /* Array entries lengths = malloc( array_numallocated * sizeof(unsigned short) ) */
- int array_numallocated; /* Allocated number of indicators/lengths */
- int ora_maxarray_numentries; /* Number of entries to send allocated to Oracle. (may be less, than total allocated) */
-
- /* Support for different internal C-types, representing Oracle data */
- int ora_internal_type; /* Which C-type would be bound instead of SQLT_CHR. */
-
- char name[1]; /* struct is malloc'd bigger as needed */
-};
-
-
-/* ------ define functions and external variables ------ */
-
-extern int ora_fetchtest;
-extern int dbd_verbose;
-extern int oci_warn;
-extern int ora_objects;
-extern int ora_ncs_buff_mtpl;
-extern ub2 charsetid;
-extern ub2 ncharsetid;
-extern ub2 us7ascii_csid;
-extern ub2 utf8_csid;
-extern ub2 al32utf8_csid;
-extern ub2 al16utf16_csid;
-
-#define CS_IS_UTF8( cs ) \
- ( ( cs == utf8_csid ) || ( cs == al32utf8_csid ) )
-
-#define CS_IS_NOT_UTF8_COMPATIBLE( cs ) \
- ( cs == us7ascii_csid )
-
- #define CS_IS_UTF16( cs ) ( cs == al16utf16_csid )
-
-
-#define CSFORM_IMPLIED_CSID(csform) \
- ((csform==SQLCS_NCHAR) ? ncharsetid : charsetid)
-
-#define CSFORM_IMPLIES_UTF8(csform) \
- CS_IS_UTF8( CSFORM_IMPLIED_CSID( csform ) )
-
-
-void dbd_init_oci _((dbistate_t *dbistate));
-void dbd_preparse _((imp_sth_t *imp_sth, char *statement));
-void dbd_fbh_dump(imp_fbh_t *fbh, int i, int aidx);
-void ora_free_fbh_contents _((imp_fbh_t *fbh));
-void ora_free_templob _((SV *sth, imp_sth_t *imp_sth, OCILobLocator *lobloc));
-int ora_dbtype_is_long _((int dbtype));
-fb_ary_t *fb_ary_alloc _((ub4 bufl, int size));
-fb_ary_t *fb_ary_cb_alloc _((ub4 piece_size,ub4 max_len, int size));
-
-int ora_db_reauthenticate _((SV *dbh, imp_dbh_t *imp_dbh, char *uid, char *pwd));
-
-void dbd_phs_sv_complete _((phs_t *phs, SV *sv, I32 debug));
-void dbd_phs_avsv_complete _((phs_t *phs, I32 index, I32 debug));
-
-int pp_exec_rset _((SV *sth, imp_sth_t *imp_sth, phs_t *phs, int pre_exec));
-int pp_rebind_ph_rset_in _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
-
-#define OTYPE_IS_LONG(t) ((t)==8 || (t)==24 || (t)==94 || (t)==95)
-
-int oci_error_err _((SV *h, OCIError *errhp, sword status, char *what, sb4 force_err));
-#define oci_error(h, errhp, status, what) oci_error_err(h, errhp, status, what, 0)
-char *oci_stmt_type_name _((int stmt_type));
-char *oci_typecode_name _((int typecode));
-char *sql_typecode_name _((int dbtype));
-char *oci_status_name _((sword status));
-char *oci_mode _((ub4 mode));
-char *oci_bind_options _((ub4 options));
-char *oci_define_options _((ub4 options));
-char *oci_hdtype_name _((ub4 hdtype));
-char *oci_attr_name _((ub4 attr));
-char *oci_exe_mode _((ub4 mode));
-char *dbd_yes_no _((int yes_no));
-char *oci_col_return_codes _((int rc));
-char *oci_csform_name _((ub4 attr));
-char *oci_sql_function_code_name _((int sqlfncode));
-char *oci_ptype_name _((int ptype));
-
-int dbd_rebind_ph_lob _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
-
-int dbd_rebind_ph_nty _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
-
-int ora_st_execute_array _((SV *sth, imp_sth_t *imp_sth, SV *tuples,
- SV *tuples_status, SV *columns, ub4 exe_count, SV *err_count));
-
-
-SV * ora_create_xml _((SV *dbh, char *source));
-
-void ora_free_lob_refetch _((SV *sth, imp_sth_t *imp_sth));
-void dbd_phs_avsv_complete _((phs_t *phs, I32 index, I32 debug));
-void dbd_phs_sv_complete _((phs_t *phs, SV *sv, I32 debug));
-int post_execute_lobs _((SV *sth, imp_sth_t *imp_sth, ub4 row_count));
-ub4 ora_parse_uid _((imp_dbh_t *imp_dbh, char **uidp, char **pwdp));
-char *ora_sql_error _((imp_sth_t *imp_sth, char *msg));
-char *ora_env_var(char *name, char *buf, unsigned long size);
-
-#ifdef __CYGWIN32__
-void ora_cygwin_set_env(char *name, char *value);
-
-#endif /* __CYGWIN32__ */
-
-sb4 dbd_phs_in _((dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index,
- dvoid **bufpp, ub4 *alenp, ub1 *piecep, dvoid **indpp));
-sb4 dbd_phs_out _((dvoid *octxp, OCIBind *bindp, ub4 iter, ub4 index,
- dvoid **bufpp, ub4 **alenpp, ub1 *piecep,
- dvoid **indpp, ub2 **rcodepp));
-sb4 presist_lob_fetch_cbk _((dvoid *octxp, OCIDefine *dfnhp, ub4 iter, dvoid **bufpp,
- ub4 **alenpp, ub1 *piecep, dvoid **indpp, ub2 **rcpp));
-int dbd_rebind_ph_rset _((SV *sth, imp_sth_t *imp_sth, phs_t *phs));
-
-void * oci_db_handle(imp_dbh_t *imp_dbh, int handle_type, int flags);
-void * oci_st_handle(imp_sth_t *imp_sth, int handle_type, int flags);
-void fb_ary_free(fb_ary_t *fb_ary);
-void rs_array_init(imp_sth_t *imp_sth);
-
-ub4 ora_db_version _((SV *dbh, imp_dbh_t *imp_dbh));
-sb4 reg_taf_callback _((imp_dbh_t *imp_dbh));
-sb4 reg_ha_callback _((imp_dbh_t *imp_dbh));
-
-/* These defines avoid name clashes for multiple statically linked DBD's */
-
-#define dbd_init ora_init
-#define dbd_db_login ora_db_login
-#define dbd_db_login6 ora_db_login6
-#define dbd_db_do ora_db_do
-#define dbd_db_commit ora_db_commit
-#define dbd_db_rollback ora_db_rollback
-#define dbd_db_cancel ora_db_cancel
-#define dbd_db_disconnect ora_db_disconnect
-#define dbd_db_destroy ora_db_destroy
-#define dbd_db_STORE_attrib ora_db_STORE_attrib
-#define dbd_db_FETCH_attrib ora_db_FETCH_attrib
-#define dbd_st_prepare ora_st_prepare
-#define dbd_st_rows ora_st_rows
-#define dbd_st_cancel ora_st_cancel
-#define dbd_st_execute ora_st_execute
-#define dbd_st_fetch ora_st_fetch
-#define dbd_st_finish ora_st_finish
-#define dbd_st_destroy ora_st_destroy
-#define dbd_st_blob_read ora_st_blob_read
-#define dbd_st_STORE_attrib ora_st_STORE_attrib
-#define dbd_st_FETCH_attrib ora_st_FETCH_attrib
-#define dbd_describe ora_describe
-#define dbd_bind_ph ora_bind_ph
-#define dbd_st_bind_col ora_st_bind_col
-#include "ocitrace.h"
-
-/* end */
-