DBD-Oracle
view release on metacpan or search on metacpan
dTHR;
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_sth_t *imp_sth, imp_fbh_t *fbh, int i, int aidx)
{
dTHX;
PerlIO_printf(DBIc_LOGPIO(imp_sth), " fbh %d: '%s'\t%s, ",
i, fbh->name, (fbh->nullok) ? "NULLable" : "NO null ");
PerlIO_printf(DBIc_LOGPIO(imp_sth), "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(DBIc_LOGPIO(imp_sth), " 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 careful here as its value (108) is the same for an embedded object Well really 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);
#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 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->taf_function){
if (enable_taf(dbh, imp_dbh) == 0) return 0;
}
return 1;
}
int
dbd_db_commit(SV *dbh, imp_dbh_t *imp_dbh)
{
dTHX;
sword status;
OCITransCommit_log_stat(imp_dbh, 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, 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, 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);
}
if (type != 0) {
imp_sth->fbh[field-1].req_type = type;
}
if (attribs) {
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;
}
}
else if (kl==12 && strEQ(key, "ora_drcp_rlb") ) {
imp_dbh->pool_rlb = SvIV (valuesv);
}
#endif
else if (kl==16 && strEQ(key, "ora_taf_function") ) {
if (imp_dbh->taf_function)
SvREFCNT_dec(imp_dbh->taf_function);
imp_dbh->taf_function = newSVsv(valuesv);
if (SvTRUE(valuesv)) {
enable_taf(dbh, imp_dbh);
} else {
disable_taf(imp_dbh);
}
}
#ifdef OCI_ATTR_ACTION
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, imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->action,imp_dbh->actionl,OCI_ATTR_ACTION,imp_dbh->errhp, status);
}
#endif
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, imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->client_identifier,imp_dbh->client_identifierl,OCI_ATTR_CLIENT_IDENTIFIER,imp_dbh->errhp, status);
}
#ifdef OCI_ATTR_CLIENT_INFO
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, imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->client_info,imp_dbh->client_infol,OCI_ATTR_CLIENT_INFO,imp_dbh->errhp, status);
}
#endif
#ifdef OCI_ATTR_MODULE
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, imp_dbh->seshp,OCI_HTYPE_SESSION, imp_dbh->module_name,imp_dbh->module_namel,OCI_ATTR_MODULE,imp_dbh->errhp, status);
}
#endif
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==12 && strEQ(key, "ora_drcp_rlb") ) {
retsv = newSViv(imp_dbh->pool_rlb);
}
#endif
else if (kl==16 && strEQ(key, "ora_taf_function") ) {
if (imp_dbh->taf_function) {
retsv = newSVsv(imp_dbh->taf_function);
}
}
#ifdef OCI_ATTR_ACTION
else if (kl==10 && strEQ(key, "ora_action")) {
retsv = newSVpv((char *)imp_dbh->action,0);
}
#endif
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;
dTHR;
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 (DBIc_DBISTATE(imp_sth)->debug >=3 || dbd_verbose >= 3 )
PerlIO_printf(DBIc_LOGPIO(imp_sth), " creating xml from string that is %lu long\n",(unsigned long)len);
if(len > MAX_OCISTRING_LEN) {
src_type = OCI_XMLTYPE_CREATE_CLOB;
if (DBIc_DBISTATE(imp_sth)->debug >=5 || dbd_verbose >= 5 )
PerlIO_printf(DBIc_LOGPIO(imp_sth),
" use a temp lob locator for large xml \n");
}
}
/* 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 {
if (DBIc_DBISTATE(imp_sth)->debug >= 6|| dbd_verbose >= 6 ) {
PerlIO_printf(DBIc_LOGPIO(imp_sth),
"Changing maxlen to %ld\n", SvLEN(phs->sv));
}
phs->maxlen = ((IV)SvLEN(phs->sv)); /* avail buffer space (64bit safe) Logicaly maxlen should never change but it does why I know not - MJE because SvGROW can allocate more than you ask for - anyway - I fixed that and it doesn't grow anymore */
}
if (phs->maxlen < 0) /* can happen with nulls */
phs->maxlen = 0;
phs->alen = value_len + phs->alen_incnull;
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 ) {
/*UV neatsvpvlen = (UV)DBIc_DBISTATE(imp_sth)->neatsvpvlen;*/
char *val = neatsvpv(phs->sv,10);
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
"dbd_rebind_ph_char() (2): bind %s <== %.1000s (size %ld/%ld, "
"otype %d(%s), indp %d, at_exec %d)\n",
phs->name,
(phs->progv) ? val: "",
(long)phs->alen, (long)phs->maxlen,
phs->ftype,sql_typecode_name(phs->ftype), phs->indp, at_exec);
}
return 1;
}
/*
* Rebind an "in" cursor ref to its real statement handle
* This allows passing cursor refs as "in" to pl/sql (but only if you got the
* cursor from pl/sql to begin with)
*/
int
pp_rebind_ph_rset_in(SV *sth, imp_sth_t *imp_sth, phs_t *phs)
{
dTHX;
dTHR;
SV * sth_csr = phs->sv;
D_impdata(imp_sth_csr, imp_sth_t, sth_csr);
sword status;
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
" 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, 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 (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(DBIc_LOGPIO(imp_sth), " 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 - throw away previous descriptor and rebind */
sword status;
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
" 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(imp_sth, phs->desc_h, phs->desc_t, status);
phs->desc_h = NULL;
}
phs->desc_t = OCI_HTYPE_STMT;
OCIHandleAlloc_ok(imp_sth, imp_sth->envhp, &phs->desc_h, phs->desc_t, status);
}
phs->progv = (char*)&phs->desc_h;
phs->maxlen = 0;
OCIBindByName_log_stat(imp_sth, imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
(text*)phs->name,
(sb4)strlen(phs->name),
phs->progv,
0,
(ub2)phs->ftype,
/* I, MJE have no evidence that passing an indicator to this func
causes ORA-01001 (invalid cursor) errors. Also, without it
you cannot test the indicator to check we have a valid output
parameter. However, it would seem when you do specify an
indicator it always comes back as 0 so it is useless. */
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;
}
/*
NOTE: The code used to magic a DBI stmt handle into existence
here before even knowing if the output parameter was going to
be a valid open cursor. The code to do this moved to post execute
below. See RT 82663 - Errors if a returned SYS_REFCURSOR is not opened
*/
}
else { /* post-execute - setup the statement handle */
dTHR;
dSP;
D_imp_dbh_from_sth;
HV *init_attr = newHV();
int count;
ub4 stmt_state = 99;
sword status;
SV * sth_csr;
/* Before we go to the bother of attempting to allocate a new sth
for this cursor make sure the Oracle sth is executed i.e.,
the returned cursor may never have been opened */
OCIAttrGet_stmhp_stat2(imp_sth, (OCIStmt*)phs->desc_h, &stmt_state, 0,
OCI_ATTR_STMT_STATE, status);
if (status != OCI_SUCCESS) {
oci_error(sth, imp_sth->errhp, status, "OCIAttrGet OCI_ATTR_STMT_STATE");
return 0;
}
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 ) {
/* initialized=1, executed=2, end of fetch=3 */
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
" returned cursor/statement state: %u\n", stmt_state);
}
/* We seem to get an indp of 0 even for a cursor which was never
opened and set to NULL. If this is the case we check the stmt state
and find the cursor is initialized but not executed - there is no
point in going any further if it is not executed - just return undef.
See RT 82663 */
if (stmt_state == OCI_STMT_STATE_INITIALIZED) {
OCIHandleFree_log_stat(imp_sth, (OCIStmt *)phs->desc_h,
OCI_HTYPE_STMT, status);
if (status != OCI_SUCCESS) {
oci_error(sth, imp_sth->errhp, status, "OCIHandleFree");
return 0;
}
phs->desc_h = NULL;
phs->sv = newSV(0); /* undef */
return 1;
}
/* Now we know we have an executed cursor create a new sth */
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 (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
" pp_exec_rset bind %s - allocated %s...\n",
phs->name, neatsvpv(phs->sv, 0));
sth_csr = phs->sv;
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
" bind %s - initialising new %s for cursor 0x%lx...\n",
phs->name, neatsvpv(sth_csr,0), (unsigned long)phs->progv);
{
D_impdata(imp_sth_csr, imp_sth_t, sth_csr); /* TO_DO */
/* copy appropriate handles and attributes 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;
dTHR;
OCIType *tdo = NULL;
sword status;
SV* ptr;
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(DBIc_LOGPIO(imp_sth), " 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") ) {
/* TO_DO not logging: */
OCITypeByName_log(
imp_sth,
imp_sth->envhp,
imp_sth->errhp,
imp_sth->svchp,
(CONST text*)"SYS", 3, /* schema_name, schema_length */
(CONST text*)"XMLTYPE", 7, /* type_name, type_length */
(CONST text*)0, 0, /* version_name, version_length */
OCI_DURATION_CALLOUT, /* pin_duration */
OCI_TYPEGET_HEADER, /* get_option */
&tdo, /* tdo */
status);
ptr = SvRV(phs->sv);
phs->progv = (void*) SvIV(ptr);
phs->maxlen = sizeof(OCIXMLType*);
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(imp_sth, 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(imp_sth, 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 (DBIc_DBISTATE(imp_sth)->debug >= 2 || dbd_verbose >= 3 ) {
PerlIO_printf(
DBIc_LOGPIO(imp_sth), "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(DBIc_LOGPIO(imp_sth), ", inout 0x%lx, maxlen %ld",
(long)newvalue, (long)maxlen);
if (attribs)
PerlIO_printf(DBIc_LOGPIO(imp_sth), ", attribs: %s", neatsvpv(attribs,0));
PerlIO_printf(DBIc_LOGPIO(imp_sth), ")\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);
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(imp_sth_t *imp_sth, 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(imp_sth, phs, sv, 0);
if (debug >= 2 || dbd_verbose >= 3 )
PerlIO_printf(DBIc_LOGPIO(imp_sth),
" dbd_phs_avsv_complete out '%s'[%ld] = %s (arcode %d, ind %d, len %d)\n",
phs->name, (long)index, neatsvpv(sv,0), phs->arcode, phs->indp, phs->alen);
}
/* --- */
int
dbd_st_execute(SV *sth, imp_sth_t *imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */
{
dTHR;
dTHX;
ub4 row_count = 0;
int debug = DBIc_DBISTATE(imp_sth)->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(
DBIc_LOGPIO(imp_sth),
" 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(
DBIc_LOGPIO(imp_sth),
" 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(
DBIc_LOGPIO(imp_sth),
" 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(
DBIc_LOGPIO(imp_sth),
"Statement Execute Mode is %d (%s)\n",
imp_sth->exe_mode,oci_exe_mode(imp_sth->exe_mode));
OCIStmtExecute_log_stat(imp_sth, 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
}
#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;
}
(void)ftype; /* no unused */
if (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
" blob_read field %d+1, ftype %d, offset %ld, len %ld, "
"destoffset %ld, retlen %ld\n",
field, imp_sth->fbh[field].ftype, offset, len, destoffset, (long)retl);
SvCUR_set(bufsv, destoffset+retl);
*SvEND(bufsv) = '\0'; /* consistent with perl sv_setpvn etc */
return 1;
}
int
dbd_st_rows(SV *sth, imp_sth_t *imp_sth)
{
dTHX;
ub4 row_count = 0;
sword status;
OCIAttrGet_stmhp_stat(imp_sth, &row_count, 0, OCI_ATTR_ROW_COUNT, status);
if (status != OCI_SUCCESS) {
oci_error(sth, imp_sth->errhp, status, "OCIAttrGet OCI_ATTR_ROW_COUNT");
return -1;
}
return row_count;
}
int
dbd_st_finish(SV *sth, imp_sth_t *imp_sth)
{
dTHR;
dTHX;
D_imp_dbh_from_sth;
sword status;
int num_fields = DBIc_NUM_FIELDS(imp_sth);
int i;
if (DBIc_DBISTATE(imp_sth)->debug >= 6 || dbd_verbose >= 6 )
PerlIO_printf(DBIc_LOGPIO(imp_sth), " dbd_st_finish\n");
if (!DBIc_ACTIVE(imp_sth))
return 1;
/* Cancel further fetches from this cursor. */
/* We don't close the cursor till DESTROY (dbd_st_destroy). */
/* The application may re execute(...) it. */
/* Turn off ACTIVE here regardless of errors below. */
DBIc_ACTIVE_off(imp_sth);
for(i=0; i < num_fields; ++i) {
imp_fbh_t *fbh = &imp_sth->fbh[i];
if (fbh->fetch_cleanup) fbh->fetch_cleanup(sth, fbh);
}
if (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, 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(SV *sth, imp_fbh_t *fbh)
{
dTHX;
D_imp_sth(sth);
D_imp_dbh_from_sth;
if (fbh->fb_ary)
fb_ary_free(fbh->fb_ary);
sv_free(fbh->name_sv);
/* see rt 75163 */
if (fbh->desc_h) {
boolean is_open;
sword status;
OCILobFileIsOpen_log_stat(imp_dbh, imp_dbh->svchp, imp_dbh->errhp, fbh->desc_h, &is_open, status);
if (status == OCI_SUCCESS && is_open) {
OCILobFileClose_log_stat(imp_sth, imp_sth->svchp, imp_sth->errhp,
fbh->desc_h, status);
}
OCIDescriptorFree_log(imp_sth, fbh->desc_h, fbh->desc_t);
}
if (fbh->obj) {
if (fbh->obj->obj_value)
OCIObjectFree(fbh->imp_sth->envhp, fbh->imp_sth->errhp, fbh->obj->obj_value, (ub2)0);
Safefree(fbh->obj);
}
}
void
ora_free_phs_contents(imp_sth_t *imp_sth, phs_t *phs)
{
dTHX;
if (phs->desc_h)
OCIDescriptorFree_log(imp_sth, 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, 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 (DBIc_DBISTATE(imp_sth)->debug >= 3 || dbd_verbose >= 3 ) {
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
" OCILobFreeTemporary %s\n", oci_status_name(status));
}
OCILobFreeTemporary_log_stat(imp_sth, 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 ;
D_imp_dbh_from_sth;
/* 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 && DBIc_ACTIVE(imp_dbh)) {
OCIStmtFetch_log_stat(imp_sth, imp_sth->stmhp, imp_sth->errhp, 0,OCI_FETCH_NEXT,0, status);
}
if (imp_sth->dschp){
OCIHandleFree_log_stat(imp_sth, 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, 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(sth, 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(imp_sth, 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);
( run in 2.088 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )