DBI
view release on metacpan or search on metacpan
if (mg_find(SvRV(h), DBI_MAGIC) != NULL)
croak(errmsg, neatsvpv(orv,0), imp_class, "already a DBI (or ~magic) handle");
imp_mem_name = sv_2mortal(newSVpvf("%s_mem", imp_class));
if ( (imp_mem_stash = gv_stashsv(imp_mem_name, FALSE)) == NULL)
croak(errmsg, neatsvpv(orv,0), SvPVbyte_nolen(imp_mem_name), "unknown _mem package");
if ((svp = hv_fetchs((HV*)SvRV(h), "dbi_imp_data", 0))) {
dbi_imp_data = *svp;
if (SvGMAGICAL(dbi_imp_data)) /* call FETCH via magic */
mg_get(dbi_imp_data);
}
DBI_LOCK;
dbih_imp_sv = dbih_make_com(parent, parent_imp, imp_class, 0, 0, dbi_imp_data);
imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv);
dbih_imp_rv = newRV_inc(dbih_imp_sv); /* just needed for sv_bless */
sv_bless(dbih_imp_rv, imp_mem_stash);
sv_free(dbih_imp_rv);
DBIc_MY_H(imp) = (HV*)SvRV(orv); /* take _copy_ of pointer, not new ref */
DBIc_IMP_DATA(imp) = (imp_datasv) ? newSVsv(imp_datasv) : &PL_sv_undef;
_imp2com(imp, std.pid) = (U32)PerlProc_getpid();
if (DBIc_TYPE(imp) <= DBIt_ST) {
SV **tmp_svp;
/* Copy some attributes from parent if not defined locally and */
/* also take address of attributes for speed of direct access. */
/* parent is null for drh, in which case h must hold the values */
#define COPY_PARENT(name,ro,opt) SvREFCNT_inc(dbih_setup_attrib(aTHX_ h,imp,(name),parent,ro,opt))
#define DBIc_ATTR(imp, f) _imp2com(imp, attr.f)
/* XXX we should validate that these are the right type (refs etc) */
DBIc_ATTR(imp, Err) = COPY_PARENT("Err",1,0); /* scalar ref */
DBIc_ATTR(imp, State) = COPY_PARENT("State",1,0); /* scalar ref */
DBIc_ATTR(imp, Errstr) = COPY_PARENT("Errstr",1,0); /* scalar ref */
DBIc_ATTR(imp, TraceLevel)=COPY_PARENT("TraceLevel",0,0);/* scalar (int)*/
DBIc_ATTR(imp, FetchHashKeyName) = COPY_PARENT("FetchHashKeyName",0,0); /* scalar ref */
if (parent) {
dbih_setup_attrib(aTHX_ h,imp,"HandleSetErr",parent,0,1);
dbih_setup_attrib(aTHX_ h,imp,"HandleError",parent,0,1);
dbih_setup_attrib(aTHX_ h,imp,"ReadOnly",parent,0,1);
dbih_setup_attrib(aTHX_ h,imp,"Profile",parent,0,1);
/* setup Callbacks from parents' ChildCallbacks */
if (DBIc_has(parent_imp, DBIcf_Callbacks)
&& (tmp_svp = hv_fetchs((HV*)SvRV(parent), "Callbacks", 0))
&& SvROK(*tmp_svp) && SvTYPE(SvRV(*tmp_svp)) == SVt_PVHV
&& (tmp_svp = hv_fetchs((HV*)SvRV(*tmp_svp), "ChildCallbacks", 0))
&& SvROK(*tmp_svp) && SvTYPE(SvRV(*tmp_svp)) == SVt_PVHV
) {
/* XXX mirrors behaviour of dbih_set_attr_k() of Callbacks */
(void)hv_stores((HV*)SvRV(h), "Callbacks", newRV_inc(SvRV(*tmp_svp)));
DBIc_set(imp, DBIcf_Callbacks, 1);
}
DBIc_LongReadLen(imp) = DBIc_LongReadLen(parent_imp);
#ifdef sv_rvweaken
if (1) {
AV *av;
/* add weakref to new (outer) handle into parents ChildHandles array */
tmp_svp = hv_fetchs((HV*)SvRV(parent), "ChildHandles", 1);
if (!SvROK(*tmp_svp)) {
SV *ChildHandles_rvav = newRV_noinc((SV*)newAV());
sv_setsv(*tmp_svp, ChildHandles_rvav);
sv_free(ChildHandles_rvav);
}
av = (AV*)SvRV(*tmp_svp);
av_push(av, (SV*)sv_rvweaken(newRV_inc((SV*)SvRV(orv))));
if (av_len(av) % 120 == 0) {
/* time to do some housekeeping to remove dead handles */
I32 i = av_len(av); /* 0 = 1 element */
while (i-- >= 0) {
SV *sv = av_shift(av);
if (SvOK(sv))
av_push(av, sv);
else
sv_free(sv); /* keep it leak-free by Doru Petrescu pdoru.dbi@from.ro */
}
}
}
#endif
}
else {
DBIc_LongReadLen(imp) = DBIc_LongReadLen_init;
}
switch (DBIc_TYPE(imp)) {
case DBIt_DB:
/* cache _inner_ handle, but also see quick_FETCH */
(void)hv_stores((HV*)SvRV(h), "Driver", newRV_inc(SvRV(parent)));
(void)hv_fetchs((HV*)SvRV(h), "Statement", 1); /* store writable undef */
break;
case DBIt_ST:
DBIc_NUM_FIELDS((imp_sth_t*)imp) = -1;
/* cache _inner_ handle, but also see quick_FETCH */
(void)hv_stores((HV*)SvRV(h), "Database", newRV_inc(SvRV(parent)));
/* copy (alias) Statement from the sth up into the dbh */
tmp_svp = hv_fetchs((HV*)SvRV(h), "Statement", 1);
(void)hv_stores((HV*)SvRV(parent), "Statement", SvREFCNT_inc(*tmp_svp));
break;
}
}
else
die("panic: invalid DBIc_TYPE");
/* Use DBI magic on inner handle to carry handle attributes */
/* Note that we store the imp_sv in mg_obj, but as a shortcut, */
/* also store a direct pointer to imp, aka PVX(dbih_imp_sv), */
/* in mg_ptr (with mg_len set to null, so it wont be freed) */
sv_magic(SvRV(h), dbih_imp_sv, DBI_MAGIC, (char*)imp, 0);
SvREFCNT_dec(dbih_imp_sv); /* since sv_magic() incremented it */
SvRMAGICAL_on(SvRV(h)); /* so DBI magic gets sv_clear'd ok */
{
dMY_CXT; /* XXX would be nice to get rid of this */
DBI_SET_LAST_HANDLE(h);
}
if (1) {
/* This is a hack to work-around the fast but poor way old versions of
* DBD::Oracle (and possibly other drivers) check for a valid handle
* using (SvMAGIC(SvRV(h)))->mg_type == 'P'). That doesn't work now
* because the weakref magic is inserted ahead of the tie magic.
* So here we swap the tie and weakref magic so the tie comes first.
*/
MAGIC *tie_mg = mg_find(SvRV(orv),'P');
MAGIC *first = SvMAGIC(SvRV(orv));
if (tie_mg && first->mg_moremagic == tie_mg && !tie_mg->mg_moremagic) {
sv_2iv(sv);
else sv_2uv(sv);
}
else if (grok_flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)
&& uv <= IV_MAX
) {
sv_2iv(sv);
}
else if (grok_flags) { /* is numeric */
sv_2nv(sv);
}
else
cast_ok = 0;
break;
#if 0 /* XXX future possibilities */
case SQL_BIGINT: /* use Math::BigInt if too large for IV/UV */
#endif
}
if (cast_ok) {
if (flags & DBIstcf_DISCARD_STRING
&& SvNIOK(sv) /* we set a numeric value */
&& SvPVX(sv) /* we have a buffer to discard */
) {
SvOOK_off(sv);
sv_force_normal(sv);
if (SvLEN(sv))
Safefree(SvPVX(sv));
SvPOK_off(sv);
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
SvCUR_set(sv, 0);
}
}
if (cast_ok)
return 2;
else if (flags & DBIstcf_STRICT)
return 0;
else return 1;
}
/* --- Generic Handle Attributes (for all handle types) --- */
static int
dbih_set_attr_k(SV *h, SV *keysv, int dbikey, SV *valuesv)
{
dTHX;
dTHR;
D_imp_xxh(h);
STRLEN keylen;
const char *key = SvPV(keysv, keylen);
const int htype = DBIc_TYPE(imp_xxh);
int on = (SvTRUE(valuesv));
int internal = 1; /* DBIh_IN_PERL_DBD(imp_xxh); -- for DBD's in perl */
int cacheit = 0;
int weakenit = 0; /* eg for CachedKids ref */
(void)dbikey;
if (DBIc_TRACE_LEVEL(imp_xxh) >= 3)
PerlIO_printf(DBIc_LOGPIO(imp_xxh)," STORE %s %s => %s\n",
neatsvpv(h,0), neatsvpv(keysv,0), neatsvpv(valuesv,0));
if (internal && strEQ(key, "Active")) {
if (on) {
D_imp_sth(h);
DBIc_ACTIVE_on(imp_xxh);
/* for pure-perl drivers on second and subsequent */
/* execute()'s, else row count keeps rising. */
if (htype==DBIt_ST && DBIc_FIELDS_AV(imp_sth))
DBIc_ROW_COUNT(imp_sth) = 0;
}
else {
DBIc_ACTIVE_off(imp_xxh);
}
}
else if (strEQ(key, "FetchHashKeyName")) {
if (htype >= DBIt_ST)
croak("Can't set FetchHashKeyName for a statement handle, set in parent before prepare()");
cacheit = 1; /* just save it */
}
else if (strEQ(key, "CompatMode")) {
(on) ? DBIc_COMPAT_on(imp_xxh) : DBIc_COMPAT_off(imp_xxh);
}
else if (strEQ(key, "Warn")) {
(on) ? DBIc_WARN_on(imp_xxh) : DBIc_WARN_off(imp_xxh);
}
else if (strEQ(key, "AutoInactiveDestroy")) {
(on) ? DBIc_AIADESTROY_on(imp_xxh) : DBIc_AIADESTROY_off(imp_xxh);
}
else if (strEQ(key, "InactiveDestroy")) {
(on) ? DBIc_IADESTROY_on(imp_xxh) : DBIc_IADESTROY_off(imp_xxh);
}
else if (strEQ(key, "RootClass")) {
cacheit = 1; /* just save it */
}
else if (strEQ(key, "RowCacheSize")) {
cacheit = 0; /* ignore it */
}
else if (strEQ(key, "Executed")) {
DBIc_set(imp_xxh, DBIcf_Executed, on);
}
else if (strEQ(key, "ChopBlanks")) {
DBIc_set(imp_xxh, DBIcf_ChopBlanks, on);
}
else if (strEQ(key, "ErrCount")) {
DBIc_ErrCount(imp_xxh) = SvUV(valuesv);
}
else if (strEQ(key, "LongReadLen")) {
if (SvNV(valuesv) < 0 || SvNV(valuesv) > MAX_LongReadLen)
croak("Can't set LongReadLen < 0 or > %ld",MAX_LongReadLen);
DBIc_LongReadLen(imp_xxh) = SvIV(valuesv);
cacheit = 1; /* save it for clone */
}
else if (strEQ(key, "LongTruncOk")) {
DBIc_set(imp_xxh,DBIcf_LongTruncOk, on);
}
if (on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) ) {
/* not a hash ref so use DBI::Profile to work out what to do */
dTHR;
dSP;
I32 returns;
TAINT_NOT; /* the require is presumed innocent till proven guilty */
require_pv("DBI/Profile.pm");
if (SvTRUE(ERRSV)) {
warn("Can't load %s: %s", profile_class, SvPV_nolen(ERRSV));
valuesv = &PL_sv_undef;
}
else {
PUSHMARK(SP);
mXPUSHs(newSVpv(profile_class, 0));
XPUSHs(valuesv);
PUTBACK;
returns = call_method("_auto_new", G_SCALAR);
if (returns != 1)
croak("%s _auto_new", profile_class);
SPAGAIN;
valuesv = POPs;
PUTBACK;
}
on = SvTRUE(valuesv); /* in case it returns undef */
}
if (on && !sv_isobject(valuesv)) {
/* not blessed already - so default to DBI::Profile */
HV *stash;
require_pv(profile_class);
stash = gv_stashpv(profile_class, GV_ADDWARN);
sv_bless(valuesv, stash);
}
DBIc_set(imp_xxh,DBIcf_Profile, on);
cacheit = 1; /* child copy setup by dbih_setup_handle() */
}
else if (strEQ(key, "ShowErrorStatement")) {
DBIc_set(imp_xxh,DBIcf_ShowErrorStatement, on);
}
else if (strEQ(key, "MultiThread") && internal) {
/* here to allow pure-perl drivers to set MultiThread */
DBIc_set(imp_xxh,DBIcf_MultiThread, on);
if (on && DBIc_WARN(imp_xxh)) {
warn("MultiThread support not yet implemented in DBI");
}
}
else if (strEQ(key, "Taint")) {
/* 'Taint' is a shortcut for both in and out mode */
DBIc_set(imp_xxh,DBIcf_TaintIn|DBIcf_TaintOut, on);
}
else if (strEQ(key, "TaintIn")) {
DBIc_set(imp_xxh,DBIcf_TaintIn, on);
}
else if (strEQ(key, "TaintOut")) {
DBIc_set(imp_xxh,DBIcf_TaintOut, on);
}
else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "CachedKids")
/* only allow hash refs */
&& SvROK(valuesv) && SvTYPE(SvRV(valuesv))==SVt_PVHV
) {
cacheit = 1;
weakenit = 1;
}
else if (keylen==9 && strEQ(key, "Callbacks")) {
if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) )
croak("Can't set Callbacks to '%s'",neatsvpv(valuesv,0));
/* see also dbih_setup_handle for ChildCallbacks handling */
DBIc_set(imp_xxh, DBIcf_Callbacks, on);
cacheit = 1;
}
else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "AutoCommit")) {
/* driver should have intercepted this and either handled it */
/* or set valuesv to either the 'magic' on or off value. */
if (SvIV(valuesv) != -900 && SvIV(valuesv) != -901)
croak("DBD driver has not implemented the AutoCommit attribute");
DBIc_set(imp_xxh,DBIcf_AutoCommit, (SvIV(valuesv)==-901));
}
else if (htype==DBIt_DB && keylen==9 && strEQ(key, "BegunWork")) {
DBIc_set(imp_xxh,DBIcf_BegunWork, on);
}
else if (keylen==10 && strEQ(key, "TraceLevel")) {
set_trace(h, valuesv, Nullsv);
}
else if (keylen==9 && strEQ(key, "TraceFile")) { /* XXX undocumented and readonly */
set_trace_file(valuesv);
}
else if (htype==DBIt_ST && strEQ(key, "NUM_OF_FIELDS")) {
D_imp_sth(h);
int new_num_fields = (SvOK(valuesv)) ? SvIV(valuesv) : -1;
DBIc_NUM_FIELDS(imp_sth) = new_num_fields;
if (DBIc_FIELDS_AV(imp_sth)) { /* modify existing fbav */
dbih_setup_fbav(imp_sth);
}
cacheit = 1;
}
else if (htype==DBIt_ST && strEQ(key, "NUM_OF_PARAMS")) {
D_imp_sth(h);
DBIc_NUM_PARAMS(imp_sth) = SvIV(valuesv);
cacheit = 1;
}
/* these are here due to clone() needing to set attribs through a public api */
else if (htype<=DBIt_DB && (strEQ(key, "Name")
|| strEQ(key,"ImplementorClass")
|| strEQ(key,"ReadOnly")
|| strEQ(key,"Statement")
|| strEQ(key,"Username")
/* these are here for backwards histerical raisons */
|| strEQ(key,"USER") || strEQ(key,"CURRENT_USER")
) ) {
cacheit = 1;
}
/* deal with: NAME_(uc|lc), NAME_hash, NAME_(uc|lc)_hash */
else if ((keylen==7 || keylen==9 || keylen==12)
&& strnEQ(key, "NAME_", 5)
&& ( (keylen==9 && strEQ(key, "NAME_hash"))
|| ((key[5]=='u' || key[5]=='l') && key[6] == 'c'
&& (!key[7] || strnEQ(&key[7], "_hash", 5)))
)
) {
cacheit = 1;
}
else { /* XXX should really be an event ? */
if (isUPPER(*key)) {
char *msg = "Can't set %s->{%s}: unrecognised attribute name or invalid value%s";
char *hint = "";
if (strEQ(key, "NUM_FIELDS"))
hint = ", perhaps you meant NUM_OF_FIELDS";
warn(msg, neatsvpv(h,0), key, hint);
return FALSE; /* don't store it */
}
/* Allow private_* attributes to be stored in the cache. */
/* This is designed to make life easier for people subclassing */
/* the DBI classes and may be of use to simple perl DBD's. */
if (strnNE(key,"private_",8) && strnNE(key,"dbd_",4) && strnNE(key,"dbi_",4)) {
if (DBIc_TRACE_LEVEL(imp_xxh)) { /* change to DBIc_WARN(imp_xxh) once we can validate prefix against registry */
PerlIO_printf(DBIc_LOGPIO(imp_xxh),"$h->{%s}=%s ignored for invalid driver-specific attribute\n",
neatsvpv(keysv,0), neatsvpv(valuesv,0));
}
return FALSE;
}
cacheit = 1;
}
if (cacheit) {
SV *sv_for_cache = newSVsv(valuesv);
(void)hv_store((HV*)SvRV(h), key, keylen, sv_for_cache, 0);
if (weakenit) {
#ifdef sv_rvweaken
sv_rvweaken(sv_for_cache);
#endif
}
}
return TRUE;
}
static SV *
dbih_get_attr_k(SV *h, SV *keysv, int dbikey)
{
dTHX;
dTHR;
D_imp_xxh(h);
STRLEN keylen;
char *key = SvPV(keysv, keylen);
int htype = DBIc_TYPE(imp_xxh);
SV *valuesv = Nullsv;
int cacheit = FALSE;
char *p;
int i;
SV *sv;
SV **svp;
(void)dbikey;
/* DBI quick_FETCH will service some requests (e.g., cached values) */
if (htype == DBIt_ST) {
switch (*key) {
case 'D':
if (keylen==8 && strEQ(key, "Database")) {
D_imp_from_child(imp_dbh, imp_dbh_t, imp_xxh);
valuesv = newRV_inc((SV*)DBIc_MY_H(imp_dbh));
cacheit = FALSE; /* else creates ref loop */
}
break;
case 'N':
if (keylen==8 && strEQ(key, "NULLABLE")) {
valuesv = &PL_sv_undef;
break;
}
if (keylen==4 && strEQ(key, "NAME")) {
valuesv = &PL_sv_undef;
break;
}
/* deal with: NAME_(uc|lc), NAME_hash, NAME_(uc|lc)_hash */
if ((keylen==7 || keylen==9 || keylen==12)
&& strnEQ(key, "NAME_", 5)
&& ( (keylen==9 && strEQ(key, "NAME_hash"))
|| ((key[5]=='u' || key[5]=='l') && key[6] == 'c'
&& (!key[7] || strnEQ(&key[7], "_hash", 5)))
)
) {
D_imp_sth(h);
valuesv = &PL_sv_undef;
/* fetch from tied outer handle to trigger FETCH magic */
case 'S':
if (strEQ(key, "SCALE"))
valuesv = &PL_sv_undef;
break;
case 'T':
if (strEQ(key, "TYPE"))
valuesv = &PL_sv_undef;
break;
}
}
else
if (htype == DBIt_DB) {
/* this is here but is, sadly, not called because
* not-preloading them into the handle attrib cache caused
* wierdness in t/proxy.t that I never got to the bottom
* of. One day maybe. */
if (keylen==6 && strEQ(key, "Driver")) {
D_imp_from_child(imp_dbh, imp_dbh_t, imp_xxh);
valuesv = newRV_inc((SV*)DBIc_MY_H(imp_dbh));
cacheit = FALSE; /* else creates ref loop */
}
}
if (valuesv == Nullsv && htype <= DBIt_DB) {
if (keylen==10 && strEQ(key, "AutoCommit")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_AutoCommit));
}
}
if (valuesv == Nullsv) {
switch (*key) {
case 'A':
if (keylen==6 && strEQ(key, "Active")) {
valuesv = boolSV(DBIc_ACTIVE(imp_xxh));
}
else if (keylen==10 && strEQ(key, "ActiveKids")) {
valuesv = newSViv(DBIc_ACTIVE_KIDS(imp_xxh));
}
else if (strEQ(key, "AutoInactiveDestroy")) {
valuesv = boolSV(DBIc_AIADESTROY(imp_xxh));
}
break;
case 'B':
if (keylen==9 && strEQ(key, "BegunWork")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_BegunWork));
}
break;
case 'C':
if (strEQ(key, "ChildHandles")) {
svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE);
/* if something has been stored then return it.
* otherwise return a dummy empty array if weakrefs are
* available, else an undef to indicate that they're not */
if (svp) {
valuesv = newSVsv(*svp);
} else {
#ifdef sv_rvweaken
valuesv = newRV_noinc((SV*)newAV());
#else
valuesv = &PL_sv_undef;
#endif
}
}
else if (strEQ(key, "ChopBlanks")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_ChopBlanks));
}
else if (strEQ(key, "CachedKids")) {
valuesv = &PL_sv_undef;
}
else if (strEQ(key, "CompatMode")) {
valuesv = boolSV(DBIc_COMPAT(imp_xxh));
}
break;
case 'E':
if (strEQ(key, "Executed")) {
valuesv = boolSV(DBIc_is(imp_xxh, DBIcf_Executed));
}
else if (strEQ(key, "ErrCount")) {
valuesv = newSVuv(DBIc_ErrCount(imp_xxh));
}
break;
case 'I':
if (strEQ(key, "InactiveDestroy")) {
valuesv = boolSV(DBIc_IADESTROY(imp_xxh));
}
break;
case 'K':
if (keylen==4 && strEQ(key, "Kids")) {
valuesv = newSViv(DBIc_KIDS(imp_xxh));
}
break;
case 'L':
if (keylen==11 && strEQ(key, "LongReadLen")) {
valuesv = newSVnv((NV)DBIc_LongReadLen(imp_xxh));
}
else if (keylen==11 && strEQ(key, "LongTruncOk")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_LongTruncOk));
}
break;
case 'M':
if (keylen==10 && strEQ(key, "MultiThread")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_MultiThread));
}
break;
case 'P':
if (keylen==10 && strEQ(key, "PrintError")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_PrintError));
}
else if (keylen==9 && strEQ(key, "PrintWarn")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_PrintWarn));
}
( run in 0.712 second using v1.01-cache-2.11-cpan-a49fcb8fa48 )