DBD-Oracle
view release on metacpan or search on metacpan
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));
}
#ifdef ORA_OCI_112
if (imp_dbh->using_drcp) {
/* Store lookup from charset name to charset ID. */
(void)hv_store_ent(imp_drh->charset_hv, *svp, newSViv(new_charsetid), 0);
}
#endif
}
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));
}
#ifdef ORA_OCI_112
if (imp_dbh->using_drcp) {
/* Store lookup from charset name to charset ID. */
(void)hv_store_ent(imp_drh->charset_hv, *svp, newSViv(new_ncharsetid), 0);
}
#endif
}
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;
OCIHandleFree_log_stat(imp_dbh, imp_dbh->envhp, OCI_HTYPE_ENV, status);
OCIEnvNlsCreate_log_stat(imp_dbh, &imp_dbh->envhp, init_mode, 0, NULL, NULL, NULL, 0, 0,
charsetid, ncharsetid, status );
if (status != OCI_SUCCESS) {
oci_error(dbh, NULL, status,
"OCIEnvNlsCreate. Check ORACLE_HOME (Linux) env var or PATH (Windows) and or NLS settings, permissions, etc");
return 0;
}
}
#ifdef ORA_OCI_112
if (!imp_dbh->using_drcp)
#endif
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");
}
#ifdef ORA_OCI_112
if (imp_dbh->using_drcp) {
/* Try looking up session pool again, in case ora_charsetid/ora_ncharsetid were used to specify previously used charset IDs from the NLS environment. */
SV *key_sv = pool_key(imp_dbh, dbname, uid, pwd, charsetid, ncharsetid);
if ((pool = pool_fetch(imp_drh, key_sv))) {
imp_dbh->pool = pool;
/* Free the current environment handle and replace it with the session pool's environment handle. */
OCIHandleFree_log_stat(imp_dbh, imp_dbh->envhp, OCI_HTYPE_ENV, status);
imp_dbh->envhp = pool->envhp;
}
sv_free(key_sv);
}
#endif
}
if (!imp_dbh->errhp) {
OCIHandleAlloc_ok(imp_dbh, imp_dbh->envhp, &imp_dbh->errhp, OCI_HTYPE_ERROR, status);
}
OCIAttrGet_log_stat(imp_dbh, imp_dbh->envhp, OCI_HTYPE_ENV, &charsetid, NULL,
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, imp_dbh->envhp, OCI_HTYPE_ENV, &ncharsetid, NULL,
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 (DBIc_DBISTATE(imp_dbh)->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(
DBIc_LOGPIO(imp_dbh),
" 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)
phs->array_numstruct = numarrayentries+1;
if (trace_level >= 2 || dbd_verbose >= 3 ){
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
"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(DBIc_LOGPIO(imp_sth),
"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) */
(void)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(
DBIc_LOGPIO(imp_sth),
"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(
DBIc_LOGPIO(imp_sth),
"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(
DBIc_LOGPIO(imp_sth),
"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(
DBIc_LOGPIO(imp_sth),
"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(
DBIc_LOGPIO(imp_sth),
"dbd_rebind_ph_varchar2_table(): phs->maxlen calculated =%ld\n",
(long)maxlen);
}
} else{
if (trace_level >= 2 || dbd_verbose >= 3 ){
PerlIO_printf(
DBIc_LOGPIO(imp_sth),
"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(
DBIc_LOGPIO(imp_sth),
"dbd_rebind_ph_varchar2_table(): ora_realloc_phs_array(,"
"need_allocate_rows=%d,buflen=%d) succeeded.\n",
need_allocate_rows,buflen);
}
}
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(
DBIc_LOGPIO(imp_sth), " 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(DBIc_LOGPIO(imp_sth), " 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, 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(imp_sth, 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(
DBIc_LOGPIO(imp_sth),
"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(imp_sth, 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(imp_sth, phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, NULL,
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(
DBIc_LOGPIO(imp_sth),
"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(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;
}
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(imp_sth, phs, avlen, debug);
}
else {
dbd_phs_sv_complete(imp_sth, 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 = DBIc_DBISTATE(imp_sth)->debug;
int i;
OCIBindByName_log_stat(imp_sth, imp_sth->stmhp, &phs->bndhp, imp_sth->errhp,
(text*)phs->name, (sb4)strlen(phs->name),
0,
(sb4)phs->maxlen,
(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(imp_sth, 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(
DBIc_LOGPIO(imp_sth),
"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(imp_sth, 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(imp_sth, phs->bndhp, OCI_HTYPE_BIND, &phs->csid_orig, NULL,
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(
DBIc_LOGPIO(imp_sth),
"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(imp_sth, phs->bndhp, (ub4) OCI_HTYPE_BIND,
( run in 0.764 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )