diff options
Diffstat (limited to 'DBI.xs')
-rw-r--r-- | DBI.xs | 5560 |
1 files changed, 5560 insertions, 0 deletions
@@ -0,0 +1,5560 @@ +/* vim: ts=8:sw=4:expandtab + * + * $Id: DBI.xs 15304 2012-05-14 08:17:22Z mjevans $ + * + * Copyright (c) 1994-2012 Tim Bunce Ireland. + * + * See COPYRIGHT section in DBI.pm for usage and distribution rights. + */ +#define NEED_grok_number +#define NEED_grok_numeric_radix +#define NEED_newRV_noinc +#define NEED_sv_2pv_flags + +#define IN_DBI_XS 1 /* see DBIXS.h */ +#define PERL_NO_GET_CONTEXT + +#include "DBIXS.h" /* DBI public interface for DBD's written in C */ + +# if (defined(_WIN32) && (! defined(HAS_GETTIMEOFDAY))) +#include <sys/timeb.h> +# endif + +/* The XS dispatcher code can optimize calls to XS driver methods, + * bypassing the usual call_sv() and argument handling overheads. + * Just-in-case it causes problems there's an (undocumented) way + * to disable it by setting an env var. + */ +static int use_xsbypass = 1; /* set in dbi_bootinit() */ + +#ifndef CvISXSUB +#define CvISXSUB(sv) CvXSUB(sv) +#endif + +#define DBI_MAGIC '~' + +/* HvMROMETA introduced in 5.9.5, but mro_meta_init not exported in 5.10.0 */ +#if (PERL_VERSION < 10) +# define MY_cache_gen(stash) 0 +#else +# if ((PERL_VERSION == 10) && (PERL_SUBVERSION == 0)) +# define MY_cache_gen(stash) \ + (HvAUX(stash)->xhv_mro_meta \ + ? HvAUX(stash)->xhv_mro_meta->cache_gen \ + : 0) +# else +# define MY_cache_gen(stash) HvMROMETA(stash)->cache_gen +# endif +#endif + +/* If the tests fail with errors about 'setlinebuf' then try */ +/* deleting the lines in the block below except the setvbuf one */ +#ifndef PerlIO_setlinebuf +#ifdef HAS_SETLINEBUF +#define PerlIO_setlinebuf(f) setlinebuf(f) +#else +#ifndef USE_PERLIO +#define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0) +#endif +#endif +#endif + +#ifndef CopFILEGV +# define CopFILEGV(cop) cop->cop_filegv +# define CopLINE(cop) cop->cop_line +# define CopSTASH(cop) cop->cop_stash +# define CopSTASHPV(cop) (CopSTASH(cop) ? HvNAME(CopSTASH(cop)) : Nullch) +#endif +#ifndef PERL_GET_THX +#define PERL_GET_THX ((void*)0) +#endif +#ifndef PerlProc_getpid +#define PerlProc_getpid() getpid() +extern Pid_t getpid (void); +#endif +#ifndef aTHXo_ +#define aTHXo_ +#endif + +#if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION == 0)) +#define DBI_save_hv_fetch_ent +#endif + +/* prior to 5.8.9: when a CV is duped, the mg dup method is called, + * then *afterwards*, any_ptr is copied from the old CV to the new CV. + * This wipes out anything which the dup method did to any_ptr. + * This needs working around */ +#if defined(USE_ITHREADS) && (PERL_VERSION == 8) && (PERL_SUBVERSION < 9) +# define BROKEN_DUP_ANY_PTR +#endif + +/* types of method name */ + +typedef enum { + methtype_ordinary, /* nothing special about this method name */ + methtype_DESTROY, + methtype_FETCH, + methtype_can, + methtype_fetch_star, /* fetch*, i.e. fetch() or fetch_...() */ + methtype_set_err +} meth_types; + + +static imp_xxh_t *dbih_getcom _((SV *h)); +static imp_xxh_t *dbih_getcom2 _((pTHX_ SV *h, MAGIC **mgp)); +static void dbih_clearcom _((imp_xxh_t *imp_xxh)); +static int dbih_logmsg _((imp_xxh_t *imp_xxh, const char *fmt, ...)); +static SV *dbih_make_com _((SV *parent_h, imp_xxh_t *p_imp_xxh, const char *imp_class, STRLEN imp_size, STRLEN extra, SV *copy)); +static SV *dbih_make_fdsv _((SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name)); +static AV *dbih_get_fbav _((imp_sth_t *imp_sth)); +static SV *dbih_event _((SV *h, const char *name, SV*, SV*)); +static int dbih_set_attr_k _((SV *h, SV *keysv, int dbikey, SV *valuesv)); +static SV *dbih_get_attr_k _((SV *h, SV *keysv, int dbikey)); +static int dbih_sth_bind_col _((SV *sth, SV *col, SV *ref, SV *attribs)); + +static int set_err_char _((SV *h, imp_xxh_t *imp_xxh, const char *err_c, IV err_i, const char *errstr, const char *state, const char *method)); +static int set_err_sv _((SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method)); +static int quote_type _((int sql_type, int p, int s, int *base_type, void *v)); +static int sql_type_cast_svpv _((pTHX_ SV *sv, int sql_type, U32 flags, void *v)); +static I32 dbi_hash _((const char *string, long i)); +static void dbih_dumphandle _((pTHX_ SV *h, const char *msg, int level)); +static int dbih_dumpcom _((pTHX_ imp_xxh_t *imp_xxh, const char *msg, int level)); +static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg); +#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR) +static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param); +#endif +char *neatsvpv _((SV *sv, STRLEN maxlen)); +SV * preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void *foo); +static meth_types get_meth_type(const char * const name); + +struct imp_drh_st { dbih_drc_t com; }; +struct imp_dbh_st { dbih_dbc_t com; }; +struct imp_sth_st { dbih_stc_t com; }; +struct imp_fdh_st { dbih_fdc_t com; }; + +/* identify the type of a method name for dispatch behaviour */ +/* (should probably be folded into the IMA flags mechanism) */ + +static meth_types +get_meth_type(const char * const name) +{ + switch (name[0]) { + case 'D': + if strEQ(name,"DESTROY") + return methtype_DESTROY; + break; + case 'F': + if strEQ(name,"FETCH") + return methtype_FETCH; + break; + case 'c': + if strEQ(name,"can") + return methtype_can; + break; + case 'f': + if strnEQ(name,"fetch", 5) /* fetch* */ + return methtype_fetch_star; + break; + case 's': + if strEQ(name,"set_err") + return methtype_set_err; + break; + } + return methtype_ordinary; +} + + +/* Internal Method Attributes (attached to dispatch methods when installed) */ +/* NOTE: when adding SVs to dbi_ima_t, update dbi_ima_dup() dbi_ima_free() + * to ensure that they are duped and correctly ref-counted */ + +typedef struct dbi_ima_st { + U8 minargs; + U8 maxargs; + IV hidearg; + /* method_trace controls tracing of method calls in the dispatcher: + - if the current trace flags include a trace flag in method_trace + then set trace_level to min(2,trace_level) for duration of the call. + - else, if trace_level < (method_trace & DBIc_TRACE_LEVEL_MASK) + then don't trace the call + */ + U32 method_trace; + const char *usage_msg; + U32 flags; + meth_types meth_type; + + /* cached outer to inner method mapping */ + HV *stash; /* the stash we found the GV in */ + GV *gv; /* the GV containing the inner sub */ + U32 generation; /* cache invalidation */ +#ifdef BROKEN_DUP_ANY_PTR + PerlInterpreter *my_perl; /* who owns this struct */ +#endif + +} dbi_ima_t; + +/* These values are embedded in the data passed to install_method */ +#define IMA_HAS_USAGE 0x00000001 /* check parameter usage */ +#define IMA_FUNC_REDIRECT 0x00000002 /* is $h->func(..., "method") */ +#define IMA_KEEP_ERR 0x00000004 /* don't reset err & errstr */ +#define IMA_KEEP_ERR_SUB 0x00000008 /* '' if in a nested call */ +#define IMA_NO_TAINT_IN 0x00000010 /* don't check for tainted args */ +#define IMA_NO_TAINT_OUT 0x00000020 /* don't taint results */ +#define IMA_COPY_UP_STMT 0x00000040 /* copy sth Statement to dbh */ +#define IMA_END_WORK 0x00000080 /* method is commit or rollback */ +#define IMA_STUB 0x00000100 /* donothing eg $dbh->connected */ +#define IMA_CLEAR_STMT 0x00000200 /* clear Statement before call */ +#define IMA_UNRELATED_TO_STMT 0x00000400 /* profile as empty Statement */ +#define IMA_NOT_FOUND_OKAY 0x00000800 /* no error if not found */ +#define IMA_EXECUTE 0x00001000 /* do/execute: DBIcf_Executed */ +#define IMA_SHOW_ERR_STMT 0x00002000 /* dbh meth relates to Statement*/ +#define IMA_HIDE_ERR_PARAMVALUES 0x00004000 /* ParamValues are not relevant */ +#define IMA_IS_FACTORY 0x00008000 /* new h ie connect and prepare */ +#define IMA_CLEAR_CACHED_KIDS 0x00010000 /* clear CachedKids before call */ + +#define DBIc_STATE_adjust(imp_xxh, state) \ + (SvOK(state) /* SQLSTATE is implemented by driver */ \ + ? (strEQ(SvPV_nolen(state),"00000") ? &PL_sv_no : sv_mortalcopy(state))\ + : (SvTRUE(DBIc_ERR(imp_xxh)) \ + ? sv_2mortal(newSVpv("S1000",5)) /* General error */ \ + : &PL_sv_no) /* Success ("00000") */ \ + ) + +#define DBI_LAST_HANDLE g_dbi_last_h /* special fake inner handle */ +#define DBI_IS_LAST_HANDLE(h) ((DBI_LAST_HANDLE) == SvRV(h)) +#define DBI_SET_LAST_HANDLE(h) ((DBI_LAST_HANDLE) = SvRV(h)) +#define DBI_UNSET_LAST_HANDLE ((DBI_LAST_HANDLE) = &PL_sv_undef) +#define DBI_LAST_HANDLE_OK ((DBI_LAST_HANDLE) != &PL_sv_undef) + +#define DBIS_TRACE_LEVEL (DBIS->debug & DBIc_TRACE_LEVEL_MASK) +#define DBIS_TRACE_FLAGS (DBIS->debug) /* includes level */ + +#ifdef PERL_LONG_MAX +#define MAX_LongReadLen PERL_LONG_MAX +#else +#define MAX_LongReadLen 2147483647L +#endif + +#ifdef DBI_USE_THREADS +static char *dbi_build_opt = "-ithread"; +#else +static char *dbi_build_opt = "-nothread"; +#endif + +/* 32 bit magic FNV-0 and FNV-1 prime */ +#define FNV_32_PRIME ((UV)0x01000193) + + +/* perl doesn't know anything about the dbi_ima_t struct attached to the + * CvXSUBANY(cv).any_ptr slot, so add some magic to the CV to handle + * duping and freeing. + */ + +static MGVTBL dbi_ima_vtbl = { 0, 0, 0, 0, dbi_ima_free, + 0, +#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR) + dbi_ima_dup +#else + 0 +#endif +#if (PERL_VERSION > 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION >= 9)) + , 0 +#endif + }; + +static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg) +{ + dbi_ima_t *ima = (dbi_ima_t *)(CvXSUBANY((CV*)sv).any_ptr); +#ifdef BROKEN_DUP_ANY_PTR + if (ima->my_perl != my_perl) + return 0; +#endif + SvREFCNT_dec(ima->stash); + SvREFCNT_dec(ima->gv); + Safefree(ima); + return 0; +} + +#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR) +static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param) +{ + dbi_ima_t *ima, *nima; + CV *cv = (CV*) mg->mg_ptr; + CV *ncv = (CV*)ptr_table_fetch(PL_ptr_table, (cv)); + + (void)param; /* avoid 'unused variable' warning */ + mg->mg_ptr = (char *)ncv; + ima = (dbi_ima_t*) CvXSUBANY(cv).any_ptr; + Newx(nima, 1, dbi_ima_t); + *nima = *ima; /* structure copy */ + CvXSUBANY(ncv).any_ptr = nima; + nima->stash = NULL; + nima->gv = NULL; + return 0; +} +#endif + + + +/* --- make DBI safe for multiple perl interpreters --- */ +/* Originally contributed by Murray Nesbitt of ActiveState, */ +/* but later updated to use MY_CTX */ + +#define MY_CXT_KEY "DBI::_guts" XS_VERSION + +typedef struct { + SV *dbi_last_h; /* maybe better moved into dbistate_t? */ + dbistate_t* dbi_state; +} my_cxt_t; + +START_MY_CXT + +#undef DBIS +#define DBIS (MY_CXT.dbi_state) + +#define g_dbi_last_h (MY_CXT.dbi_last_h) + +/* allow the 'static' dbi_state struct to be accessed from other files */ +dbistate_t** +_dbi_state_lval(pTHX) +{ + dMY_CXT; + return &(MY_CXT.dbi_state); +} + + +/* --- */ + +static void * +malloc_using_sv(STRLEN len) +{ + dTHX; + SV *sv = newSV(len); + void *p = SvPVX(sv); + memzero(p, len); + return p; +} + +static char * +savepv_using_sv(char *str) +{ + char *buf = malloc_using_sv(strlen(str)); + strcpy(buf, str); + return buf; +} + + +/* --- support functions for concat_hash_sorted --- */ + +typedef struct str_uv_sort_pair_st { + char *key; + UV numeric; +} str_uv_sort_pair_t; + +static int +_cmp_number(const void *val1, const void *val2) +{ + UV first = ((str_uv_sort_pair_t *)val1)->numeric; + UV second = ((str_uv_sort_pair_t *)val2)->numeric; + + if (first > second) + return 1; + if (first < second) + return -1; + /* only likely to reach here if numeric sort forced for non-numeric keys */ + /* fallback to comparing the key strings */ + return strcmp( + ((str_uv_sort_pair_t *)val1)->key, + ((str_uv_sort_pair_t *)val2)->key + ); +} + +static int +_cmp_str (const void *val1, const void *val2) +{ + return strcmp( *(char **)val1, *(char **)val2); +} + +static char ** +_sort_hash_keys (HV *hash, int num_sort, STRLEN *total_length) +{ + dTHX; + I32 hv_len, key_len; + HE *entry; + char **keys; + unsigned int idx = 0; + STRLEN tot_len = 0; + bool has_non_numerics = 0; + str_uv_sort_pair_t *numbers; + + hv_len = hv_iterinit(hash); + if (!hv_len) + return 0; + + Newz(0, keys, hv_len, char *); + Newz(0, numbers, hv_len, str_uv_sort_pair_t); + + while ((entry = hv_iternext(hash))) { + *(keys+idx) = hv_iterkey(entry, &key_len); + tot_len += key_len; + + if (grok_number(*(keys+idx), key_len, &(numbers+idx)->numeric) != IS_NUMBER_IN_UV) { + has_non_numerics = 1; + (numbers+idx)->numeric = 0; + } + + (numbers+idx)->key = *(keys+idx); + ++idx; + } + + if (total_length) + *total_length = tot_len; + + if (num_sort < 0) + num_sort = (has_non_numerics) ? 0 : 1; + + if (!num_sort) { + qsort(keys, hv_len, sizeof(char*), _cmp_str); + } + else { + qsort(numbers, hv_len, sizeof(str_uv_sort_pair_t), _cmp_number); + for (idx = 0; idx < hv_len; ++idx) + *(keys+idx) = (numbers+idx)->key; + } + + Safefree(numbers); + return keys; +} + + +static SV * +_join_hash_sorted(HV *hash, char *kv_sep, STRLEN kv_sep_len, char *pair_sep, STRLEN pair_sep_len, int use_neat, int num_sort) +{ + dTHX; + I32 hv_len; + STRLEN total_len = 0; + char **keys; + unsigned int i = 0; + SV *return_sv; + + keys = _sort_hash_keys(hash, num_sort, &total_len); + if (!keys) + return newSVpv("", 0); + + if (!kv_sep_len) + kv_sep_len = strlen(kv_sep); + if (!pair_sep_len) + pair_sep_len = strlen(pair_sep); + + hv_len = hv_iterinit(hash); + /* total_len += Separators + quotes + term null */ + total_len += kv_sep_len*hv_len + pair_sep_len*hv_len+2*hv_len+1; + return_sv = newSV(total_len); + sv_setpv(return_sv, ""); /* quell undef warnings */ + + for (i=0; i<hv_len; ++i) { + SV **hash_svp = hv_fetch(hash, keys[i], strlen(keys[i]), 0); + + sv_catpv(return_sv, keys[i]); /* XXX keys can't contain nul chars */ + sv_catpvn(return_sv, kv_sep, kv_sep_len); + + if (!hash_svp) { /* should never happen */ + warn("No hash entry with key '%s'", keys[i]); + sv_catpvn(return_sv, "???", 3); + continue; + } + + if (use_neat) { + sv_catpv(return_sv, neatsvpv(*hash_svp,0)); + } + else { + if (SvOK(*hash_svp)) { + STRLEN hv_val_len; + char *hv_val = SvPV(*hash_svp, hv_val_len); + sv_catpvn(return_sv, "'", 1); + sv_catpvn(return_sv, hv_val, hv_val_len); + sv_catpvn(return_sv, "'", 1); + } + else sv_catpvn(return_sv, "undef", 5); + } + + if (i < hv_len-1) + sv_catpvn(return_sv, pair_sep, pair_sep_len); + } + + Safefree(keys); + + return return_sv; +} + + + +/* handy for embedding into condition expression for debugging */ +/* +static int warn1(char *s) { warn(s); return 1; } +static int dump1(SV *sv) { dTHX; sv_dump(sv); return 1; } +*/ + + +/* --- */ + +static void +check_version(const char *name, int dbis_cv, int dbis_cs, int need_dbixs_cv, int drc_s, + int dbc_s, int stc_s, int fdc_s) +{ + dTHX; + dMY_CXT; + static const char msg[] = "you probably need to rebuild the DBD driver (or possibly the DBI)"; + (void)need_dbixs_cv; + if (dbis_cv != DBISTATE_VERSION || dbis_cs != sizeof(*DBIS)) + croak("DBI/DBD internal version mismatch (DBI is v%d/s%lu, DBD %s expected v%d/s%d) %s.\n", + DBISTATE_VERSION, (long unsigned int)sizeof(*DBIS), name, dbis_cv, dbis_cs, msg); + /* Catch structure size changes - We should probably force a recompile if the DBI */ + /* runtime version is different from the build time. That would be harsh but safe. */ + if (drc_s != sizeof(dbih_drc_t) || dbc_s != sizeof(dbih_dbc_t) || + stc_s != sizeof(dbih_stc_t) || fdc_s != sizeof(dbih_fdc_t) ) + croak("%s (dr:%d/%ld, db:%d/%ld, st:%d/%ld, fd:%d/%ld), %s.\n", + "DBI/DBD internal structure mismatch", + drc_s, (long)sizeof(dbih_drc_t), dbc_s, (long)sizeof(dbih_dbc_t), + stc_s, (long)sizeof(dbih_stc_t), fdc_s, (long)sizeof(dbih_fdc_t), msg); +} + +static void +dbi_bootinit(dbistate_t * parent_dbis) +{ + dTHX; + dMY_CXT; + dbistate_t* DBISx; + + DBISx = (struct dbistate_st*)malloc_using_sv(sizeof(struct dbistate_st)); + DBIS = DBISx; + + /* make DBIS available to DBD modules the "old" (<= 1.618) way, + * so that unrecompiled DBD's will still work against a newer DBI */ + sv_setiv(get_sv("DBI::_dbistate", GV_ADDMULTI), + PTR2IV(MY_CXT.dbi_state)); + + /* store version and size so we can spot DBI/DBD version mismatch */ + DBIS->check_version = check_version; + DBIS->version = DBISTATE_VERSION; + DBIS->size = sizeof(*DBIS); + DBIS->xs_version = DBIXS_VERSION; + + DBIS->logmsg = dbih_logmsg; + DBIS->logfp = PerlIO_stderr(); + DBIS->debug = (parent_dbis) ? parent_dbis->debug + : SvIV(get_sv("DBI::dbi_debug",0x5)); + DBIS->neatsvpvlen = (parent_dbis) ? parent_dbis->neatsvpvlen + : get_sv("DBI::neat_maxlen", GV_ADDMULTI); +#ifdef DBI_USE_THREADS + DBIS->thr_owner = PERL_GET_THX; +#endif + + /* store some function pointers so DBD's can call our functions */ + DBIS->getcom = dbih_getcom; + DBIS->clearcom = dbih_clearcom; + DBIS->event = dbih_event; + DBIS->set_attr_k = dbih_set_attr_k; + DBIS->get_attr_k = dbih_get_attr_k; + DBIS->get_fbav = dbih_get_fbav; + DBIS->make_fdsv = dbih_make_fdsv; + DBIS->neat_svpv = neatsvpv; + DBIS->bind_as_num = quote_type; /* XXX deprecated */ + DBIS->hash = dbi_hash; + DBIS->set_err_sv = set_err_sv; + DBIS->set_err_char= set_err_char; + DBIS->bind_col = dbih_sth_bind_col; + DBIS->sql_type_cast_svpv = sql_type_cast_svpv; + + + /* Remember the last handle used. BEWARE! Sneaky stuff here! */ + /* We want a handle reference but we don't want to increment */ + /* the handle's reference count and we don't want perl to try */ + /* to destroy it during global destruction. Take care! */ + DBI_UNSET_LAST_HANDLE; /* ensure setup the correct way */ + + /* trick to avoid 'possible typo' warnings */ + gv_fetchpv("DBI::state", GV_ADDMULTI, SVt_PV); + gv_fetchpv("DBI::err", GV_ADDMULTI, SVt_PV); + gv_fetchpv("DBI::errstr", GV_ADDMULTI, SVt_PV); + gv_fetchpv("DBI::lasth", GV_ADDMULTI, SVt_PV); + gv_fetchpv("DBI::rows", GV_ADDMULTI, SVt_PV); + + /* we only need to check the env var on the initial boot + * which is handy because it can core dump during CLONE on windows + */ + if (!parent_dbis && getenv("PERL_DBI_XSBYPASS")) + use_xsbypass = atoi(getenv("PERL_DBI_XSBYPASS")); +} + + +/* ----------------------------------------------------------------- */ +/* Utility functions */ + + +static char * +dbih_htype_name(int htype) +{ + switch(htype) { + case DBIt_DR: return "dr"; + case DBIt_DB: return "db"; + case DBIt_ST: return "st"; + case DBIt_FD: return "fd"; + default: return "??"; + } +} + + +char * +neatsvpv(SV *sv, STRLEN maxlen) /* return a tidy ascii value, for debugging only */ +{ + dTHX; + dMY_CXT; + STRLEN len; + SV *nsv = Nullsv; + SV *infosv = Nullsv; + char *v, *quote; + + /* We take care not to alter the supplied sv in any way at all. */ + /* (but if it is SvGMAGICAL we have to call mg_get and that can */ + /* have side effects, especially as it may be called twice overall.) */ + + if (!sv) + return "Null!"; /* should never happen */ + + /* try to do the right thing with magical values */ + if (SvMAGICAL(sv)) { + if (DBIS_TRACE_LEVEL >= 5) { /* add magic details to help debugging */ + MAGIC* mg; + infosv = sv_2mortal(newSVpv(" (magic-",0)); + if (SvSMAGICAL(sv)) sv_catpvn(infosv,"s",1); + if (SvGMAGICAL(sv)) sv_catpvn(infosv,"g",1); + if (SvRMAGICAL(sv)) sv_catpvn(infosv,"r",1); + sv_catpvn(infosv,":",1); + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) + sv_catpvn(infosv, &mg->mg_type, 1); + sv_catpvn(infosv, ")", 1); + } + if (SvGMAGICAL(sv)) + mg_get(sv); /* trigger magic to FETCH the value */ + } + + if (!SvOK(sv)) { + if (SvTYPE(sv) >= SVt_PVAV) + return (char *)sv_reftype(sv,0); /* raw AV/HV etc, not via a ref */ + if (!infosv) + return "undef"; + sv_insert(infosv, 0,0, "undef",5); + return SvPVX(infosv); + } + + if (SvNIOK(sv)) { /* is a numeric value - so no surrounding quotes */ + if (SvPOK(sv)) { /* already has string version of the value, so use it */ + v = SvPV(sv,len); + if (len == 0) { v="''"; len=2; } /* catch &sv_no style special case */ + if (!infosv) + return v; + sv_insert(infosv, 0,0, v, len); + return SvPVX(infosv); + } + /* we don't use SvPV here since we don't want to alter sv in _any_ way */ + if (SvUOK(sv)) + nsv = newSVpvf("%"UVuf, SvUVX(sv)); + else if (SvIOK(sv)) + nsv = newSVpvf("%"IVdf, SvIVX(sv)); + else nsv = newSVpvf("%"NVgf, SvNVX(sv)); + if (infosv) + sv_catsv(nsv, infosv); + return SvPVX(sv_2mortal(nsv)); + } + + nsv = sv_newmortal(); + sv_upgrade(nsv, SVt_PV); + + if (SvROK(sv)) { + if (!SvAMAGIC(sv)) /* (un-amagic'd) refs get no special treatment */ + v = SvPV(sv,len); + else { + /* handle Overload magic refs */ + (void)SvAMAGIC_off(sv); /* should really be done via local scoping */ + v = SvPV(sv,len); /* XXX how does this relate to SvGMAGIC? */ + SvAMAGIC_on(sv); + } + sv_setpvn(nsv, v, len); + if (infosv) + sv_catsv(nsv, infosv); + return SvPV(nsv, len); + } + + if (SvPOK(sv)) /* usual simple string case */ + v = SvPV(sv,len); + else /* handles all else via sv_2pv() */ + v = SvPV(sv,len); /* XXX how does this relate to SvGMAGIC? */ + + /* for strings we limit the length and translate codes */ + if (maxlen == 0) + maxlen = SvIV(DBIS->neatsvpvlen); + if (maxlen < 6) /* handle daft values */ + maxlen = 6; + maxlen -= 2; /* account for quotes */ + + quote = (SvUTF8(sv)) ? "\"" : "'"; + if (len > maxlen) { + SvGROW(nsv, (1+maxlen+1+1)); + sv_setpvn(nsv, quote, 1); + sv_catpvn(nsv, v, maxlen-3); /* account for three dots */ + sv_catpvn(nsv, "...", 3); + } else { + SvGROW(nsv, (1+len+1+1)); + sv_setpvn(nsv, quote, 1); + sv_catpvn(nsv, v, len); + } + sv_catpvn(nsv, quote, 1); + if (infosv) + sv_catsv(nsv, infosv); + v = SvPV(nsv, len); + if (!SvUTF8(sv)) { + while(len-- > 0) { /* cleanup string (map control chars to ascii etc) */ + const char c = v[len] & 0x7F; /* ignore top bit for multinational chars */ + if (!isPRINT(c) && !isSPACE(c)) + v[len] = '.'; + } + } + return v; +} + + +static int +set_err_char(SV *h, imp_xxh_t *imp_xxh, const char *err_c, IV err_i, const char *errstr, const char *state, const char *method) +{ + dTHX; + char err_buf[28]; + SV *err_sv, *errstr_sv, *state_sv, *method_sv; + if (!err_c) { + sprintf(err_buf, "%ld", (long)err_i); + err_c = &err_buf[0]; + } + err_sv = (strEQ(err_c,"1")) ? &PL_sv_yes : sv_2mortal(newSVpvn(err_c, strlen(err_c))); + errstr_sv = sv_2mortal(newSVpvn(errstr, strlen(errstr))); + state_sv = (state && *state) ? sv_2mortal(newSVpvn(state, strlen(state))) : &PL_sv_undef; + method_sv = (method && *method) ? sv_2mortal(newSVpvn(method, strlen(method))) : &PL_sv_undef; + return set_err_sv(h, imp_xxh, err_sv, errstr_sv, state_sv, method_sv); +} + +static int +set_err_sv(SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method) +{ + dTHX; + SV *h_err; + SV *h_errstr; + SV *h_state; + SV **hook_svp; + int err_changed = 0; + + if ( DBIc_has(imp_xxh, DBIcf_HandleSetErr) + && (hook_svp = hv_fetch((HV*)SvRV(h),"HandleSetErr",12,0)) + && hook_svp + && ((void)(SvGMAGICAL(*hook_svp) && mg_get(*hook_svp)), SvOK(*hook_svp)) + ) { + dSP; + IV items; + SV *response_sv; + if (SvREADONLY(err)) err = sv_mortalcopy(err); + if (SvREADONLY(errstr)) errstr = sv_mortalcopy(errstr); + if (SvREADONLY(state)) state = sv_mortalcopy(state); + if (SvREADONLY(method)) method = sv_mortalcopy(method); + if (DBIc_TRACE_LEVEL(imp_xxh) >= 2) + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," -> HandleSetErr(%s, err=%s, errstr=%s, state=%s, %s)\n", + neatsvpv(h,0), neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0), + neatsvpv(method,0) + ); + PUSHMARK(SP); + XPUSHs(sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh)))); + XPUSHs(err); + XPUSHs(errstr); + XPUSHs(state); + XPUSHs(method); + PUTBACK; + items = call_sv(*hook_svp, G_SCALAR); + SPAGAIN; + response_sv = (items) ? POPs : &PL_sv_undef; + PUTBACK; + if (DBIc_TRACE_LEVEL(imp_xxh) >= 1) + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," <- HandleSetErr= %s (err=%s, errstr=%s, state=%s, %s)\n", + neatsvpv(response_sv,0), neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0), + neatsvpv(method,0) + ); + if (SvTRUE(response_sv)) /* handler says it has handled it, so... */ + return 0; + } + + if (!SvOK(err)) { /* clear err / errstr / state */ + DBIh_CLEAR_ERROR(imp_xxh); + return 1; + } + + /* fetch these after calling HandleSetErr */ + h_err = DBIc_ERR(imp_xxh); + h_errstr = DBIc_ERRSTR(imp_xxh); + h_state = DBIc_STATE(imp_xxh); + + if (SvTRUE(h_errstr)) { + /* append current err, if any, to errstr if it's going to change */ + if (SvTRUE(h_err) && SvTRUE(err) && strNE(SvPV_nolen(h_err), SvPV_nolen(err))) + sv_catpvf(h_errstr, " [err was %s now %s]", SvPV_nolen(h_err), SvPV_nolen(err)); + if (SvTRUE(h_state) && SvTRUE(state) && strNE(SvPV_nolen(h_state), SvPV_nolen(state))) + sv_catpvf(h_errstr, " [state was %s now %s]", SvPV_nolen(h_state), SvPV_nolen(state)); + if (strNE(SvPV_nolen(h_errstr), SvPV_nolen(errstr))) { + sv_catpvn(h_errstr, "\n", 1); + sv_catsv(h_errstr, errstr); + } + } + else + sv_setsv(h_errstr, errstr); + + /* SvTRUE(err) > "0" > "" > undef */ + if (SvTRUE(err) /* new error: so assign */ + || !SvOK(h_err) /* no existing warn/info: so assign */ + /* new warn ("0" len 1) > info ("" len 0): so assign */ + || (SvOK(err) && strlen(SvPV_nolen(err)) > strlen(SvPV_nolen(h_err))) + ) { + sv_setsv(h_err, err); + err_changed = 1; + if (SvTRUE(h_err)) /* new error */ + ++DBIc_ErrCount(imp_xxh); + } + + if (err_changed) { + if (SvTRUE(state)) { + if (strlen(SvPV_nolen(state)) != 5) { + warn("set_err: state (%s) is not a 5 character string, using 'S1000' instead", neatsvpv(state,0)); + sv_setpv(h_state, "S1000"); + } + else + sv_setsv(h_state, state); + } + else + (void)SvOK_off(h_state); /* see DBIc_STATE_adjust */ + } + + return 1; +} + + +static char * +mkvname(pTHX_ HV *stash, const char *item, int uplevel) /* construct a variable name */ +{ + SV *sv = sv_newmortal(); + sv_setpv(sv, HvNAME(stash)); + if(uplevel) { + while(SvCUR(sv) && *SvEND(sv)!=':') + --SvCUR(sv); + if (SvCUR(sv)) + --SvCUR(sv); + } + sv_catpv(sv, "::"); + sv_catpv(sv, item); + return SvPV_nolen(sv); +} + +/* 32 bit magic FNV-0 and FNV-1 prime */ +#define FNV_32_PRIME ((UV)0x01000193) + +static I32 +dbi_hash(const char *key, long type) +{ + if (type == 0) { + STRLEN klen = strlen(key); + U32 hash = 0; + while (klen--) + hash = hash * 33 + *key++; + hash &= 0x7FFFFFFF; /* limit to 31 bits */ + hash |= 0x40000000; /* set bit 31 */ + return -(I32)hash; /* return negative int */ + } + else if (type == 1) { /* Fowler/Noll/Vo hash */ + /* see http://www.isthe.com/chongo/tech/comp/fnv/ */ + U32 hash = 0x811c9dc5; + const unsigned char *s = (unsigned char *)key; /* unsigned string */ + while (*s) { + /* multiply by the 32 bit FNV magic prime mod 2^32 */ + hash *= FNV_32_PRIME; + /* xor the bottom with the current octet */ + hash ^= (U32)*s++; + } + return hash; + } + croak("DBI::hash(%ld): invalid type", type); + return 0; /* NOT REACHED */ +} + + +static int +dbih_logmsg(imp_xxh_t *imp_xxh, const char *fmt, ...) +{ + dTHX; + va_list args; +#ifdef I_STDARG + va_start(args, fmt); +#else + va_start(args); +#endif + (void) PerlIO_vprintf(DBIc_DBISTATE(imp_xxh)->logfp, fmt, args); + va_end(args); + (void)imp_xxh; + return 1; +} + +static void +close_trace_file(pTHX) +{ + dMY_CXT; + if (DBILOGFP == PerlIO_stderr() || DBILOGFP == PerlIO_stdout()) + return; + + if (DBIS->logfp_ref == NULL) + PerlIO_close(DBILOGFP); + else { + /* DAA dec refcount and discard */ + SvREFCNT_dec(DBIS->logfp_ref); + DBIS->logfp_ref = NULL; + } +} + +static int +set_trace_file(SV *file) +{ + dTHX; + dMY_CXT; + const char *filename; + PerlIO *fp = Nullfp; + IO *io; + + if (!file) /* no arg == no change */ + return 0; + + /* DAA check for a filehandle */ + if (SvROK(file)) { + io = sv_2io(file); + if (!io || !(fp = IoOFP(io))) { + warn("DBI trace filehandle is not valid"); + return 0; + } + close_trace_file(aTHX); + SvREFCNT_inc(io); + DBIS->logfp_ref = io; + } + else if (isGV_with_GP(file)) { + io = GvIO(file); + if (!io || !(fp = IoOFP(io))) { + warn("DBI trace filehandle from GLOB is not valid"); + return 0; + } + close_trace_file(aTHX); + SvREFCNT_inc(io); + DBIS->logfp_ref = io; + } + else { + filename = (SvOK(file)) ? SvPV_nolen(file) : Nullch; + /* undef arg == reset back to stderr */ + if (!filename || strEQ(filename,"STDERR") + || strEQ(filename,"*main::STDERR")) { + close_trace_file(aTHX); + DBILOGFP = PerlIO_stderr(); + return 1; + } + if (strEQ(filename,"STDOUT")) { + close_trace_file(aTHX); + DBILOGFP = PerlIO_stdout(); + return 1; + } + fp = PerlIO_open(filename, "a+"); + if (fp == Nullfp) { + warn("Can't open trace file %s: %s", filename, Strerror(errno)); + return 0; + } + close_trace_file(aTHX); + } + DBILOGFP = fp; + /* if this line causes your compiler or linker to choke */ + /* then just comment it out, it's not essential. */ + PerlIO_setlinebuf(fp); /* force line buffered output */ + return 1; +} + +static IV +parse_trace_flags(SV *h, SV *level_sv, IV old_level) +{ + dTHX; + IV level; + if (!level_sv || !SvOK(level_sv)) + level = old_level; /* undef: no change */ + else + if (SvTRUE(level_sv)) { + if (looks_like_number(level_sv)) + level = SvIV(level_sv); /* number: number */ + else { /* string: parse it */ + dSP; + PUSHMARK(sp); + XPUSHs(h); + XPUSHs(level_sv); + PUTBACK; + if (call_method("parse_trace_flags", G_SCALAR) != 1) + croak("panic: parse_trace_flags");/* should never happen */ + SPAGAIN; + level = POPi; + PUTBACK; + } + } + else /* defined but false: 0 */ + level = 0; + return level; +} + + +static int +set_trace(SV *h, SV *level_sv, SV *file) +{ + dTHX; + D_imp_xxh(h); + int RETVAL = DBIc_DBISTATE(imp_xxh)->debug; /* Return trace level in effect now */ + IV level = parse_trace_flags(h, level_sv, RETVAL); + set_trace_file(file); + if (level != RETVAL) { /* set value */ + if ((level & DBIc_TRACE_LEVEL_MASK) > 0) { + PerlIO_printf(DBIc_LOGPIO(imp_xxh), + " %s trace level set to 0x%lx/%ld (DBI @ 0x%lx/%ld) in DBI %s%s (pid %d)\n", + neatsvpv(h,0), + (long)(level & DBIc_TRACE_FLAGS_MASK), + (long)(level & DBIc_TRACE_LEVEL_MASK), + (long)DBIc_TRACE_FLAGS(imp_xxh), (long)DBIc_TRACE_LEVEL(imp_xxh), + XS_VERSION, dbi_build_opt, (int)PerlProc_getpid()); + if (!PL_dowarn) + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," Note: perl is running without the recommended perl -w option\n"); + PerlIO_flush(DBIc_LOGPIO(imp_xxh)); + } + sv_setiv(DBIc_DEBUG(imp_xxh), level); + } + return RETVAL; +} + + +static SV * +dbih_inner(pTHX_ SV *orv, const char *what) +{ /* convert outer to inner handle else croak(what) if what is not NULL */ + /* if what is NULL then return NULL for invalid handles */ + MAGIC *mg; + SV *ohv; /* outer HV after derefing the RV */ + SV *hrv; /* dbi inner handle RV-to-HV */ + + /* enable a raw HV (not ref-to-HV) to be passed in, eg DBIc_MY_H */ + ohv = SvROK(orv) ? SvRV(orv) : orv; + + if (!ohv || SvTYPE(ohv) != SVt_PVHV) { + if (!what) + return NULL; + if (1) { + dMY_CXT; + if (DBIS_TRACE_LEVEL) + sv_dump(orv); + } + if (!SvOK(orv)) + croak("%s given an undefined handle %s", + what, "(perhaps returned from a previous call which failed)"); + croak("%s handle %s is not a DBI handle", what, neatsvpv(orv,0)); + } + if (!SvMAGICAL(ohv)) { + if (!what) + return NULL; + sv_dump(orv); + croak("%s handle %s is not a DBI handle (has no magic)", + what, neatsvpv(orv,0)); + } + + if ( (mg=mg_find(ohv,'P')) == NULL) { /* hash tie magic */ + /* not tied, maybe it's already an inner handle... */ + if (mg_find(ohv, DBI_MAGIC) == NULL) { + if (!what) + return NULL; + sv_dump(orv); + croak("%s handle %s is not a valid DBI handle", + what, neatsvpv(orv,0)); + } + hrv = orv; /* was already a DBI handle inner hash */ + } + else { + hrv = mg->mg_obj; /* inner hash of tie */ + } + + return hrv; +} + + + +/* -------------------------------------------------------------------- */ +/* Functions to manage a DBI handle (magic and attributes etc). */ + +static imp_xxh_t * +dbih_getcom(SV *hrv) /* used by drivers via DBIS func ptr */ +{ + MAGIC *mg; + SV *sv; + + /* short-cut common case */ + if ( SvROK(hrv) + && (sv = SvRV(hrv)) + && SvRMAGICAL(sv) + && (mg = SvMAGIC(sv)) + && mg->mg_type == DBI_MAGIC + && mg->mg_ptr + ) + return (imp_xxh_t *) mg->mg_ptr; + + { + dTHX; + imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ hrv, 0); + if (!imp_xxh) /* eg after take_imp_data */ + croak("Invalid DBI handle %s, has no dbi_imp_data", neatsvpv(hrv,0)); + return imp_xxh; + } +} + +static imp_xxh_t * +dbih_getcom2(pTHX_ SV *hrv, MAGIC **mgp) /* Get com struct for handle. Must be fast. */ +{ + MAGIC *mg; + SV *sv; + + /* important and quick sanity check (esp non-'safe' Oraperl) */ + if (SvROK(hrv)) /* must at least be a ref */ + sv = SvRV(hrv); + else { + dMY_CXT; + if (hrv == DBI_LAST_HANDLE) /* special for var::FETCH */ + sv = DBI_LAST_HANDLE; + else if (sv_derived_from(hrv, "DBI::common")) { + /* probably a class name, if ref($h)->foo() */ + return 0; + } + else { + sv_dump(hrv); + croak("Invalid DBI handle %s", neatsvpv(hrv,0)); + sv = &PL_sv_undef; /* avoid "might be used uninitialized" warning */ + } + } + + /* Short cut for common case. We assume that a magic var always */ + /* has magic and that DBI_MAGIC, if present, will be the first. */ + if (SvRMAGICAL(sv) && (mg=SvMAGIC(sv))->mg_type == DBI_MAGIC) { + /* nothing to do here */ + } + else { + /* Validate handle (convert outer to inner if required) */ + hrv = dbih_inner(aTHX_ hrv, "dbih_getcom"); + mg = mg_find(SvRV(hrv), DBI_MAGIC); + } + if (mgp) /* let caller pickup magic struct for this handle */ + *mgp = mg; + + return (imp_xxh_t *) mg->mg_ptr; +} + + +static SV * +dbih_setup_attrib(pTHX_ SV *h, imp_xxh_t *imp_xxh, char *attrib, SV *parent, int read_only, int optional) +{ + STRLEN len = strlen(attrib); + SV **asvp; + + asvp = hv_fetch((HV*)SvRV(h), attrib, len, !optional); + /* we assume that we won't have any existing 'undef' attributes here */ + /* (or, alternately, we take undef to mean 'copy from parent') */ + if (!(asvp && SvOK(*asvp))) { /* attribute doesn't already exists (the common case) */ + SV **psvp; + if ((!parent || !SvROK(parent)) && !optional) { + croak("dbih_setup_attrib(%s): %s not set and no parent supplied", + neatsvpv(h,0), attrib); + } + psvp = hv_fetch((HV*)SvRV(parent), attrib, len, 0); + if (psvp) { + if (!asvp) + asvp = hv_fetch((HV*)SvRV(h), attrib, len, 1); + sv_setsv(*asvp, *psvp); /* copy attribute from parent to handle */ + } + else { + if (!optional) + croak("dbih_setup_attrib(%s): %s not set and not in parent", + neatsvpv(h,0), attrib); + } + } + if (DBIc_TRACE_LEVEL(imp_xxh) >= 5) { + PerlIO *logfp = DBIc_LOGPIO(imp_xxh); + PerlIO_printf(logfp," dbih_setup_attrib(%s, %s, %s)", + neatsvpv(h,0), attrib, neatsvpv(parent,0)); + if (!asvp) + PerlIO_printf(logfp," undef (not defined)\n"); + else + if (SvOK(*asvp)) + PerlIO_printf(logfp," %s (already defined)\n", neatsvpv(*asvp,0)); + else PerlIO_printf(logfp," %s (copied from parent)\n", neatsvpv(*asvp,0)); + } + if (read_only && asvp) + SvREADONLY_on(*asvp); + return asvp ? *asvp : &PL_sv_undef; +} + + +static SV * +dbih_make_fdsv(SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name) +{ + dTHX; + D_imp_sth(sth); + const STRLEN cn_len = strlen(col_name); + imp_fdh_t *imp_fdh; + SV *fdsv; + if (imp_size < sizeof(imp_fdh_t) || cn_len<10 || strNE("::fd",&col_name[cn_len-4])) + croak("panic: dbih_makefdsv %s '%s' imp_size %ld invalid", + imp_class, col_name, (long)imp_size); + if (DBIc_TRACE_LEVEL(imp_sth) >= 5) + PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_make_fdsv(%s, %s, %ld, '%s')\n", + neatsvpv(sth,0), imp_class, (long)imp_size, col_name); + fdsv = dbih_make_com(sth, (imp_xxh_t*)imp_sth, imp_class, imp_size, cn_len+2, 0); + imp_fdh = (imp_fdh_t*)(void*)SvPVX(fdsv); + imp_fdh->com.col_name = ((char*)imp_fdh) + imp_size; + strcpy(imp_fdh->com.col_name, col_name); + return fdsv; +} + + +static SV * +dbih_make_com(SV *p_h, imp_xxh_t *p_imp_xxh, const char *imp_class, STRLEN imp_size, STRLEN extra, SV* imp_templ) +{ + dTHX; + static const char *errmsg = "Can't make DBI com handle for %s: %s"; + HV *imp_stash; + SV *dbih_imp_sv; + imp_xxh_t *imp; + int trace_level; + (void)extra; /* unused arg */ + + if ( (imp_stash = gv_stashpv(imp_class, FALSE)) == NULL) + croak(errmsg, imp_class, "unknown package"); + + if (imp_size == 0) { + /* get size of structure to allocate for common and imp specific data */ + const char *imp_size_name = mkvname(aTHX_ imp_stash, "imp_data_size", 0); + imp_size = SvIV(get_sv(imp_size_name, 0x05)); + if (imp_size == 0) { + imp_size = sizeof(imp_sth_t); + if (sizeof(imp_dbh_t) > imp_size) + imp_size = sizeof(imp_dbh_t); + if (sizeof(imp_drh_t) > imp_size) + imp_size = sizeof(imp_drh_t); + imp_size += 4; + } + } + + if (p_imp_xxh) { + trace_level = DBIc_TRACE_LEVEL(p_imp_xxh); + } + else { + dMY_CXT; + trace_level = DBIS_TRACE_LEVEL; + } + if (trace_level >= 5) { + dMY_CXT; + PerlIO_printf(DBILOGFP," dbih_make_com(%s, %p, %s, %ld, %p) thr#%p\n", + neatsvpv(p_h,0), (void*)p_imp_xxh, imp_class, (long)imp_size, (void*)imp_templ, (void*)PERL_GET_THX); + } + + if (imp_templ && SvOK(imp_templ)) { + U32 imp_templ_flags; + /* validate the supplied dbi_imp_data looks reasonable, */ + if (SvCUR(imp_templ) != imp_size) + croak("Can't use dbi_imp_data of wrong size (%ld not %ld)", + (long)SvCUR(imp_templ), (long)imp_size); + + /* copy the whole template */ + dbih_imp_sv = newSVsv(imp_templ); + imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv); + + /* sanity checks on the supplied imp_data */ + if (DBIc_TYPE(imp) != ((p_imp_xxh) ? DBIc_TYPE(p_imp_xxh)+1 :1) ) + croak("Can't use dbi_imp_data from different type of handle"); + if (!DBIc_has(imp, DBIcf_IMPSET)) + croak("Can't use dbi_imp_data that not from a setup handle"); + + /* copy flags, zero out our imp_xxh struct, restore some flags */ + imp_templ_flags = DBIc_FLAGS(imp); + switch ( (p_imp_xxh) ? DBIc_TYPE(p_imp_xxh)+1 : DBIt_DR ) { + case DBIt_DR: memzero((char*)imp, sizeof(imp_drh_t)); break; + case DBIt_DB: memzero((char*)imp, sizeof(imp_dbh_t)); break; + case DBIt_ST: memzero((char*)imp, sizeof(imp_sth_t)); break; + default: croak("dbih_make_com dbi_imp_data bad h type"); + } + /* Only pass on DBIcf_IMPSET to indicate to driver that the imp */ + /* structure has been copied and it doesn't need to reconnect. */ + /* Similarly DBIcf_ACTIVE is also passed along but isn't key. */ + DBIc_FLAGS(imp) = imp_templ_flags & (DBIcf_IMPSET|DBIcf_ACTIVE); + } + else { + dbih_imp_sv = newSV(imp_size); /* is grown to at least imp_size+1 */ + imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv); + memzero((char*)imp, imp_size); + /* set up SV with SvCUR set ready for take_imp_data */ + SvCUR_set(dbih_imp_sv, imp_size); + *SvEND(dbih_imp_sv) = '\0'; + } + + if (p_imp_xxh) { + DBIc_DBISTATE(imp) = DBIc_DBISTATE(p_imp_xxh); + } + else { + dMY_CXT; + DBIc_DBISTATE(imp) = DBIS; + } + DBIc_IMP_STASH(imp) = imp_stash; + + if (!p_h) { /* only a driver (drh) has no parent */ + DBIc_PARENT_H(imp) = &PL_sv_undef; + DBIc_PARENT_COM(imp) = NULL; + DBIc_TYPE(imp) = DBIt_DR; + DBIc_on(imp,DBIcf_WARN /* set only here, children inherit */ + |DBIcf_ACTIVE /* drivers are 'Active' by default */ + |DBIcf_AutoCommit /* advisory, driver must manage this */ + ); + DBIc_set(imp, DBIcf_PrintWarn, PL_dowarn); /* set if warnings enabled */ + } + else { + DBIc_PARENT_H(imp) = (SV*)SvREFCNT_inc(p_h); /* ensure it lives */ + DBIc_PARENT_COM(imp) = p_imp_xxh; /* shortcut for speed */ + DBIc_TYPE(imp) = DBIc_TYPE(p_imp_xxh) + 1; + /* inherit some flags from parent and carry forward some from template */ + DBIc_FLAGS(imp) = (DBIc_FLAGS(p_imp_xxh) & ~DBIcf_INHERITMASK) + | (DBIc_FLAGS(imp) & (DBIcf_IMPSET|DBIcf_ACTIVE)); + ++DBIc_KIDS(p_imp_xxh); + } +#ifdef DBI_USE_THREADS + DBIc_THR_USER(imp) = PERL_GET_THX ; +#endif + + if (DBIc_TYPE(imp) == DBIt_ST) { + imp_sth_t *imp_sth = (imp_sth_t*)imp; + DBIc_ROW_COUNT(imp_sth) = -1; + } + + DBIc_COMSET_on(imp); /* common data now set up */ + + /* The implementor should DBIc_IMPSET_on(imp) when setting up */ + /* any private data which will need clearing/freeing later. */ + + return dbih_imp_sv; +} + + +static void +dbih_setup_handle(pTHX_ SV *orv, char *imp_class, SV *parent, SV *imp_datasv) +{ + SV *h; + char *errmsg = "Can't setup DBI handle of %s to %s: %s"; + SV *dbih_imp_sv; + SV *dbih_imp_rv; + SV *dbi_imp_data = Nullsv; + SV **svp; + char imp_mem_name[300]; + HV *imp_mem_stash; + imp_xxh_t *imp; + imp_xxh_t *parent_imp; + int trace_level; + + h = dbih_inner(aTHX_ orv, "dbih_setup_handle"); + parent = dbih_inner(aTHX_ parent, NULL); /* check parent valid (& inner) */ + if (parent) { + parent_imp = DBIh_COM(parent); + trace_level = DBIc_TRACE_LEVEL(parent_imp); + } + else { + dMY_CXT; + parent_imp = NULL; + trace_level = DBIS_TRACE_LEVEL; + } + + if (trace_level >= 5) { + dMY_CXT; + PerlIO_printf(DBILOGFP," dbih_setup_handle(%s=>%s, %s, %lx, %s)\n", + neatsvpv(orv,0), neatsvpv(h,0), imp_class, (long)parent, neatsvpv(imp_datasv,0)); + } + + if (mg_find(SvRV(h), DBI_MAGIC) != NULL) + croak(errmsg, neatsvpv(orv,0), imp_class, "already a DBI (or ~magic) handle"); + + strcpy(imp_mem_name, imp_class); + strcat(imp_mem_name, "_mem"); + if ( (imp_mem_stash = gv_stashpv(imp_mem_name, FALSE)) == NULL) + croak(errmsg, neatsvpv(orv,0), imp_mem_name, "unknown _mem package"); + + if ((svp = hv_fetch((HV*)SvRV(h), "dbi_imp_data", 12, 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_fetch((HV*)SvRV(parent), "Callbacks", 9, 0)) + && SvROK(*tmp_svp) && SvTYPE(SvRV(*tmp_svp)) == SVt_PVHV + && (tmp_svp = hv_fetch((HV*)SvRV(*tmp_svp), "ChildCallbacks", 14, 0)) + && SvROK(*tmp_svp) && SvTYPE(SvRV(*tmp_svp)) == SVt_PVHV + ) { + /* XXX mirrors behaviour of dbih_set_attr_k() of Callbacks */ + (void)hv_store((HV*)SvRV(h), "Callbacks", 9, newRV_inc(SvRV(*tmp_svp)), 0); + 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_fetch((HV*)SvRV(parent), "ChildHandles", 12, 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_store((HV*)SvRV(h), "Driver", 6, newRV_inc(SvRV(parent)), 0); + (void)hv_fetch((HV*)SvRV(h), "Statement", 9, 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_store((HV*)SvRV(h), "Database", 8, newRV_inc(SvRV(parent)), 0); + /* copy (alias) Statement from the sth up into the dbh */ + tmp_svp = hv_fetch((HV*)SvRV(h), "Statement", 9, 1); + (void)hv_store((HV*)SvRV(parent), "Statement", 9, SvREFCNT_inc(*tmp_svp), 0); + break; + } + } + + /* 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) { + MAGIC *next = tie_mg->mg_moremagic; + SvMAGIC(SvRV(orv)) = tie_mg; + tie_mg->mg_moremagic = first; + first->mg_moremagic = next; + } + } + + DBI_UNLOCK; +} + + +static void +dbih_dumphandle(pTHX_ SV *h, const char *msg, int level) +{ + D_imp_xxh(h); + if (level >= 9) { + sv_dump(h); + } + dbih_dumpcom(aTHX_ imp_xxh, msg, level); +} + +static int +dbih_dumpcom(pTHX_ imp_xxh_t *imp_xxh, const char *msg, int level) +{ + dMY_CXT; + SV *flags = sv_2mortal(newSVpv("",0)); + SV *inner; + static const char pad[] = " "; + if (!msg) + msg = "dbih_dumpcom"; + PerlIO_printf(DBILOGFP," %s (%sh 0x%lx, com 0x%lx, imp %s):\n", + msg, dbih_htype_name(DBIc_TYPE(imp_xxh)), + (long)DBIc_MY_H(imp_xxh), (long)imp_xxh, + (PL_dirty) ? "global destruction" : HvNAME(DBIc_IMP_STASH(imp_xxh))); + if (DBIc_COMSET(imp_xxh)) sv_catpv(flags,"COMSET "); + if (DBIc_IMPSET(imp_xxh)) sv_catpv(flags,"IMPSET "); + if (DBIc_ACTIVE(imp_xxh)) sv_catpv(flags,"Active "); + if (DBIc_WARN(imp_xxh)) sv_catpv(flags,"Warn "); + if (DBIc_COMPAT(imp_xxh)) sv_catpv(flags,"CompatMode "); + if (DBIc_is(imp_xxh, DBIcf_ChopBlanks)) sv_catpv(flags,"ChopBlanks "); + if (DBIc_is(imp_xxh, DBIcf_HandleSetErr)) sv_catpv(flags,"HandleSetErr "); + if (DBIc_is(imp_xxh, DBIcf_HandleError)) sv_catpv(flags,"HandleError "); + if (DBIc_is(imp_xxh, DBIcf_RaiseError)) sv_catpv(flags,"RaiseError "); + if (DBIc_is(imp_xxh, DBIcf_PrintError)) sv_catpv(flags,"PrintError "); + if (DBIc_is(imp_xxh, DBIcf_PrintWarn)) sv_catpv(flags,"PrintWarn "); + if (DBIc_is(imp_xxh, DBIcf_ShowErrorStatement)) sv_catpv(flags,"ShowErrorStatement "); + if (DBIc_is(imp_xxh, DBIcf_AutoCommit)) sv_catpv(flags,"AutoCommit "); + if (DBIc_is(imp_xxh, DBIcf_BegunWork)) sv_catpv(flags,"BegunWork "); + if (DBIc_is(imp_xxh, DBIcf_LongTruncOk)) sv_catpv(flags,"LongTruncOk "); + if (DBIc_is(imp_xxh, DBIcf_MultiThread)) sv_catpv(flags,"MultiThread "); + if (DBIc_is(imp_xxh, DBIcf_TaintIn)) sv_catpv(flags,"TaintIn "); + if (DBIc_is(imp_xxh, DBIcf_TaintOut)) sv_catpv(flags,"TaintOut "); + if (DBIc_is(imp_xxh, DBIcf_Profile)) sv_catpv(flags,"Profile "); + if (DBIc_is(imp_xxh, DBIcf_Callbacks)) sv_catpv(flags,"Callbacks "); + PerlIO_printf(DBILOGFP,"%s FLAGS 0x%lx: %s\n", pad, (long)DBIc_FLAGS(imp_xxh), SvPV_nolen(flags)); + if (SvOK(DBIc_ERR(imp_xxh))) + PerlIO_printf(DBILOGFP,"%s ERR %s\n", pad, neatsvpv((SV*)DBIc_ERR(imp_xxh),0)); + if (SvOK(DBIc_ERR(imp_xxh))) + PerlIO_printf(DBILOGFP,"%s ERRSTR %s\n", pad, neatsvpv((SV*)DBIc_ERRSTR(imp_xxh),0)); + PerlIO_printf(DBILOGFP,"%s PARENT %s\n", pad, neatsvpv((SV*)DBIc_PARENT_H(imp_xxh),0)); + PerlIO_printf(DBILOGFP,"%s KIDS %ld (%ld Active)\n", pad, + (long)DBIc_KIDS(imp_xxh), (long)DBIc_ACTIVE_KIDS(imp_xxh)); + if (DBIc_IMP_DATA(imp_xxh) && SvOK(DBIc_IMP_DATA(imp_xxh))) + PerlIO_printf(DBILOGFP,"%s IMP_DATA %s\n", pad, neatsvpv(DBIc_IMP_DATA(imp_xxh),0)); + if (DBIc_LongReadLen(imp_xxh) != DBIc_LongReadLen_init) + PerlIO_printf(DBILOGFP,"%s LongReadLen %ld\n", pad, (long)DBIc_LongReadLen(imp_xxh)); + + if (DBIc_TYPE(imp_xxh) == DBIt_ST) { + const imp_sth_t *imp_sth = (imp_sth_t*)imp_xxh; + PerlIO_printf(DBILOGFP,"%s NUM_OF_FIELDS %d\n", pad, DBIc_NUM_FIELDS(imp_sth)); + PerlIO_printf(DBILOGFP,"%s NUM_OF_PARAMS %d\n", pad, DBIc_NUM_PARAMS(imp_sth)); + } + inner = dbih_inner(aTHX_ (SV*)DBIc_MY_H(imp_xxh), msg); + if (!inner || !SvROK(inner)) + return 1; + if (DBIc_TYPE(imp_xxh) <= DBIt_DB) { + SV **svp = hv_fetch((HV*)SvRV(inner), "CachedKids", 10, 0); + if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) { + HV *hv = (HV*)SvRV(*svp); + PerlIO_printf(DBILOGFP,"%s CachedKids %d\n", pad, (int)HvKEYS(hv)); + } + } + if (level > 0) { + SV* value; + char *key; + I32 keylen; + PerlIO_printf(DBILOGFP,"%s cached attributes:\n", pad); + while ( (value = hv_iternextsv((HV*)SvRV(inner), &key, &keylen)) ) { + PerlIO_printf(DBILOGFP,"%s '%s' => %s\n", pad, key, neatsvpv(value,0)); + } + } + else if (DBIc_TYPE(imp_xxh) == DBIt_DB) { + SV **svp = hv_fetch((HV*)SvRV(inner), "Name", 4, 0); + if (svp && SvOK(*svp)) + PerlIO_printf(DBILOGFP,"%s Name %s\n", pad, neatsvpv(*svp,0)); + } + else if (DBIc_TYPE(imp_xxh) == DBIt_ST) { + SV **svp = hv_fetch((HV*)SvRV(inner), "Statement", 9, 0); + if (svp && SvOK(*svp)) + PerlIO_printf(DBILOGFP,"%s Statement %s\n", pad, neatsvpv(*svp,0)); + } + return 1; +} + + +static void +dbih_clearcom(imp_xxh_t *imp_xxh) +{ + dTHX; + dTHR; + int dump = FALSE; + int debug = DBIc_TRACE_LEVEL(imp_xxh); + int auto_dump = (debug >= 6); + imp_xxh_t * const parent_xxh = DBIc_PARENT_COM(imp_xxh); + /* Note that we're very much on our own here. DBIc_MY_H(imp_xxh) almost */ + /* certainly points to memory which has been freed. Don't use it! */ + + /* --- pre-clearing sanity checks --- */ + +#ifdef DBI_USE_THREADS + if (DBIc_THR_USER(imp_xxh) != my_perl) { /* don't clear handle that belongs to another thread */ + if (debug >= 3) { + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," skipped dbih_clearcom: DBI handle (type=%d, %s) is owned by thread %p not current thread %p\n", + DBIc_TYPE(imp_xxh), HvNAME(DBIc_IMP_STASH(imp_xxh)), (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ; + PerlIO_flush(DBIc_LOGPIO(imp_xxh)); + } + return; + } +#endif + + if (!DBIc_COMSET(imp_xxh)) { /* should never happen */ + dbih_dumpcom(aTHX_ imp_xxh, "dbih_clearcom: DBI handle already cleared", 0); + return; + } + + if (auto_dump) + dbih_dumpcom(aTHX_ imp_xxh,"DESTROY (dbih_clearcom)", 0); + + if (!PL_dirty) { + + if (DBIc_ACTIVE(imp_xxh)) { /* bad news, potentially */ + /* warn for sth, warn for dbh only if it has active sth or isn't AutoCommit */ + if (DBIc_TYPE(imp_xxh) >= DBIt_ST + || (DBIc_ACTIVE_KIDS(imp_xxh) || !DBIc_has(imp_xxh, DBIcf_AutoCommit)) + ) { + warn("DBI %s handle 0x%lx cleared whilst still active", + dbih_htype_name(DBIc_TYPE(imp_xxh)), (unsigned long)DBIc_MY_H(imp_xxh)); + dump = TRUE; + } + } + + /* check that the implementor has done its own housekeeping */ + if (DBIc_IMPSET(imp_xxh)) { + warn("DBI %s handle 0x%lx has uncleared implementors data", + dbih_htype_name(DBIc_TYPE(imp_xxh)), (unsigned long)DBIc_MY_H(imp_xxh)); + dump = TRUE; + } + + if (DBIc_KIDS(imp_xxh)) { + warn("DBI %s handle 0x%lx has %d uncleared child handles", + dbih_htype_name(DBIc_TYPE(imp_xxh)), + (unsigned long)DBIc_MY_H(imp_xxh), (int)DBIc_KIDS(imp_xxh)); + dump = TRUE; + } + } + + if (dump && !auto_dump) /* else was already dumped above */ + dbih_dumpcom(aTHX_ imp_xxh, "dbih_clearcom", 0); + + /* --- pre-clearing adjustments --- */ + + if (!PL_dirty) { + if (parent_xxh) { + if (DBIc_ACTIVE(imp_xxh)) /* see also DBIc_ACTIVE_off */ + --DBIc_ACTIVE_KIDS(parent_xxh); + --DBIc_KIDS(parent_xxh); + } + } + + /* --- clear fields (may invoke object destructors) --- */ + + if (DBIc_TYPE(imp_xxh) == DBIt_ST) { + imp_sth_t *imp_sth = (imp_sth_t*)imp_xxh; + sv_free((SV*)DBIc_FIELDS_AV(imp_sth)); + } + + sv_free(DBIc_IMP_DATA(imp_xxh)); /* do this first */ + if (DBIc_TYPE(imp_xxh) <= DBIt_ST) { /* DBIt_FD doesn't have attr */ + sv_free(_imp2com(imp_xxh, attr.TraceLevel)); + sv_free(_imp2com(imp_xxh, attr.State)); + sv_free(_imp2com(imp_xxh, attr.Err)); + sv_free(_imp2com(imp_xxh, attr.Errstr)); + sv_free(_imp2com(imp_xxh, attr.FetchHashKeyName)); + } + + + sv_free((SV*)DBIc_PARENT_H(imp_xxh)); /* do this last */ + + DBIc_COMSET_off(imp_xxh); + + if (debug >= 4) + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," dbih_clearcom 0x%lx (com 0x%lx, type %d) done.\n\n", + (long)DBIc_MY_H(imp_xxh), (long)imp_xxh, DBIc_TYPE(imp_xxh)); +} + + +/* --- Functions for handling field buffer arrays --- */ + +static AV * +dbih_setup_fbav(imp_sth_t *imp_sth) +{ + /* Usually called to setup the row buffer for new sth. + * Also called if the value of NUM_OF_FIELDS is altered, + * in which case it adjusts the row buffer to match NUM_OF_FIELDS. + */ + dTHX; + I32 i = DBIc_NUM_FIELDS(imp_sth); + AV *av = DBIc_FIELDS_AV(imp_sth); + + if (i < 0) + i = 0; + + if (av) { + if (av_len(av)+1 == i) /* is existing array the right size? */ + return av; + /* we need to adjust the size of the array */ + if (DBIc_TRACE_LEVEL(imp_sth) >= 2) + PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav realloc from %ld to %ld fields\n", (long)(av_len(av)+1), (long)i); + SvREADONLY_off(av); + if (i < av_len(av)+1) /* trim to size if too big */ + av_fill(av, i-1); + } + else { + if (DBIc_TRACE_LEVEL(imp_sth) >= 5) + PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav alloc for %ld fields\n", (long)i); + av = newAV(); + DBIc_FIELDS_AV(imp_sth) = av; + + /* row_count will need to be manually reset by the driver if the */ + /* sth is re-executed (since this code won't get rerun) */ + DBIc_ROW_COUNT(imp_sth) = 0; + } + + /* load array with writeable SV's. Do this backwards so */ + /* the array only gets extended once. */ + while(i--) /* field 1 stored at index 0 */ + av_store(av, i, newSV(0)); + if (DBIc_TRACE_LEVEL(imp_sth) >= 6) + PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav now %ld fields\n", (long)(av_len(av)+1)); + SvREADONLY_on(av); /* protect against shift @$row etc */ + return av; +} + + +static AV * +dbih_get_fbav(imp_sth_t *imp_sth) +{ + AV *av; + + if ( (av = DBIc_FIELDS_AV(imp_sth)) == Nullav) { + av = dbih_setup_fbav(imp_sth); + } + else { + dTHX; + int i = av_len(av) + 1; + if (i != DBIc_NUM_FIELDS(imp_sth)) { + /*SV *sth = dbih_inner(aTHX_ (SV*)DBIc_MY_H(imp_sth), "_get_fbav");*/ + /* warn via PrintWarn */ + set_err_char(SvRV(DBIc_MY_H(imp_sth)), (imp_xxh_t*)imp_sth, + "0", 0, "Number of row fields inconsistent with NUM_OF_FIELDS (driver bug)", "", "_get_fbav"); + /* + DBIc_NUM_FIELDS(imp_sth) = i; + hv_delete((HV*)SvRV(sth), "NUM_OF_FIELDS", 13, G_DISCARD); + */ + } + /* don't let SvUTF8 flag persist from one row to the next */ + /* (only affects drivers that use sv_setpv, but most XS do) */ + /* XXX turn into option later (force on/force off/ignore) */ + while(i--) /* field 1 stored at index 0 */ + SvUTF8_off(AvARRAY(av)[i]); + } + + if (DBIc_is(imp_sth, DBIcf_TaintOut)) { + dTHX; + dTHR; + TAINT; /* affects sv_setsv()'s called within same perl statement */ + } + + /* XXX fancy stuff to happen here later (re scrolling etc) */ + ++DBIc_ROW_COUNT(imp_sth); + return av; +} + + +static int +dbih_sth_bind_col(SV *sth, SV *col, SV *ref, SV *attribs) +{ + dTHX; + D_imp_sth(sth); + AV *av; + int idx = SvIV(col); + int fields = DBIc_NUM_FIELDS(imp_sth); + + if (fields <= 0) { + attribs = attribs; /* avoid 'unused variable' warning */ + croak("Statement has no result columns to bind%s", + DBIc_ACTIVE(imp_sth) + ? "" : " (perhaps you need to call execute first)"); + } + + if ( (av = DBIc_FIELDS_AV(imp_sth)) == Nullav) + av = dbih_setup_fbav(imp_sth); + + if (DBIc_TRACE_LEVEL(imp_sth) >= 5) + PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_sth_bind_col %s => %s %s\n", + neatsvpv(col,0), neatsvpv(ref,0), neatsvpv(attribs,0)); + + if (idx < 1 || idx > fields) + croak("bind_col: column %d is not a valid column (1..%d)", + idx, fields); + + if (!SvOK(ref) && SvREADONLY(ref)) { /* binding to literal undef */ + /* presumably the call is just setting the TYPE or other atribs */ + /* but this default method ignores attribs, so we just return */ + return 1; + } + + /* Write this as > SVt_PVMG because in 5.8.x the next type */ + /* is SVt_PVBM, whereas in 5.9.x it's SVt_PVGV. */ + if (!SvROK(ref) || SvTYPE(SvRV(ref)) > SVt_PVMG) /* XXX LV */ + croak("Can't %s->bind_col(%s, %s,...), need a reference to a scalar", + neatsvpv(sth,0), neatsvpv(col,0), neatsvpv(ref,0)); + + /* use supplied scalar as storage for this column */ + SvREADONLY_off(av); + av_store(av, idx-1, SvREFCNT_inc(SvRV(ref)) ); + SvREADONLY_on(av); + return 1; +} + + +static int +quote_type(int sql_type, int p, int s, int *t, void *v) +{ + /* Returns true if type should be bound as a number else */ + /* false implying that binding as a string should be okay. */ + /* The true value is either SQL_INTEGER or SQL_DOUBLE which */ + /* can be used as a hint if desired. */ + (void)p; + (void)s; + (void)t; + (void)v; + /* looks like it's never been used, and doesn't make much sense anyway */ + warn("Use of DBI internal bind_as_num/quote_type function is deprecated"); + switch(sql_type) { + case SQL_INTEGER: + case SQL_SMALLINT: + case SQL_TINYINT: + case SQL_BIGINT: + return 0; + case SQL_FLOAT: + case SQL_REAL: + case SQL_DOUBLE: + return 0; + case SQL_NUMERIC: + case SQL_DECIMAL: + return 0; /* bind as string to attempt to retain precision */ + } + return 1; +} + + +/* Convert a simple string representation of a value into a more specific + * perl type based on an sql_type value. + * The semantics of SQL standard TYPE values are interpreted _very_ loosely + * on the basis of "be liberal in what you accept and let's throw in some + * extra semantics while we're here" :) + * Returns: + * -2: sql_type isn't handled, value unchanged + * -1: sv is undef, value unchanged + * 0: sv couldn't be cast cleanly and DBIstcf_STRICT was used + * 1: sv couldn't be cast cleanly and DBIstcf_STRICT was not used + * 2: sv was cast ok + */ + +int +sql_type_cast_svpv(pTHX_ SV *sv, int sql_type, U32 flags, void *v) +{ + int cast_ok = 0; + int grok_flags; + UV uv; + + /* do nothing for undef (NULL) or non-string values */ + if (!sv || !SvOK(sv)) + return -1; + + switch(sql_type) { + + default: + return -2; /* not a recognised SQL TYPE, value unchanged */ + + case SQL_INTEGER: + /* sv_2iv is liberal, may return SvIV, SvUV, or SvNV */ + sv_2iv(sv); + /* SvNOK will be set if value is out of range for IV/UV. + * SvIOK should be set but won't if sv is not numeric (in which + * case perl would have warn'd already if -w or warnings are in effect) + */ + cast_ok = (SvIOK(sv) && !SvNOK(sv)); + break; + + case SQL_DOUBLE: + sv_2nv(sv); + /* SvNOK should be set but won't if sv is not numeric (in which + * case perl would have warn'd already if -w or warnings are in effect) + */ + cast_ok = SvNOK(sv); + break; + + /* caller would like IV else UV else NV */ + /* else no error and sv is untouched */ + case SQL_NUMERIC: + /* based on the code in perl's toke.c */ + uv = 0; + grok_flags = grok_number(SvPVX(sv), SvCUR(sv), &uv); + cast_ok = 1; + if (grok_flags == IS_NUMBER_IN_UV) { /* +ve int */ + if (uv <= IV_MAX) /* prefer IV over UV */ + 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); + 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; + (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); + } + else if (strEQ(key, "RaiseError")) { + DBIc_set(imp_xxh,DBIcf_RaiseError, on); + } + else if (strEQ(key, "PrintError")) { + DBIc_set(imp_xxh,DBIcf_PrintError, on); + } + else if (strEQ(key, "PrintWarn")) { + DBIc_set(imp_xxh,DBIcf_PrintWarn, on); + } + else if (strEQ(key, "HandleError")) { + if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) { + croak("Can't set %s to '%s'", "HandleError", neatsvpv(valuesv,0)); + } + DBIc_set(imp_xxh,DBIcf_HandleError, on); + cacheit = 1; /* child copy setup by dbih_setup_handle() */ + } + else if (strEQ(key, "HandleSetErr")) { + if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) { + croak("Can't set %s to '%s'","HandleSetErr",neatsvpv(valuesv,0)); + } + DBIc_set(imp_xxh,DBIcf_HandleSetErr, on); + cacheit = 1; /* child copy setup by dbih_setup_handle() */ + } + else if (strEQ(key, "ChildHandles")) { + if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVAV)) ) { + croak("Can't set %s to '%s'", "ChildHandles", neatsvpv(valuesv,0)); + } + cacheit = 1; /* just save it in the hash */ + } + else if (strEQ(key, "Profile")) { + static const char profile_class[] = "DBI::Profile"; + 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 */ + perl_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); + XPUSHs(sv_2mortal(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; + perl_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; + } + 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; + } + 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) { + (void)hv_store((HV*)SvRV(h), key, keylen, newSVsv(valuesv), 0); + } + 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 */ + svp = hv_fetch((HV*)DBIc_MY_H(imp_sth), "NAME",4, FALSE); + sv = (svp) ? *svp : &PL_sv_undef; + if (SvGMAGICAL(sv)) /* call FETCH via magic */ + mg_get(sv); + + if (SvROK(sv)) { + AV *name_av = (AV*)SvRV(sv); + char *name; + int upcase = (key[5] == 'u'); + AV *av = Nullav; + HV *hv = Nullhv; + int num_fields_mismatch = 0; + + if (strEQ(&key[strlen(key)-5], "_hash")) + hv = newHV(); + else av = newAV(); + i = DBIc_NUM_FIELDS(imp_sth); + + /* catch invalid NUM_FIELDS */ + if (i != AvFILL(name_av)+1) { + /* flag as mismatch, except for "-1 and empty" case */ + if ( ! (i == -1 && 0 == AvFILL(name_av)+1) ) + num_fields_mismatch = 1; + i = AvFILL(name_av)+1; /* limit for safe iteration over array */ + } + + if (DBIc_TRACE_LEVEL(imp_sth) >= 10 || (num_fields_mismatch && DBIc_WARN(imp_xxh))) { + PerlIO_printf(DBIc_LOGPIO(imp_sth)," FETCH $h->{%s} from $h->{NAME} with $h->{NUM_OF_FIELDS} = %d" + " and %ld entries in $h->{NAME}%s\n", + neatsvpv(keysv,0), DBIc_NUM_FIELDS(imp_sth), AvFILL(name_av)+1, + (num_fields_mismatch) ? " (possible bug in driver)" : ""); + } + + while (--i >= 0) { + sv = newSVsv(AvARRAY(name_av)[i]); + name = SvPV_nolen(sv); + if (key[5] != 'h') { /* "NAME_hash" */ + for (p = name; p && *p; ++p) { +#ifdef toUPPER_LC + *p = (upcase) ? toUPPER_LC(*p) : toLOWER_LC(*p); +#else + *p = (upcase) ? toUPPER(*p) : toLOWER(*p); +#endif + } + } + if (av) + av_store(av, i, sv); + else { + (void)hv_store(hv, name, SvCUR(sv), newSViv(i), 0); + sv_free(sv); + } + } + valuesv = newRV_noinc( (av ? (SV*)av : (SV*)hv) ); + cacheit = TRUE; /* can't change */ + } + } + else if (keylen==13 && strEQ(key, "NUM_OF_FIELDS")) { + D_imp_sth(h); + IV num_fields = DBIc_NUM_FIELDS(imp_sth); + valuesv = (num_fields < 0) ? &PL_sv_undef : newSViv(num_fields); + if (num_fields > 0) + cacheit = TRUE; /* can't change once set (XXX except for multiple result sets) */ + } + else if (keylen==13 && strEQ(key, "NUM_OF_PARAMS")) { + D_imp_sth(h); + valuesv = newSViv(DBIc_NUM_PARAMS(imp_sth)); + cacheit = TRUE; /* can't change */ + } + break; + + case 'P': + if (strEQ(key, "PRECISION")) + valuesv = &PL_sv_undef; + else if (strEQ(key, "ParamValues")) + valuesv = &PL_sv_undef; + else if (strEQ(key, "ParamTypes")) + valuesv = &PL_sv_undef; + break; + + case 'R': + if (strEQ(key, "RowsInCache")) + valuesv = &PL_sv_undef; + break; + + 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)); + } + break; + + case 'R': + if (keylen==10 && strEQ(key, "RaiseError")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_RaiseError)); + } + else if (keylen==12 && strEQ(key, "RowCacheSize")) { + valuesv = &PL_sv_undef; + } + break; + + case 'S': + if (keylen==18 && strEQ(key, "ShowErrorStatement")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_ShowErrorStatement)); + } + break; + + case 'T': + if (keylen==4 && strEQ(key, "Type")) { + char *type = dbih_htype_name(htype); + valuesv = newSVpv(type,0); + cacheit = TRUE; /* can't change */ + } + else if (keylen==10 && strEQ(key, "TraceLevel")) { + valuesv = newSViv( DBIc_DEBUGIV(imp_xxh) ); + } + else if (keylen==5 && strEQ(key, "Taint")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintIn) && + DBIc_has(imp_xxh,DBIcf_TaintOut)); + } + else if (keylen==7 && strEQ(key, "TaintIn")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintIn)); + } + else if (keylen==8 && strEQ(key, "TaintOut")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintOut)); + } + break; + + case 'W': + if (keylen==4 && strEQ(key, "Warn")) { + valuesv = boolSV(DBIc_WARN(imp_xxh)); + } + break; + } + } + + /* finally check the actual hash */ + if (valuesv == Nullsv) { + valuesv = &PL_sv_undef; + cacheit = 0; + svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE); + if (svp) + valuesv = newSVsv(*svp); /* take copy to mortalize */ + else /* warn unless it's known attribute name */ + if ( !( (*key=='H' && strEQ(key, "HandleError")) + || (*key=='H' && strEQ(key, "HandleSetErr")) + || (*key=='S' && strEQ(key, "Statement")) + || (*key=='P' && strEQ(key, "ParamArrays")) + || (*key=='P' && strEQ(key, "ParamValues")) + || (*key=='P' && strEQ(key, "Profile")) + || (*key=='R' && strEQ(key, "ReadOnly")) + || (*key=='C' && strEQ(key, "CursorName")) + || (*key=='C' && strEQ(key, "Callbacks")) + || (*key=='U' && strEQ(key, "Username")) + || !isUPPER(*key) /* dbd_*, private_* etc */ + )) + warn("Can't get %s->{%s}: unrecognised attribute name",neatsvpv(h,0),key); + } + + if (cacheit) { + (void)hv_store((HV*)SvRV(h), key, keylen, newSVsv(valuesv), 0); + } + if (DBIc_TRACE_LEVEL(imp_xxh) >= 3) + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," .. FETCH %s %s = %s%s\n", neatsvpv(h,0), + neatsvpv(keysv,0), neatsvpv(valuesv,0), cacheit?" (cached)":""); + if (valuesv == &PL_sv_yes || valuesv == &PL_sv_no || valuesv == &PL_sv_undef) + return valuesv; /* no need to mortalize yes or no */ + return sv_2mortal(valuesv); +} + + + +/* -------------------------------------------------------------------- */ +/* Functions implementing Error and Event Handling. */ + + +static SV * +dbih_event(SV *hrv, const char *evtype, SV *a1, SV *a2) +{ + dTHX; + /* We arrive here via DBIh_EVENT* macros (see DBIXS.h) called from */ + /* DBD driver C code OR $h->event() method (in DBD::_::common) */ + /* XXX VERY OLD INTERFACE/CONCEPT MAY GO SOON */ + /* OR MAY EVOLVE INTO A WAY TO HANDLE 'SUCCESS_WITH_INFO'/'WARNINGS' from db */ + (void)hrv; + (void)evtype; + (void)a1; + (void)a2; + return &PL_sv_undef; +} + + +/* ----------------------------------------------------------------- */ + + +STATIC I32 +dbi_dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock) +{ + dTHX; + I32 i; + register PERL_CONTEXT *cx; + for (i = startingblock; i >= 0; i--) { + cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + case CXt_SUB: +#ifdef CXt_FORMAT + case CXt_FORMAT: +#endif + DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); + return i; + } + } + return i; +} + + +static COP * +dbi_caller_cop() +{ + dTHX; + register I32 cxix; + register PERL_CONTEXT *cx; + register PERL_CONTEXT *ccstack = cxstack; + PERL_SI *top_si = PL_curstackinfo; + char *stashname; + + for ( cxix = dbi_dopoptosub_at(ccstack, cxstack_ix) ;; cxix = dbi_dopoptosub_at(ccstack, cxix - 1)) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = dbi_dopoptosub_at(ccstack, top_si->si_cxix); + } + if (cxix < 0) { + break; + } + if (PL_DBsub && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + continue; + cx = &ccstack[cxix]; + stashname = CopSTASHPV(cx->blk_oldcop); + if (!stashname) + continue; + if (!(stashname[0] == 'D' && stashname[1] == 'B' + && strchr("DI", stashname[2]) + && (!stashname[3] || (stashname[3] == ':' && stashname[4] == ':')))) + { + return cx->blk_oldcop; + } + cxix = dbi_dopoptosub_at(ccstack, cxix - 1); + } + return NULL; +} + +static void +dbi_caller_string(SV *buf, COP *cop, char *prefix, int show_line, int show_path) +{ + dTHX; + STRLEN len; + long line = CopLINE(cop); + char *file = SvPV(GvSV(CopFILEGV(cop)), len); + if (!show_path) { + char *sep; + if ( (sep=strrchr(file,'/')) || (sep=strrchr(file,'\\'))) + file = sep+1; + } + if (show_line) { + sv_catpvf(buf, "%s%s line %ld", (prefix) ? prefix : "", file, line); + } + else { + sv_catpvf(buf, "%s%s", (prefix) ? prefix : "", file); + } +} + +static char * +log_where(SV *buf, int append, char *prefix, char *suffix, int show_line, int show_caller, int show_path) +{ + dTHX; + dTHR; + if (!buf) + buf = sv_2mortal(newSVpv("",0)); + else if (!append) + sv_setpv(buf,""); + if (CopLINE(PL_curcop)) { + COP *cop; + dbi_caller_string(buf, PL_curcop, prefix, show_line, show_path); + if (show_caller && (cop = dbi_caller_cop())) { + SV *via = sv_2mortal(newSVpv("",0)); + dbi_caller_string(via, cop, prefix, show_line, show_path); + sv_catpvf(buf, " via %s", SvPV_nolen(via)); + } + } + if (PL_dirty) + sv_catpvf(buf, " during global destruction"); + if (suffix) + sv_catpv(buf, suffix); + return SvPVX(buf); +} + + +static void +clear_cached_kids(pTHX_ SV *h, imp_xxh_t *imp_xxh, const char *meth_name, int trace_level) +{ + if (DBIc_TYPE(imp_xxh) <= DBIt_DB) { + SV **svp = hv_fetch((HV*)SvRV(h), "CachedKids", 10, 0); + if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) { + HV *hv = (HV*)SvRV(*svp); + if (HvKEYS(hv)) { + if (DBIc_TRACE_LEVEL(imp_xxh) > trace_level) + trace_level = DBIc_TRACE_LEVEL(imp_xxh); + if (trace_level >= 2) { + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," >> %s %s clearing %d CachedKids\n", + meth_name, neatsvpv(h,0), (int)HvKEYS(hv)); + PerlIO_flush(DBIc_LOGPIO(imp_xxh)); + } + /* This will probably recurse through dispatch to DESTROY the kids */ + /* For drh we should probably explicitly do dbh disconnects */ + hv_clear(hv); + } + } + } +} + + +static NV +dbi_time() { +# ifdef HAS_GETTIMEOFDAY +# ifdef PERL_IMPLICIT_SYS + dTHX; +# endif + struct timeval when; + gettimeofday(&when, (struct timezone *) 0); + return when.tv_sec + (when.tv_usec / 1000000.0); +# else /* per-second is almost useless */ +# ifdef _WIN32 /* use _ftime() on Win32 (MS Visual C++ 6.0) */ +# if defined(__BORLANDC__) +# define _timeb timeb +# define _ftime ftime +# endif + struct _timeb when; + _ftime( &when ); + return when.time + (when.millitm / 1000.0); +# else + return time(NULL); +# endif +# endif +} + + +static SV * +_profile_next_node(SV *node, const char *name) +{ + /* step one level down profile Data tree and auto-vivify if required */ + dTHX; + SV *orig_node = node; + if (SvROK(node)) + node = SvRV(node); + if (SvTYPE(node) != SVt_PVHV) { + HV *hv = newHV(); + if (SvOK(node)) { + char *key = "(demoted)"; + warn("Profile data element %s replaced with new hash ref (for %s) and original value stored with key '%s'", + neatsvpv(orig_node,0), name, key); + (void)hv_store(hv, key, strlen(key), SvREFCNT_inc(orig_node), 0); + } + sv_setsv(node, newRV_noinc((SV*)hv)); + node = (SV*)hv; + } + node = *hv_fetch((HV*)node, name, strlen(name), 1); + return node; +} + + +static SV* +dbi_profile(SV *h, imp_xxh_t *imp_xxh, SV *statement_sv, SV *method, NV t1, NV t2) +{ +#define DBIprof_MAX_PATH_ELEM 100 +#define DBIprof_COUNT 0 +#define DBIprof_TOTAL_TIME 1 +#define DBIprof_FIRST_TIME 2 +#define DBIprof_MIN_TIME 3 +#define DBIprof_MAX_TIME 4 +#define DBIprof_FIRST_CALLED 5 +#define DBIprof_LAST_CALLED 6 +#define DBIprof_max_index 6 + dTHX; + NV ti = t2 - t1; + int src_idx = 0; + HV *dbh_outer_hv = NULL; + HV *dbh_inner_hv = NULL; + char *statement_pv; + char *method_pv; + SV *profile; + SV *tmp; + SV *dest_node; + AV *av; + HV *h_hv; + + const int call_depth = DBIc_CALL_DEPTH(imp_xxh); + const int parent_call_depth = DBIc_PARENT_COM(imp_xxh) ? DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) : 0; + /* Only count calls originating from the application code */ + if (call_depth > 1 || parent_call_depth > 0) + return &PL_sv_undef; + + if (!DBIc_has(imp_xxh, DBIcf_Profile)) + return &PL_sv_undef; + + method_pv = (SvTYPE(method)==SVt_PVCV) ? GvNAME(CvGV(method)) + : isGV(method) ? GvNAME(method) + : SvOK(method) ? SvPV_nolen(method) + : ""; + + /* we don't profile DESTROY during global destruction */ + if (PL_dirty && instr(method_pv, "DESTROY")) + return &PL_sv_undef; + + h_hv = (HV*)SvRV(dbih_inner(aTHX_ h, "dbi_profile")); + + profile = *hv_fetch(h_hv, "Profile", 7, 1); + if (profile && SvMAGICAL(profile)) + mg_get(profile); /* FETCH */ + if (!profile || !SvROK(profile)) { + DBIc_set(imp_xxh, DBIcf_Profile, 0); /* disable */ + if (SvOK(profile) && !PL_dirty) + warn("Profile attribute isn't a hash ref (%s,%ld)", neatsvpv(profile,0), (long)SvTYPE(profile)); + return &PL_sv_undef; + } + + /* statement_sv: undef = use $h->{Statement}, "" (&sv_no) = use empty string */ + + if (!SvOK(statement_sv)) { + SV **psv = hv_fetch(h_hv, "Statement", 9, 0); + statement_sv = (psv && SvOK(*psv)) ? *psv : &PL_sv_no; + } + statement_pv = SvPV_nolen(statement_sv); + + if (DBIc_TRACE_LEVEL(imp_xxh) >= 4) + PerlIO_printf(DBIc_LOGPIO(imp_xxh), " dbi_profile +%" NVff "s %s %s\n", + ti, method_pv, neatsvpv(statement_sv,0)); + + dest_node = _profile_next_node(profile, "Data"); + + tmp = *hv_fetch((HV*)SvRV(profile), "Path", 4, 1); + if (SvROK(tmp) && SvTYPE(SvRV(tmp))==SVt_PVAV) { + int len; + av = (AV*)SvRV(tmp); + len = av_len(av); /* -1=empty, 0=one element */ + + while ( src_idx <= len ) { + SV *pathsv = AvARRAY(av)[src_idx++]; + + if (SvROK(pathsv) && SvTYPE(SvRV(pathsv))==SVt_PVCV) { + /* call sub, use returned list of values as path */ + /* returning a ref to undef vetos this profile data */ + dSP; + I32 ax; + SV *code_sv = SvRV(pathsv); + I32 items; + I32 item_idx; + EXTEND(SP, 4); + PUSHMARK(SP); + PUSHs(h); /* push inner handle, then others params */ + PUSHs( sv_2mortal(newSVpv(method_pv,0))); + PUTBACK; + SAVE_DEFSV; /* local($_) = $statement */ + DEFSV = statement_sv; + items = call_sv(code_sv, G_ARRAY); + SPAGAIN; + SP -= items ; + ax = (SP - PL_stack_base) + 1 ; + for (item_idx=0; item_idx < items; ++item_idx) { + SV *item_sv = ST(item_idx); + if (SvROK(item_sv)) { + if (!SvOK(SvRV(item_sv))) + items = -2; /* flag that we're rejecting this profile data */ + else /* other refs reserved */ + warn("Ignored ref returned by code ref in Profile Path"); + break; + } + dest_node = _profile_next_node(dest_node, SvPV_nolen(item_sv)); + } + PUTBACK; + if (items == -2) /* this profile data was vetoed */ + return &PL_sv_undef; + } + else if (SvROK(pathsv)) { + /* only meant for refs to scalars currently */ + const char *p = SvPV_nolen(SvRV(pathsv)); + dest_node = _profile_next_node(dest_node, p); + } + else if (SvOK(pathsv)) { + STRLEN len; + const char *p = SvPV(pathsv,len); + if (p[0] == '!') { /* special cases */ + if (p[1] == 'S' && strEQ(p, "!Statement")) { + dest_node = _profile_next_node(dest_node, statement_pv); + } + else if (p[1] == 'M' && strEQ(p, "!MethodName")) { + dest_node = _profile_next_node(dest_node, method_pv); + } + else if (p[1] == 'M' && strEQ(p, "!MethodClass")) { + if (SvTYPE(method) == SVt_PVCV) { + p = SvPV_nolen((SV*)CvGV(method)); + } + else if (isGV(method)) { + /* just using SvPV_nolen(method) sometimes causes an error: */ + /* "Can't coerce GLOB to string" so we use gv_efullname() */ + SV *tmpsv = sv_2mortal(newSVpv("",0)); +#if (PERL_VERSION < 6) + gv_efullname(tmpsv, (GV*)method); +#else + gv_efullname4(tmpsv, (GV*)method, "", TRUE); +#endif + p = SvPV_nolen(tmpsv); + if (*p == '*') ++p; /* skip past leading '*' glob sigil */ + } + else { + p = method_pv; + } + dest_node = _profile_next_node(dest_node, p); + } + else if (p[1] == 'F' && strEQ(p, "!File")) { + dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 0, 0, 0)); + } + else if (p[1] == 'F' && strEQ(p, "!File2")) { + dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 0, 1, 0)); + } + else if (p[1] == 'C' && strEQ(p, "!Caller")) { + dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 1, 0, 0)); + } + else if (p[1] == 'C' && strEQ(p, "!Caller2")) { + dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 1, 1, 0)); + } + else if (p[1] == 'T' && (strEQ(p, "!Time") || strnEQ(p, "!Time~", 6))) { + char timebuf[20]; + int factor = 1; + if (p[5] == '~') { + factor = atoi(&p[6]); + if (factor == 0) /* sanity check to avoid div by zero error */ + factor = 3600; + } + sprintf(timebuf, "%ld", ((long)(dbi_time()/factor))*factor); + dest_node = _profile_next_node(dest_node, timebuf); + } + else { + warn("Unknown ! element in DBI::Profile Path: %s", p); + dest_node = _profile_next_node(dest_node, p); + } + } + else if (p[0] == '{' && p[len-1] == '}') { /* treat as name of dbh attribute to use */ + SV **attr_svp; + if (!dbh_inner_hv) { /* cache dbh handles the first time we need them */ + imp_dbh_t *imp_dbh = (DBIc_TYPE(imp_xxh) <= DBIt_DB) ? (imp_dbh_t*)imp_xxh : (imp_dbh_t*)DBIc_PARENT_COM(imp_xxh); + dbh_outer_hv = DBIc_MY_H(imp_dbh); + if (SvTYPE(dbh_outer_hv) != SVt_PVHV) + return &PL_sv_undef; /* presumably global destruction - bail */ + dbh_inner_hv = (HV*)SvRV(dbih_inner(aTHX_ (SV*)dbh_outer_hv, "profile")); + if (SvTYPE(dbh_inner_hv) != SVt_PVHV) + return &PL_sv_undef; /* presumably global destruction - bail */ + } + /* fetch from inner first, then outer if key doesn't exist */ + /* (yes, this is an evil premature optimization) */ + p += 1; len -= 2; /* ignore the braces */ + if ((attr_svp = hv_fetch(dbh_inner_hv, p, len, 0)) == NULL) { + /* try outer (tied) hash - for things like AutoCommit */ + /* (will always return something even for unknowns) */ + if ((attr_svp = hv_fetch(dbh_outer_hv, p, len, 0))) { + if (SvGMAGICAL(*attr_svp)) + mg_get(*attr_svp); /* FETCH */ + } + } + if (!attr_svp) + p -= 1; /* unignore the braces */ + else if (!SvOK(*attr_svp)) + p = ""; + else if (!SvTRUE(*attr_svp) && SvPOK(*attr_svp) && SvNIOK(*attr_svp)) + p = "0"; /* catch &sv_no style special case */ + else + p = SvPV_nolen(*attr_svp); + dest_node = _profile_next_node(dest_node, p); + } + else { + dest_node = _profile_next_node(dest_node, p); + } + } + /* else undef, so ignore */ + } + } + else { /* a bad Path value is treated as a Path of just Statement */ + dest_node = _profile_next_node(dest_node, statement_pv); + } + + + if (!SvOK(dest_node)) { + av = newAV(); + sv_setsv(dest_node, newRV_noinc((SV*)av)); + av_store(av, DBIprof_COUNT, newSViv(1)); + av_store(av, DBIprof_TOTAL_TIME, newSVnv(ti)); + av_store(av, DBIprof_FIRST_TIME, newSVnv(ti)); + av_store(av, DBIprof_MIN_TIME, newSVnv(ti)); + av_store(av, DBIprof_MAX_TIME, newSVnv(ti)); + av_store(av, DBIprof_FIRST_CALLED, newSVnv(t1)); + av_store(av, DBIprof_LAST_CALLED, newSVnv(t1)); + } + else { + tmp = dest_node; + if (SvROK(tmp)) + tmp = SvRV(tmp); + if (SvTYPE(tmp) != SVt_PVAV) + croak("Invalid Profile data leaf element: %s (type %ld)", + neatsvpv(tmp,0), (long)SvTYPE(tmp)); + av = (AV*)tmp; + sv_inc( *av_fetch(av, DBIprof_COUNT, 1)); + tmp = *av_fetch(av, DBIprof_TOTAL_TIME, 1); + sv_setnv(tmp, SvNV(tmp) + ti); + tmp = *av_fetch(av, DBIprof_MIN_TIME, 1); + if (ti < SvNV(tmp)) sv_setnv(tmp, ti); + tmp = *av_fetch(av, DBIprof_MAX_TIME, 1); + if (ti > SvNV(tmp)) sv_setnv(tmp, ti); + sv_setnv( *av_fetch(av, DBIprof_LAST_CALLED, 1), t1); + } + return dest_node; /* use with caution - copy first, ie sv_mortalcopy() */ +} + + +static void +dbi_profile_merge_nodes(SV *dest, SV *increment) +{ + dTHX; + AV *d_av, *i_av; + SV *tmp; + SV *tmp2; + NV i_nv; + int i_is_earlier; + + if (!SvROK(dest) || SvTYPE(SvRV(dest)) != SVt_PVAV) + croak("dbi_profile_merge_nodes(%s, ...) requires array ref", neatsvpv(dest,0)); + d_av = (AV*)SvRV(dest); + + if (av_len(d_av) < DBIprof_max_index) { + int idx; + av_extend(d_av, DBIprof_max_index); + for(idx=0; idx<=DBIprof_max_index; ++idx) { + tmp = *av_fetch(d_av, idx, 1); + if (!SvOK(tmp) && idx != DBIprof_MIN_TIME && idx != DBIprof_FIRST_CALLED) + sv_setnv(tmp, 0.0); /* leave 'min' values as undef */ + } + } + + if (!SvOK(increment)) + return; + + if (SvROK(increment) && SvTYPE(SvRV(increment)) == SVt_PVHV) { + HV *hv = (HV*)SvRV(increment); + char *key; + I32 keylen = 0; + hv_iterinit(hv); + while ( (tmp = hv_iternextsv(hv, &key, &keylen)) != NULL ) { + dbi_profile_merge_nodes(dest, tmp); + }; + return; + } + + if (!SvROK(increment) || SvTYPE(SvRV(increment)) != SVt_PVAV) + croak("dbi_profile_merge_nodes: increment %s not an array or hash ref", neatsvpv(increment,0)); + i_av = (AV*)SvRV(increment); + + tmp = *av_fetch(d_av, DBIprof_COUNT, 1); + tmp2 = *av_fetch(i_av, DBIprof_COUNT, 1); + if (SvIOK(tmp) && SvIOK(tmp2)) + sv_setiv( tmp, SvIV(tmp) + SvIV(tmp2) ); + else + sv_setnv( tmp, SvNV(tmp) + SvNV(tmp2) ); + + tmp = *av_fetch(d_av, DBIprof_TOTAL_TIME, 1); + sv_setnv( tmp, SvNV(tmp) + SvNV( *av_fetch(i_av, DBIprof_TOTAL_TIME, 1)) ); + + i_nv = SvNV(*av_fetch(i_av, DBIprof_MIN_TIME, 1)); + tmp = *av_fetch(d_av, DBIprof_MIN_TIME, 1); + if (!SvOK(tmp) || i_nv < SvNV(tmp)) sv_setnv(tmp, i_nv); + + i_nv = SvNV(*av_fetch(i_av, DBIprof_MAX_TIME, 1)); + tmp = *av_fetch(d_av, DBIprof_MAX_TIME, 1); + if (i_nv > SvNV(tmp)) sv_setnv(tmp, i_nv); + + i_nv = SvNV(*av_fetch(i_av, DBIprof_FIRST_CALLED, 1)); + tmp = *av_fetch(d_av, DBIprof_FIRST_CALLED, 1); + i_is_earlier = (!SvOK(tmp) || i_nv < SvNV(tmp)); + if (i_is_earlier) + sv_setnv(tmp, i_nv); + + i_nv = SvNV(*av_fetch(i_av, DBIprof_FIRST_TIME, 1)); + tmp = *av_fetch(d_av, DBIprof_FIRST_TIME, 1); + if (i_is_earlier || !SvOK(tmp)) { + /* If the increment has an earlier DBIprof_FIRST_CALLED + then we set the DBIprof_FIRST_TIME from the increment */ + sv_setnv(tmp, i_nv); + } + + i_nv = SvNV(*av_fetch(i_av, DBIprof_LAST_CALLED, 1)); + tmp = *av_fetch(d_av, DBIprof_LAST_CALLED, 1); + if (i_nv > SvNV(tmp)) sv_setnv(tmp, i_nv); +} + + +/* ----------------------------------------------------------------- */ +/* --- The DBI dispatcher. The heart of the perl DBI. --- */ + +XS(XS_DBI_dispatch); /* prototype to pass -Wmissing-prototypes */ +XS(XS_DBI_dispatch) +{ + dXSARGS; + dMY_CXT; + + SV *h = ST(0); /* the DBI handle we are working with */ + SV *st1 = ST(1); /* used in debugging */ + SV *st2 = ST(2); /* used in debugging */ + SV *orig_h = h; + SV *err_sv; + SV **tmp_svp; + SV **hook_svp = 0; + MAGIC *mg; + int gimme = GIMME; + I32 trace_flags = DBIS->debug; /* local copy may change during dispatch */ + I32 trace_level = (trace_flags & DBIc_TRACE_LEVEL_MASK); + int is_DESTROY; + meth_types meth_type; + int is_unrelated_to_Statement = 0; + int keep_error = FALSE; + UV ErrCount = UV_MAX; + int i, outitems; + int call_depth; + int is_nested_call; + NV profile_t1 = 0.0; + int is_orig_method_name = 1; + + const char *meth_name = GvNAME(CvGV(cv)); + dbi_ima_t *ima = (dbi_ima_t*)CvXSUBANY(cv).any_ptr; + U32 ima_flags; + imp_xxh_t *imp_xxh = NULL; + SV *imp_msv = Nullsv; + SV *qsv = Nullsv; /* quick result from a shortcut method */ + + +#ifdef BROKEN_DUP_ANY_PTR + if (ima->my_perl != my_perl) { + /* we couldn't dup the ima struct at clone time, so do it now */ + dbi_ima_t *nima; + Newx(nima, 1, dbi_ima_t); + *nima = *ima; /* structure copy */ + CvXSUBANY(cv).any_ptr = nima; + nima->stash = NULL; + nima->gv = NULL; + nima->my_perl = my_perl; + ima = nima; + } +#endif + + ima_flags = ima->flags; + meth_type = ima->meth_type; + if (trace_level >= 9) { + PerlIO *logfp = DBILOGFP; + PerlIO_printf(logfp,"%c >> %-11s DISPATCH (%s rc%ld/%ld @%ld g%x ima%lx pid#%ld)", + (PL_dirty?'!':' '), meth_name, neatsvpv(h,0), + (long)SvREFCNT(h), (SvROK(h) ? (long)SvREFCNT(SvRV(h)) : (long)-1), + (long)items, (int)gimme, (long)ima_flags, (long)PerlProc_getpid()); + PerlIO_puts(logfp, log_where(0, 0, " at ","\n", 1, (trace_level >= 3), (trace_level >= 4))); + PerlIO_flush(logfp); + } + + if ( ( (is_DESTROY=(meth_type == methtype_DESTROY))) ) { + /* note that croak()'s won't propagate, only append to $@ */ + keep_error = TRUE; + } + + /* If h is a tied hash ref, switch to the inner ref 'behind' the tie. + This means *all* DBI methods work with the inner (non-tied) ref. + This makes it much easier for methods to access the real hash + data (without having to go through FETCH and STORE methods) and + for tie and non-tie methods to call each other. + */ + if (SvROK(h) + && SvRMAGICAL(SvRV(h)) + && ( + ((mg=SvMAGIC(SvRV(h)))->mg_type == 'P') + || ((mg=mg_find(SvRV(h),'P')) != NULL) + ) + ) { + if (mg->mg_obj==NULL || !SvOK(mg->mg_obj) || SvRV(mg->mg_obj)==NULL) { /* maybe global destruction */ + if (trace_level >= 3) + PerlIO_printf(DBILOGFP, + "%c <> %s for %s ignored (inner handle gone)\n", + (PL_dirty?'!':' '), meth_name, neatsvpv(h,0)); + XSRETURN(0); + } + /* Distinguish DESTROY of tie (outer) from DESTROY of inner ref */ + /* This may one day be used to manually destroy extra internal */ + /* refs if the application ceases to use the handle. */ + if (is_DESTROY) { + imp_xxh = DBIh_COM(mg->mg_obj); +#ifdef DBI_USE_THREADS + if (imp_xxh && DBIc_THR_USER(imp_xxh) != my_perl) { + goto is_DESTROY_wrong_thread; + } +#endif + if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB) + clear_cached_kids(aTHX_ mg->mg_obj, imp_xxh, meth_name, trace_level); + /* XXX might be better to move this down to after call_depth has been + * incremented and then also SvREFCNT_dec(mg->mg_obj) to force an immediate + * DESTROY of the inner handle if there are no other refs to it. + * That way the inner DESTROY is properly flagged as a nested call, + * and the outer DESTROY gets profiled more accurately, and callbacks work. + */ + if (trace_level >= 3) { + PerlIO_printf(DBILOGFP, + "%c <> DESTROY(%s) ignored for outer handle (inner %s has ref cnt %ld)\n", + (PL_dirty?'!':' '), neatsvpv(h,0), neatsvpv(mg->mg_obj,0), + (long)SvREFCNT(SvRV(mg->mg_obj)) + ); + } + /* for now we ignore it since it'll be followed soon by */ + /* a destroy of the inner hash and that'll do the real work */ + + /* However, we must at least modify DBIc_MY_H() as that is */ + /* pointing (without a refcnt inc) to the scalar that is */ + /* being destroyed, so it'll contain random values later. */ + if (imp_xxh) + DBIc_MY_H(imp_xxh) = (HV*)SvRV(mg->mg_obj); /* inner (untied) HV */ + + XSRETURN(0); + } + h = mg->mg_obj; /* switch h to inner ref */ + ST(0) = h; /* switch handle on stack to inner ref */ + } + + imp_xxh = dbih_getcom2(aTHX_ h, 0); /* get common Internal Handle Attributes */ + if (!imp_xxh) { + if (meth_type == methtype_can) { /* ref($h)->can("foo") */ + const char *can_meth = SvPV_nolen(st1); + SV *rv = &PL_sv_undef; + GV *gv = gv_fetchmethod_autoload(gv_stashsv(orig_h,FALSE), can_meth, FALSE); + if (gv && isGV(gv)) + rv = sv_2mortal(newRV_inc((SV*)GvCV(gv))); + if (trace_level >= 1) { + PerlIO_printf(DBILOGFP," <- %s(%s) = %p\n", meth_name, can_meth, neatsvpv(rv,0)); + } + ST(0) = rv; + XSRETURN(1); + } + if (trace_level) + PerlIO_printf(DBILOGFP, "%c <> %s for %s ignored (no imp_data)\n", + (PL_dirty?'!':' '), meth_name, neatsvpv(h,0)); + if (!is_DESTROY) + warn("Can't call %s method on handle %s%s", meth_name, neatsvpv(h,0), + SvROK(h) ? " after take_imp_data()" : " (not a reference)"); + XSRETURN(0); + } + + if (DBIc_has(imp_xxh,DBIcf_Profile)) { + profile_t1 = dbi_time(); /* just get start time here */ + } + + if ((i = DBIc_DEBUGIV(imp_xxh))) { /* merge handle into global */ + I32 h_trace_level = (i & DBIc_TRACE_LEVEL_MASK); + if ( h_trace_level > trace_level ) + trace_level = h_trace_level; + trace_flags = (trace_flags & ~DBIc_TRACE_LEVEL_MASK) + | ( i & ~DBIc_TRACE_LEVEL_MASK) + | trace_level; + } + +#ifdef DBI_USE_THREADS +{ + PerlInterpreter * h_perl; + is_DESTROY_wrong_thread: + h_perl = DBIc_THR_USER(imp_xxh) ; + if (h_perl != my_perl) { + /* XXX could call a 'handle clone' method here?, for dbh's at least */ + if (is_DESTROY) { + if (trace_level >= 3) { + PerlIO_printf(DBILOGFP," DESTROY ignored because DBI %sh handle (%s) is owned by thread %p not current thread %p\n", + dbih_htype_name(DBIc_TYPE(imp_xxh)), HvNAME(DBIc_IMP_STASH(imp_xxh)), + (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ; + PerlIO_flush(DBILOGFP); + } + XSRETURN(0); /* don't DESTROY handle, if it is not our's !*/ + } + croak("%s %s failed: handle %d is owned by thread %lx not current thread %lx (%s)", + HvNAME(DBIc_IMP_STASH(imp_xxh)), meth_name, DBIc_TYPE(imp_xxh), + (unsigned long)h_perl, (unsigned long)my_perl, + "handles can't be shared between threads and your driver may need a CLONE method added"); + } +} +#endif + + /* Check method call against Internal Method Attributes */ + if (ima_flags) { + + if (ima_flags & (IMA_STUB|IMA_FUNC_REDIRECT|IMA_KEEP_ERR|IMA_KEEP_ERR_SUB|IMA_CLEAR_STMT)) { + + if (ima_flags & IMA_STUB) { + if (meth_type == methtype_can) { + const char *can_meth = SvPV_nolen(st1); + SV *dbi_msv = Nullsv; + /* find handle implementors method (GV or CV) */ + if ( (imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), can_meth, FALSE)) ) { + /* return DBI's CV, not the implementors CV (else we'd bypass dispatch) */ + /* and anyway, we may have hit a private method not part of the DBI */ + GV *gv = gv_fetchmethod_autoload(SvSTASH(SvRV(orig_h)), can_meth, FALSE); + if (gv && isGV(gv)) + dbi_msv = (SV*)GvCV(gv); + } + if (trace_level >= 1) { + PerlIO *logfp = DBILOGFP; + PerlIO_printf(logfp," <- %s(%s) = %p (%s %p)\n", meth_name, can_meth, (void*)dbi_msv, + (imp_msv && isGV(imp_msv)) ? HvNAME(GvSTASH(imp_msv)) : "?", (void*)imp_msv); + } + ST(0) = (dbi_msv) ? sv_2mortal(newRV_inc(dbi_msv)) : &PL_sv_undef; + XSRETURN(1); + } + XSRETURN(0); + } + if (ima_flags & IMA_FUNC_REDIRECT) { + /* XXX this doesn't redispatch, nor consider the IMA of the new method */ + SV *meth_name_sv = POPs; + PUTBACK; + --items; + if (!SvPOK(meth_name_sv) || SvNIOK(meth_name_sv)) + croak("%s->%s() invalid redirect method name %s", + neatsvpv(h,0), meth_name, neatsvpv(meth_name_sv,0)); + meth_name = SvPV_nolen(meth_name_sv); + meth_type = get_meth_type(meth_name); + is_orig_method_name = 0; + } + if (ima_flags & IMA_KEEP_ERR) + keep_error = TRUE; + if (ima_flags & IMA_KEEP_ERR_SUB + && DBIc_PARENT_COM(imp_xxh) && DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) > 0) + keep_error = TRUE; + if (ima_flags & IMA_CLEAR_STMT) { + /* don't use SvOK_off: dbh's Statement may be ref to sth's */ + (void)hv_store((HV*)SvRV(h), "Statement", 9, &PL_sv_undef, 0); + } + if (ima_flags & IMA_CLEAR_CACHED_KIDS) + clear_cached_kids(aTHX_ h, imp_xxh, meth_name, trace_flags); + + } + + if (ima_flags & IMA_HAS_USAGE) { + const char *err = NULL; + char msg[200]; + + if (ima->minargs && (items < ima->minargs + || (ima->maxargs>0 && items > ima->maxargs))) { + sprintf(msg, + "DBI %s: invalid number of arguments: got handle + %ld, expected handle + between %d and %d\n", + meth_name, (long)items-1, (int)ima->minargs-1, (int)ima->maxargs-1); + err = msg; + } + /* arg type checking could be added here later */ + if (err) { + croak("%sUsage: %s->%s(%s)", err, "$h", meth_name, + (ima->usage_msg) ? ima->usage_msg : "...?"); + } + } + } + + is_unrelated_to_Statement = ( (DBIc_TYPE(imp_xxh) == DBIt_ST) ? 0 + : (DBIc_TYPE(imp_xxh) == DBIt_DR) ? 1 + : (ima_flags & IMA_UNRELATED_TO_STMT) ); + + if (PL_tainting && items > 1 /* method call has args */ + && DBIc_is(imp_xxh, DBIcf_TaintIn) /* taint checks requested */ + && !(ima_flags & IMA_NO_TAINT_IN) + ) { + for(i=1; i < items; ++i) { + if (SvTAINTED(ST(i))) { + char buf[100]; + sprintf(buf,"parameter %d of %s->%s method call", + i, SvPV_nolen(h), meth_name); + PL_tainted = 1; /* needed for TAINT_PROPER to work */ + TAINT_PROPER(buf); /* die's */ + } + } + } + + /* record this inner handle for use by DBI::var::FETCH */ + if (is_DESTROY) { + + if (DBIc_TYPE(imp_xxh) <= DBIt_DB ) { /* is dbh or drh */ + imp_xxh_t *parent_imp; + + if (SvOK(DBIc_ERR(imp_xxh)) && (parent_imp = DBIc_PARENT_COM(imp_xxh)) + && !PL_dirty + ) { + /* copy err/errstr/state values to $DBI::err etc still work */ + sv_setsv(DBIc_ERR(parent_imp), DBIc_ERR(imp_xxh)); + sv_setsv(DBIc_ERRSTR(parent_imp), DBIc_ERRSTR(imp_xxh)); + sv_setsv(DBIc_STATE(parent_imp), DBIc_STATE(imp_xxh)); + } + } + + if (DBIc_AIADESTROY(imp_xxh)) { /* wants ineffective destroy after fork */ + if ((U32)PerlProc_getpid() != _imp2com(imp_xxh, std.pid)) + DBIc_set(imp_xxh, DBIcf_IADESTROY, 1); + } + if (DBIc_IADESTROY(imp_xxh)) { /* wants ineffective destroy */ + DBIc_ACTIVE_off(imp_xxh); + } + call_depth = 0; + } + else { + DBI_SET_LAST_HANDLE(h); + SAVEINT(DBIc_CALL_DEPTH(imp_xxh)); + call_depth = ++DBIc_CALL_DEPTH(imp_xxh); + + if (ima_flags & IMA_COPY_UP_STMT) { /* execute() */ + SV *parent = DBIc_PARENT_H(imp_xxh); + SV *tmp_sv = *hv_fetch((HV*)SvRV(h), "Statement", 9, 1); + /* XXX sv_copy() if Profiling? */ + (void)hv_store((HV*)SvRV(parent), "Statement", 9, SvREFCNT_inc(tmp_sv), 0); + } + } + + is_nested_call = ( call_depth > 1 || (DBIc_PARENT_COM(imp_xxh) && (DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) >= 1)) ); + + + /* --- dispatch --- */ + + if (!keep_error && meth_type != methtype_set_err) { + SV *err_sv; + if (trace_level && SvOK(err_sv=DBIc_ERR(imp_xxh))) { + PerlIO *logfp = DBILOGFP; + PerlIO_printf(logfp, " !! %s: %s CLEARED by call to %s method\n", + SvTRUE(err_sv) ? "ERROR" : strlen(SvPV_nolen(err_sv)) ? "warn" : "info", + neatsvpv(DBIc_ERR(imp_xxh),0), meth_name); + } + DBIh_CLEAR_ERROR(imp_xxh); + } + else { /* we check for change in ErrCount during call */ + ErrCount = DBIc_ErrCount(imp_xxh); + } + + if (DBIc_has(imp_xxh,DBIcf_Callbacks) + && (tmp_svp = hv_fetch((HV*)SvRV(h), "Callbacks", 9, 0)) + && ( (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), meth_name, strlen(meth_name), 0)) + /* the "*" fallback callback only applies to non-nested calls + * and also doesn't apply to the 'set_err' or DESTROY methods. + * Nor during global destruction. + * Other restrictions may be added over time. + * It's an undocumented hack. + */ + || (!is_nested_call && !PL_dirty && meth_type != methtype_set_err && + meth_type != methtype_DESTROY && + (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), "*", 1, 0)) + ) + ) + && SvROK(*hook_svp) + ) { + SV *orig_defsv; + SV *code = SvRV(*hook_svp); + I32 skip_dispatch = 0; + if (trace_level) + PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked\n", + (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0)); + + /* we don't use ENTER,SAVETMPS & FREETMPS,LEAVE because we may need mortal + * results to live long enough to be returned to our caller + */ + /* we want to localize $_ for the callback but can't just do that alone + * because we're not using SAVETMPS & FREETMPS, so we have to get sneaky. + * We still localize, so we're safe from the callback dieing, + * but after the callback we manually restore the original $_. + */ + orig_defsv = DEFSV; /* remember the current $_ */ + SAVE_DEFSV; /* local($_) = $method_name */ + DEFSV = sv_2mortal(newSVpv(meth_name,0)); + + EXTEND(SP, items+1); + PUSHMARK(SP); + PUSHs(h); /* push inner handle, then others params */ + for (i=1; i < items; ++i) { /* start at 1 to skip handle */ + PUSHs( ST(i) ); + } + PUTBACK; + outitems = call_sv(code, G_ARRAY); /* call the callback code */ + SPAGAIN; + + /* The callback code can undef $_ to indicate to skip dispatch */ + skip_dispatch = !SvOK(DEFSV); + /* put $_ back now, but with an incremented ref count to compensate + * for the ref count decrement that will happen when we exit the scope. + */ + DEFSV = SvREFCNT_inc(orig_defsv); + + if (trace_level) + PerlIO_printf(DBILOGFP, "%c }} %s callback %s returned%s\n", + (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0), + skip_dispatch ? ", actual method will not be called" : "" + ); + if (skip_dispatch) { /* XXX experimental */ + int ix = outitems; + /* copy the new items down to the destination list */ + while (ix-- > 0) { + if(0)warn("\tcopy down %d: %s overwriting %s\n", ix, SvPV_nolen(TOPs), SvPV_nolen(ST(ix)) ); + ST(ix) = POPs; + } + imp_msv = *hook_svp; /* for trace and profile */ + goto post_dispatch; + } + else { + if (outitems != 0) + die("Callback for %s returned %d values but must not return any (temporary restriction in current version)", + meth_name, (int)outitems); + /* POP's and PUTBACK? to clear stack */ + } + } + + /* set Executed after Callbacks so it's not set if callback elects to skip the method */ + if (ima_flags & IMA_EXECUTE) { + imp_xxh_t *parent = DBIc_PARENT_COM(imp_xxh); + DBIc_on(imp_xxh, DBIcf_Executed); + if (parent) + DBIc_on(parent, DBIcf_Executed); + } + + /* The "quick_FETCH" logic... */ + /* Shortcut for fetching attributes to bypass method call overheads */ + if (meth_type == methtype_FETCH && !DBIc_COMPAT(imp_xxh)) { + STRLEN kl; + const char *key = SvPV(st1, kl); + SV **attr_svp; + if (*key != '_' && (attr_svp=hv_fetch((HV*)SvRV(h), key, kl, 0))) { + qsv = *attr_svp; + /* disable FETCH from cache for special attributes */ + if (SvROK(qsv) && SvTYPE(SvRV(qsv))==SVt_PVHV && *key=='D' && + ( (kl==6 && DBIc_TYPE(imp_xxh)==DBIt_DB && strEQ(key,"Driver")) + || (kl==8 && DBIc_TYPE(imp_xxh)==DBIt_ST && strEQ(key,"Database")) ) + ) { + qsv = Nullsv; + } + /* disable profiling of FETCH of Profile data */ + if (*key == 'P' && strEQ(key, "Profile")) + profile_t1 = 0.0; + } + if (qsv) { /* skip real method call if we already have a 'quick' value */ + ST(0) = sv_mortalcopy(qsv); + outitems = 1; + goto post_dispatch; + } + } + + { + CV *meth_cv; +#ifdef DBI_save_hv_fetch_ent + HE save_mh; + if (meth_type == methtype_FETCH) + save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */ +#endif + + if (trace_flags) { + SAVEI32(DBIS->debug); /* fall back to orig value later */ + DBIS->debug = trace_flags; /* make new value global (for now) */ + if (ima) { + /* enabling trace via flags takes precedence over disabling due to min level */ + if ((trace_flags & DBIc_TRACE_FLAGS_MASK) & (ima->method_trace & DBIc_TRACE_FLAGS_MASK)) + trace_level = (trace_level < 2) ? 2 : trace_level; /* min */ + else + if (trace_level < (DBIc_TRACE_LEVEL_MASK & ima->method_trace)) + trace_level = 0; /* silence dispatch log for this method */ + } + } + + if (is_orig_method_name + && ima->stash == DBIc_IMP_STASH(imp_xxh) + && ima->generation == PL_sub_generation + + MY_cache_gen(DBIc_IMP_STASH(imp_xxh)) + ) + imp_msv = (SV*)ima->gv; + else { + imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), + meth_name, FALSE); + if (is_orig_method_name) { + /* clear stale entry, if any */ + SvREFCNT_dec(ima->stash); + SvREFCNT_dec(ima->gv); + if (!imp_msv) { + ima->stash = NULL; + ima->gv = NULL; + } + else { + ima->stash = (HV*)SvREFCNT_inc(DBIc_IMP_STASH(imp_xxh)); + ima->gv = (GV*)SvREFCNT_inc(imp_msv); + ima->generation = PL_sub_generation + + MY_cache_gen(DBIc_IMP_STASH(imp_xxh)); + } + } + } + + /* if method was a 'func' then try falling back to real 'func' method */ + if (!imp_msv && (ima_flags & IMA_FUNC_REDIRECT)) { + imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), "func", FALSE); + if (imp_msv) { + /* driver does have func method so undo the earlier 'func' stack changes */ + PUSHs(sv_2mortal(newSVpv(meth_name,0))); + PUTBACK; + ++items; + meth_name = "func"; + meth_type = methtype_ordinary; + } + } + + if (trace_level >= (is_nested_call ? 4 : 2)) { + PerlIO *logfp = DBILOGFP; + /* Full pkg method name (or just meth_name for ANON CODE) */ + const char *imp_meth_name = (imp_msv && isGV(imp_msv)) ? GvNAME(imp_msv) : meth_name; + HV *imp_stash = DBIc_IMP_STASH(imp_xxh); + PerlIO_printf(logfp, "%c -> %s ", + call_depth>1 ? '0'+call_depth-1 : (PL_dirty?'!':' '), imp_meth_name); + if (imp_meth_name[0] == 'A' && strEQ(imp_meth_name,"AUTOLOAD")) + PerlIO_printf(logfp, "\"%s\" ", meth_name); + if (imp_msv && isGV(imp_msv) && GvSTASH(imp_msv) != imp_stash) + PerlIO_printf(logfp, "in %s ", HvNAME(GvSTASH(imp_msv))); + PerlIO_printf(logfp, "for %s (%s", HvNAME(imp_stash), + SvPV_nolen(orig_h)); + if (h != orig_h) /* show inner handle to aid tracing */ + PerlIO_printf(logfp, "~0x%lx", (long)SvRV(h)); + else PerlIO_printf(logfp, "~INNER"); + for(i=1; i<items; ++i) { + PerlIO_printf(logfp," %s", + (ima && i==ima->hidearg) ? "****" : neatsvpv(ST(i),0)); + } +#ifdef DBI_USE_THREADS + PerlIO_printf(logfp, ") thr#%p\n", (void*)DBIc_THR_USER(imp_xxh)); +#else + PerlIO_printf(logfp, ")\n"); +#endif + PerlIO_flush(logfp); + } + + if (!imp_msv || ! ((meth_cv = GvCV(imp_msv))) ) { + if (PL_dirty || is_DESTROY) { + outitems = 0; + goto post_dispatch; + } + if (ima_flags & IMA_NOT_FOUND_OKAY) { + outitems = 0; + goto post_dispatch; + } + croak("Can't locate DBI object method \"%s\" via package \"%s\"", + meth_name, HvNAME(DBIc_IMP_STASH(imp_xxh))); + } + + PUSHMARK(mark); /* mark arguments again so we can pass them on */ + + /* Note: the handle on the stack is still an object blessed into a + * DBI::* class and not the DBD::*::* class whose method is being + * invoked. This is correct and should be largely transparent. + */ + + /* SHORT-CUT ALERT! */ + if (use_xsbypass && CvISXSUB(meth_cv) && CvXSUB(meth_cv)) { + + /* If we are calling an XSUB we jump directly to its C code and + * bypass perl_call_sv(), pp_entersub() etc. This is fast. + * This code is based on a small section of pp_entersub(). + */ + (void)(*CvXSUB(meth_cv))(aTHXo_ meth_cv); /* Call the C code directly */ + + if (gimme == G_SCALAR) { /* Enforce sanity in scalar context */ + if (ax != PL_stack_sp - PL_stack_base ) { /* outitems != 1 */ + ST(0) = + (ax > PL_stack_sp - PL_stack_base) + ? &PL_sv_undef /* outitems == 0 */ + : *PL_stack_sp; /* outitems > 1 */ + PL_stack_sp = PL_stack_base + ax; + } + outitems = 1; + } + else { + outitems = PL_stack_sp - (PL_stack_base + ax - 1); + } + + } + else { + /* sv_dump(imp_msv); */ + outitems = call_sv((SV*)meth_cv, + (is_DESTROY ? gimme | G_EVAL | G_KEEPERR : gimme) ); + } + + XSprePUSH; /* reset SP to base of stack frame */ + +#ifdef DBI_save_hv_fetch_ent + if (meth_type == methtype_FETCH) + PL_hv_fetch_ent_mh = save_mh; /* see start of block */ +#endif + } + + post_dispatch: + + if (is_DESTROY && DBI_IS_LAST_HANDLE(h)) { /* if destroying _this_ handle */ + SV *lhp = DBIc_PARENT_H(imp_xxh); + if (lhp && SvROK(lhp)) { + DBI_SET_LAST_HANDLE(lhp); + } + else { + DBI_UNSET_LAST_HANDLE; + } + } + + /* if we didn't clear err before the call, check if ErrCount has gone up */ + /* if so, we turn off keep_error so error is acted on */ + if (keep_error && DBIc_ErrCount(imp_xxh) > ErrCount) + keep_error = 0; + + err_sv = DBIc_ERR(imp_xxh); + + if (trace_level >= (is_nested_call ? 3 : 1)) { + PerlIO *logfp = DBILOGFP; + const int is_fetch = (meth_type == methtype_fetch_star && DBIc_TYPE(imp_xxh)==DBIt_ST); + const int row_count = (is_fetch) ? DBIc_ROW_COUNT((imp_sth_t*)imp_xxh) : 0; + if (is_fetch && row_count>=2 && trace_level<=4 && SvOK(ST(0))) { + /* skip the 'middle' rows to reduce output */ + goto skip_meth_return_trace; + } + if (SvOK(err_sv)) { + PerlIO_printf(logfp, " %s %s %s %s (err#%ld)\n", (keep_error) ? " " : "!!", + SvTRUE(err_sv) ? "ERROR:" : strlen(SvPV_nolen(err_sv)) ? "warn:" : "info:", + neatsvpv(err_sv,0), neatsvpv(DBIc_ERRSTR(imp_xxh),0), (long)DBIc_ErrCount(imp_xxh)); + } + PerlIO_printf(logfp,"%c%c <%c %s", + (call_depth > 1) ? '0'+call_depth-1 : (PL_dirty?'!':' '), + (DBIc_is(imp_xxh, DBIcf_TaintIn|DBIcf_TaintOut)) ? 'T' : ' ', + (qsv) ? '>' : '-', + meth_name); + if (trace_level==1 && (items>=2||is_DESTROY)) { /* make level 1 more useful */ + /* we only have the first two parameters available here */ + if (is_DESTROY) /* show handle as first arg to DESTROY */ + /* want to show outer handle so trace makes sense */ + /* but outer handle has been destroyed so we fake it */ + PerlIO_printf(logfp,"(%s=HASH(0x%p)", HvNAME(SvSTASH(SvRV(orig_h))), (void*)DBIc_MY_H(imp_xxh)); + else + PerlIO_printf(logfp,"(%s", neatsvpv(st1,0)); + if (items >= 3) + PerlIO_printf(logfp,", %s", neatsvpv(st2,0)); + PerlIO_printf(logfp,"%s)", (items > 3) ? ", ..." : ""); + } + + if (gimme & G_ARRAY) + PerlIO_printf(logfp,"= ("); + else PerlIO_printf(logfp,"="); + for(i=0; i < outitems; ++i) { + SV *s = ST(i); + if ( SvROK(s) && SvTYPE(SvRV(s))==SVt_PVAV) { + AV *av = (AV*)SvRV(s); + int avi; + int avi_last = SvIV(DBIS->neatsvpvlen) / 10; + if (avi_last < 39) + avi_last = 39; + PerlIO_printf(logfp, " ["); + for (avi=0; avi <= AvFILL(av); ++avi) { + PerlIO_printf(logfp, " %s", neatsvpv(AvARRAY(av)[avi],0)); + if (avi >= avi_last && AvFILL(av) - avi > 1) { + PerlIO_printf(logfp, " ... %ld others skipped", AvFILL(av) - avi); + break; + } + } + PerlIO_printf(logfp, " ]"); + } + else { + PerlIO_printf(logfp, " %s", neatsvpv(s,0)); + if ( SvROK(s) && SvTYPE(SvRV(s))==SVt_PVHV && !SvOBJECT(SvRV(s)) ) + PerlIO_printf(logfp, "%ldkeys", (long)HvKEYS(SvRV(s))); + } + } + if (gimme & G_ARRAY) { + PerlIO_printf(logfp," ) [%d items]", outitems); + } + if (is_fetch && row_count) { + PerlIO_printf(logfp," row%d", row_count); + } + if (qsv) /* flag as quick and peek at the first arg (still on the stack) */ + PerlIO_printf(logfp," (%s from cache)", neatsvpv(st1,0)); + else if (!imp_msv) + PerlIO_printf(logfp," (not implemented)"); + /* XXX add flag to show pid here? */ + /* add file and line number information */ + PerlIO_puts(logfp, log_where(0, 0, " at ", "\n", 1, (trace_level >= 3), (trace_level >= 4))); + skip_meth_return_trace: + PerlIO_flush(logfp); + } + + if (ima_flags & IMA_END_WORK) { /* commit() or rollback() */ + /* XXX does not consider if the method call actually worked or not */ + DBIc_off(imp_xxh, DBIcf_Executed); + + if (DBIc_has(imp_xxh, DBIcf_BegunWork)) { + DBIc_off(imp_xxh, DBIcf_BegunWork); + if (!DBIc_has(imp_xxh, DBIcf_AutoCommit)) { + /* We only get here if the driver hasn't implemented their own code */ + /* for begin_work, or has but hasn't correctly turned AutoCommit */ + /* back on in their commit or rollback code. So we have to do it. */ + /* This is bad because it'll probably trigger a spurious commit() */ + /* and may mess up the error handling below for the commit/rollback */ + PUSHMARK(SP); + XPUSHs(h); + XPUSHs(sv_2mortal(newSVpv("AutoCommit",0))); + XPUSHs(&PL_sv_yes); + PUTBACK; + call_method("STORE", G_DISCARD); + SPAGAIN; + } + } + } + + if (PL_tainting + && DBIc_is(imp_xxh, DBIcf_TaintOut) /* taint checks requested */ + /* XXX this would taint *everything* being returned from *any* */ + /* method that doesn't have IMA_NO_TAINT_OUT set. */ + /* DISABLED: just tainting fetched data in get_fbav seems ok */ + && 0/* XXX disabled*/ /* !(ima_flags & IMA_NO_TAINT_OUT) */ + ) { + dTHR; + TAINT; /* affects sv_setsv()'s within same perl statement */ + for(i=0; i < outitems; ++i) { + I32 avi; + char *p; + SV *s; + SV *agg = ST(i); + if ( !SvROK(agg) ) + continue; + agg = SvRV(agg); +#define DBI_OUT_TAINTABLE(s) (!SvREADONLY(s) && !SvTAINTED(s)) + switch (SvTYPE(agg)) { + case SVt_PVAV: + for(avi=0; avi <= AvFILL((AV*)agg); ++avi) { + s = AvARRAY((AV*)agg)[avi]; + if (DBI_OUT_TAINTABLE(s)) + SvTAINTED_on(s); + } + break; + case SVt_PVHV: + hv_iterinit((HV*)agg); + while( (s = hv_iternextsv((HV*)agg, &p, &avi)) ) { + if (DBI_OUT_TAINTABLE(s)) + SvTAINTED_on(s); + } + break; + default: + if (DBIc_WARN(imp_xxh)) { + PerlIO_printf(DBILOGFP,"Don't know how to taint contents of returned %s (type %d)\n", + neatsvpv(agg,0), (int)SvTYPE(agg)); + } + } + } + } + + /* if method returned a new handle, and that handle has an error on it + * then copy the error up into the parent handle + */ + if (ima_flags & IMA_IS_FACTORY && SvROK(ST(0))) { + SV *h_new = ST(0); + D_impdata(imp_xxh_new, imp_xxh_t, h_new); + if (SvOK(DBIc_ERR(imp_xxh_new))) { + set_err_sv(h, imp_xxh, DBIc_ERR(imp_xxh_new), DBIc_ERRSTR(imp_xxh_new), DBIc_STATE(imp_xxh_new), &PL_sv_no); + } + } + + if ( !keep_error /* is a new err/warn/info */ + && !is_nested_call /* skip nested (internal) calls */ + && ( + /* is an error and has RaiseError|PrintError|HandleError set */ + (SvTRUE(err_sv) && DBIc_has(imp_xxh, DBIcf_RaiseError|DBIcf_PrintError|DBIcf_HandleError)) + /* is a warn (not info) and has PrintWarn set */ + || ( SvOK(err_sv) && strlen(SvPV_nolen(err_sv)) && DBIc_has(imp_xxh, DBIcf_PrintWarn)) + ) + ) { + SV *msg; + SV **statement_svp = NULL; + const int is_warning = (!SvTRUE(err_sv) && strlen(SvPV_nolen(err_sv))==1); + const char *err_meth_name = meth_name; + char intro[200]; + + if (meth_type == methtype_set_err) { + SV **sem_svp = hv_fetch((HV*)SvRV(h), "dbi_set_err_method", 18, GV_ADDWARN); + if (SvOK(*sem_svp)) + err_meth_name = SvPV_nolen(*sem_svp); + } + + /* XXX change to vsprintf into sv directly */ + sprintf(intro,"%s %s %s: ", HvNAME(DBIc_IMP_STASH(imp_xxh)), err_meth_name, + SvTRUE(err_sv) ? "failed" : is_warning ? "warning" : "information"); + msg = sv_2mortal(newSVpv(intro,0)); + if (SvOK(DBIc_ERRSTR(imp_xxh))) + sv_catsv(msg, DBIc_ERRSTR(imp_xxh)); + else + sv_catpvf(msg, "(err=%s, errstr=undef, state=%s)", + neatsvpv(DBIc_ERR(imp_xxh),0), neatsvpv(DBIc_STATE(imp_xxh),0) ); + + if ( DBIc_has(imp_xxh, DBIcf_ShowErrorStatement) + && !is_unrelated_to_Statement + && (DBIc_TYPE(imp_xxh) == DBIt_ST || ima_flags & IMA_SHOW_ERR_STMT) + && (statement_svp = hv_fetch((HV*)SvRV(h), "Statement", 9, 0)) + && statement_svp && SvOK(*statement_svp) + ) { + SV **svp = 0; + sv_catpv(msg, " [for Statement \""); + sv_catsv(msg, *statement_svp); + + /* fetch from tied outer handle to trigger FETCH magic */ + /* could add DBIcf_ShowErrorParams (default to on?) */ + if (!(ima_flags & IMA_HIDE_ERR_PARAMVALUES)) { + svp = hv_fetch((HV*)DBIc_MY_H(imp_xxh),"ParamValues",11,FALSE); + if (svp && SvMAGICAL(*svp)) + mg_get(*svp); /* XXX may recurse, may croak. could use eval */ + } + if (svp && SvRV(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV && HvKEYS(SvRV(*svp))>0 ) { + SV *param_values_sv = sv_2mortal(_join_hash_sorted((HV*)SvRV(*svp), "=",1, ", ",2, 1, -1)); + sv_catpv(msg, "\" with ParamValues: "); + sv_catsv(msg, param_values_sv); + sv_catpvn(msg, "]", 1); + } + else { + sv_catpv(msg, "\"]"); + } + } + + if (0) { + COP *cop = dbi_caller_cop(); + if (cop && (CopLINE(cop) != CopLINE(PL_curcop) || CopFILEGV(cop) != CopFILEGV(PL_curcop))) { + dbi_caller_string(msg, cop, " called via ", 1, 0); + } + } + + hook_svp = NULL; + if ( SvTRUE(err_sv) + && DBIc_has(imp_xxh, DBIcf_HandleError) + && (hook_svp = hv_fetch((HV*)SvRV(h),"HandleError",11,0)) + && hook_svp && SvOK(*hook_svp) + ) { + dSP; + PerlIO *logfp = DBILOGFP; + IV items; + SV *status; + SV *result; /* point to result SV that's pointed to by the stack */ + if (outitems) { + result = *(sp-outitems+1); + if (SvREADONLY(result)) { + *(sp-outitems+1) = result = sv_2mortal(newSVsv(result)); + } + } + else { + result = sv_newmortal(); + } + if (trace_level) + PerlIO_printf(logfp," -> HandleError on %s via %s%s%s%s\n", + neatsvpv(h,0), neatsvpv(*hook_svp,0), + (!outitems ? "" : " ("), + (!outitems ? "" : neatsvpv(result ,0)), + (!outitems ? "" : ")") + ); + PUSHMARK(SP); + XPUSHs(msg); + XPUSHs(sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh)))); + XPUSHs( result ); + PUTBACK; + items = call_sv(*hook_svp, G_SCALAR); + SPAGAIN; + status = (items) ? POPs : &PL_sv_undef; + PUTBACK; + if (trace_level) + PerlIO_printf(logfp," <- HandleError= %s%s%s%s\n", + neatsvpv(status,0), + (!outitems ? "" : " ("), + (!outitems ? "" : neatsvpv(result,0)), + (!outitems ? "" : ")") + ); + if (!SvTRUE(status)) /* handler says it didn't handle it, so... */ + hook_svp = 0; /* pretend we didn't have a handler... */ + } + + if (profile_t1) { /* see also dbi_profile() call a few lines below */ + SV *statement_sv = (is_unrelated_to_Statement) ? &PL_sv_no : &PL_sv_undef; + dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv, + profile_t1, dbi_time()); + } + if (is_warning) { + if (DBIc_has(imp_xxh, DBIcf_PrintWarn)) + warn("%s", SvPV_nolen(msg)); + } + else if (!hook_svp && SvTRUE(err_sv)) { + if (DBIc_has(imp_xxh, DBIcf_PrintError)) + warn("%s", SvPV_nolen(msg)); + if (DBIc_has(imp_xxh, DBIcf_RaiseError)) + croak("%s", SvPV_nolen(msg)); + } + } + else if (profile_t1) { /* see also dbi_profile() call a few lines above */ + SV *statement_sv = (is_unrelated_to_Statement) ? &PL_sv_no : &PL_sv_undef; + dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv, + profile_t1, dbi_time()); + } + XSRETURN(outitems); +} + + + +/* -------------------------------------------------------------------- */ + +/* comment and placeholder styles to accept and return */ + +#define DBIpp_cm_cs 0x000001 /* C style */ +#define DBIpp_cm_hs 0x000002 /* # */ +#define DBIpp_cm_dd 0x000004 /* -- */ +#define DBIpp_cm_br 0x000008 /* {} */ +#define DBIpp_cm_dw 0x000010 /* '-- ' dash dash whitespace */ +#define DBIpp_cm_XX 0x00001F /* any of the above */ + +#define DBIpp_ph_qm 0x000100 /* ? */ +#define DBIpp_ph_cn 0x000200 /* :1 */ +#define DBIpp_ph_cs 0x000400 /* :name */ +#define DBIpp_ph_sp 0x000800 /* %s (as return only, not accept) */ +#define DBIpp_ph_XX 0x000F00 /* any of the above */ + +#define DBIpp_st_qq 0x010000 /* '' char escape */ +#define DBIpp_st_bs 0x020000 /* \ char escape */ +#define DBIpp_st_XX 0x030000 /* any of the above */ + +#define DBIpp_L_BRACE '{' +#define DBIpp_R_BRACE '}' +#define PS_accept(flag) DBIbf_has(ps_accept,(flag)) +#define PS_return(flag) DBIbf_has(ps_return,(flag)) + +SV * +preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void *foo) +{ + dTHX; + D_imp_xxh(dbh); +/* + The idea here is that ps_accept defines which constructs to + recognize (accept) as valid in the source string (other + constructs are ignored), and ps_return defines which + constructs are valid to return in the result string. + + If a construct that is valid in the input is also valid in the + output then it's simply copied. If it's not valid in the output + then it's editied into one of the valid forms (ideally the most + 'standard' and/or information preserving one). + + For example, if ps_accept includes '--' style comments but + ps_return doesn't, but ps_return does include '#' style + comments then any '--' style comments would be rewritten as '#' + style comments. + + Similarly for placeholders. DBD::Oracle, for example, would say + '?', ':1' and ':name' are all acceptable input, but only + ':name' should be returned. + + (There's a tricky issue with the '--' comment style because it can + clash with valid syntax, i.e., "... set foo=foo--1 ..." so it + would be *bad* to misinterpret that as the start of a comment. + Perhaps we need a DBIpp_cm_dw (for dash-dash-whitespace) style + to allow for that.) + + Also, we'll only support DBIpp_cm_br as an input style. And + even then, only with reluctance. We may (need to) drop it when + we add support for odbc escape sequences. +*/ + int idx = 1; + + char in_quote = '\0'; + char in_comment = '\0'; + char rt_comment = '\0'; + char *dest, *start; + const char *src; + const char *style = "", *laststyle = '\0'; + SV *new_stmt_sv; + + (void)foo; + + if (!(ps_return | DBIpp_ph_XX)) { /* no return ph type specified */ + ps_return |= ps_accept | DBIpp_ph_XX; /* so copy from ps_accept */ + } + + /* XXX this allocation strategy won't work when we get to more advanced stuff */ + new_stmt_sv = newSV(strlen(statement) * 3); + sv_setpv(new_stmt_sv,""); + src = statement; + dest = SvPVX(new_stmt_sv); + + while( *src ) + { + if (*src == '%' && PS_return(DBIpp_ph_sp)) + *dest++ = '%'; + + if (in_comment) + { + if ( (in_comment == '-' && (*src == '\n' || *(src+1) == '\0')) + || (in_comment == '#' && (*src == '\n' || *(src+1) == '\0')) + || (in_comment == DBIpp_L_BRACE && *src == DBIpp_R_BRACE) /* XXX nesting? */ + || (in_comment == '/' && *src == '*' && *(src+1) == '/') + ) { + switch (rt_comment) { + case '/': *dest++ = '*'; *dest++ = '/'; break; + case '-': *dest++ = '\n'; break; + case '#': *dest++ = '\n'; break; + case DBIpp_L_BRACE: *dest++ = DBIpp_R_BRACE; break; + case '\0': /* ensure deleting a comment doesn't join two tokens */ + if (in_comment=='/' || in_comment==DBIpp_L_BRACE) + *dest++ = ' '; /* ('-' and '#' styles use the newline) */ + break; + } + if (in_comment == '/') + src++; + src += (*src != '\n' || *(dest-1)=='\n') ? 1 : 0; + in_comment = '\0'; + rt_comment = '\0'; + } + else + if (rt_comment) + *dest++ = *src++; + else + src++; /* delete (don't copy) the comment */ + continue; + } + + if (in_quote) + { + if (*src == in_quote) { + in_quote = 0; + } + *dest++ = *src++; + continue; + } + + /* Look for comments */ + if (*src == '-' && *(src+1) == '-' && + (PS_accept(DBIpp_cm_dd) || (*(src+2) == ' ' && PS_accept(DBIpp_cm_dw))) + ) + { + in_comment = *src; + src += 2; /* skip past 2nd char of double char delimiters */ + if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) { + *dest++ = rt_comment = '-'; + *dest++ = '-'; + if (PS_return(DBIpp_cm_dw) && *src!=' ') + *dest++ = ' '; /* insert needed white space */ + } + else if (PS_return(DBIpp_cm_cs)) { + *dest++ = rt_comment = '/'; + *dest++ = '*'; + } + else if (PS_return(DBIpp_cm_hs)) { + *dest++ = rt_comment = '#'; + } + else if (PS_return(DBIpp_cm_br)) { + *dest++ = rt_comment = DBIpp_L_BRACE; + } + continue; + } + else if (*src == '/' && *(src+1) == '*' && PS_accept(DBIpp_cm_cs)) + { + in_comment = *src; + src += 2; /* skip past 2nd char of double char delimiters */ + if (PS_return(DBIpp_cm_cs)) { + *dest++ = rt_comment = '/'; + *dest++ = '*'; + } + else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) { + *dest++ = rt_comment = '-'; + *dest++ = '-'; + if (PS_return(DBIpp_cm_dw)) *dest++ = ' '; + } + else if (PS_return(DBIpp_cm_hs)) { + *dest++ = rt_comment = '#'; + } + else if (PS_return(DBIpp_cm_br)) { + *dest++ = rt_comment = DBIpp_L_BRACE; + } + continue; + } + else if (*src == '#' && PS_accept(DBIpp_cm_hs)) + { + in_comment = *src; + src++; + if (PS_return(DBIpp_cm_hs)) { + *dest++ = rt_comment = '#'; + } + else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) { + *dest++ = rt_comment = '-'; + *dest++ = '-'; + if (PS_return(DBIpp_cm_dw)) *dest++ = ' '; + } + else if (PS_return(DBIpp_cm_cs)) { + *dest++ = rt_comment = '/'; + *dest++ = '*'; + } + else if (PS_return(DBIpp_cm_br)) { + *dest++ = rt_comment = DBIpp_L_BRACE; + } + continue; + } + else if (*src == DBIpp_L_BRACE && PS_accept(DBIpp_cm_br)) + { + in_comment = *src; + src++; + if (PS_return(DBIpp_cm_br)) { + *dest++ = rt_comment = DBIpp_L_BRACE; + } + else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) { + *dest++ = rt_comment = '-'; + *dest++ = '-'; + if (PS_return(DBIpp_cm_dw)) *dest++ = ' '; + } + else if (PS_return(DBIpp_cm_cs)) { + *dest++ = rt_comment = '/'; + *dest++ = '*'; + } + else if (PS_return(DBIpp_cm_hs)) { + *dest++ = rt_comment = '#'; + } + continue; + } + + if ( !(*src==':' && (PS_accept(DBIpp_ph_cn) || PS_accept(DBIpp_ph_cs))) + && !(*src=='?' && PS_accept(DBIpp_ph_qm)) + ){ + if (*src == '\'' || *src == '"') + in_quote = *src; + *dest++ = *src++; + continue; + } + + /* only here for : or ? outside of a comment or literal */ + + start = dest; /* save name inc colon */ + *dest++ = *src++; /* copy and move past first char */ + + if (*start == '?') /* X/Open Standard */ + { + style = "?"; + + if (PS_return(DBIpp_ph_qm)) + ; + else if (PS_return(DBIpp_ph_cn)) { /* '?' -> ':p1' (etc) */ + sprintf(start,":p%d", idx++); + dest = start+strlen(start); + } + else if (PS_return(DBIpp_ph_sp)) { /* '?' -> '%s' */ + *start = '%'; + *dest++ = 's'; + } + } + else if (isDIGIT(*src)) { /* :1 */ + const int pln = atoi(src); + style = ":1"; + + if (PS_return(DBIpp_ph_cn)) { /* ':1'->':p1' */ + idx = pln; + *dest++ = 'p'; + while(isDIGIT(*src)) + *dest++ = *src++; + } + else if (PS_return(DBIpp_ph_qm) /* ':1' -> '?' */ + || PS_return(DBIpp_ph_sp) /* ':1' -> '%s' */ + ) { + PS_return(DBIpp_ph_qm) ? sprintf(start,"?") : sprintf(start,"%%s"); + dest = start + strlen(start); + if (pln != idx) { + char buf[99]; + sprintf(buf, "preparse found placeholder :%d out of sequence, expected :%d", pln, idx); + set_err_char(dbh, imp_xxh, "1", 1, buf, 0, "preparse"); + return &PL_sv_undef; + } + while(isDIGIT(*src)) src++; + idx++; + } + } + else if (isALNUM(*src)) /* :name */ + { + style = ":name"; + + if (PS_return(DBIpp_ph_cs)) { + ; + } + else if (PS_return(DBIpp_ph_qm) /* ':name' -> '?' */ + || PS_return(DBIpp_ph_sp) /* ':name' -> '%s' */ + ) { + PS_return(DBIpp_ph_qm) ? sprintf(start,"?") : sprintf(start,"%%s"); + dest = start + strlen(start); + while (isALNUM(*src)) /* consume name, includes '_' */ + src++; + } + } + /* perhaps ':=' PL/SQL construct */ + else { continue; } + + *dest = '\0'; /* handy for debugging */ + + if (laststyle && style != laststyle) { + char buf[99]; + sprintf(buf, "preparse found mixed placeholder styles (%s / %s)", style, laststyle); + set_err_char(dbh, imp_xxh, "1", 1, buf, 0, "preparse"); + return &PL_sv_undef; + } + laststyle = style; + } + *dest = '\0'; + + /* warn about probable parsing errors, but continue anyway (returning processed string) */ + switch (in_quote) + { + case '\'': + set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated single-quoted string", 0, "preparse"); + break; + case '\"': + set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated double-quoted string", 0, "preparse"); + break; + } + switch (in_comment) + { + case DBIpp_L_BRACE: + set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated bracketed {...} comment", 0, "preparse"); + break; + case '/': + set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated bracketed C-style comment", 0, "preparse"); + break; + } + + SvCUR_set(new_stmt_sv, strlen(SvPVX(new_stmt_sv))); + *SvEND(new_stmt_sv) = '\0'; + return new_stmt_sv; +} + + +/* -------------------------------------------------------------------- */ +/* The DBI Perl interface (via XS) starts here. Currently these are */ +/* all internal support functions. Note install_method and see DBI.pm */ + +MODULE = DBI PACKAGE = DBI + +REQUIRE: 1.929 +PROTOTYPES: DISABLE + + +BOOT: + { + MY_CXT_INIT; + (void)MY_CXT; /* avoid 'unused variable' warning */ + } + (void)cv; + (void)items; /* avoid 'unused variable' warning */ + dbi_bootinit(NULL); + /* make this sub into a fake XS so it can bee seen by DBD::* modules; + * never actually call it as an XS sub, or it will crash and burn! */ + (void) newXS("DBI::_dbi_state_lval", (XSUBADDR_t)_dbi_state_lval, __FILE__); + + +I32 +constant() + PROTOTYPE: + ALIAS: + SQL_ALL_TYPES = SQL_ALL_TYPES + SQL_ARRAY = SQL_ARRAY + SQL_ARRAY_LOCATOR = SQL_ARRAY_LOCATOR + SQL_BIGINT = SQL_BIGINT + SQL_BINARY = SQL_BINARY + SQL_BIT = SQL_BIT + SQL_BLOB = SQL_BLOB + SQL_BLOB_LOCATOR = SQL_BLOB_LOCATOR + SQL_BOOLEAN = SQL_BOOLEAN + SQL_CHAR = SQL_CHAR + SQL_CLOB = SQL_CLOB + SQL_CLOB_LOCATOR = SQL_CLOB_LOCATOR + SQL_DATE = SQL_DATE + SQL_DATETIME = SQL_DATETIME + SQL_DECIMAL = SQL_DECIMAL + SQL_DOUBLE = SQL_DOUBLE + SQL_FLOAT = SQL_FLOAT + SQL_GUID = SQL_GUID + SQL_INTEGER = SQL_INTEGER + SQL_INTERVAL = SQL_INTERVAL + SQL_INTERVAL_DAY = SQL_INTERVAL_DAY + SQL_INTERVAL_DAY_TO_HOUR = SQL_INTERVAL_DAY_TO_HOUR + SQL_INTERVAL_DAY_TO_MINUTE = SQL_INTERVAL_DAY_TO_MINUTE + SQL_INTERVAL_DAY_TO_SECOND = SQL_INTERVAL_DAY_TO_SECOND + SQL_INTERVAL_HOUR = SQL_INTERVAL_HOUR + SQL_INTERVAL_HOUR_TO_MINUTE = SQL_INTERVAL_HOUR_TO_MINUTE + SQL_INTERVAL_HOUR_TO_SECOND = SQL_INTERVAL_HOUR_TO_SECOND + SQL_INTERVAL_MINUTE = SQL_INTERVAL_MINUTE + SQL_INTERVAL_MINUTE_TO_SECOND = SQL_INTERVAL_MINUTE_TO_SECOND + SQL_INTERVAL_MONTH = SQL_INTERVAL_MONTH + SQL_INTERVAL_SECOND = SQL_INTERVAL_SECOND + SQL_INTERVAL_YEAR = SQL_INTERVAL_YEAR + SQL_INTERVAL_YEAR_TO_MONTH = SQL_INTERVAL_YEAR_TO_MONTH + SQL_LONGVARBINARY = SQL_LONGVARBINARY + SQL_LONGVARCHAR = SQL_LONGVARCHAR + SQL_MULTISET = SQL_MULTISET + SQL_MULTISET_LOCATOR = SQL_MULTISET_LOCATOR + SQL_NUMERIC = SQL_NUMERIC + SQL_REAL = SQL_REAL + SQL_REF = SQL_REF + SQL_ROW = SQL_ROW + SQL_SMALLINT = SQL_SMALLINT + SQL_TIME = SQL_TIME + SQL_TIMESTAMP = SQL_TIMESTAMP + SQL_TINYINT = SQL_TINYINT + SQL_TYPE_DATE = SQL_TYPE_DATE + SQL_TYPE_TIME = SQL_TYPE_TIME + SQL_TYPE_TIMESTAMP = SQL_TYPE_TIMESTAMP + SQL_TYPE_TIMESTAMP_WITH_TIMEZONE = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE + SQL_TYPE_TIME_WITH_TIMEZONE = SQL_TYPE_TIME_WITH_TIMEZONE + SQL_UDT = SQL_UDT + SQL_UDT_LOCATOR = SQL_UDT_LOCATOR + SQL_UNKNOWN_TYPE = SQL_UNKNOWN_TYPE + SQL_VARBINARY = SQL_VARBINARY + SQL_VARCHAR = SQL_VARCHAR + SQL_WCHAR = SQL_WCHAR + SQL_WLONGVARCHAR = SQL_WLONGVARCHAR + SQL_WVARCHAR = SQL_WVARCHAR + SQL_CURSOR_FORWARD_ONLY = SQL_CURSOR_FORWARD_ONLY + SQL_CURSOR_KEYSET_DRIVEN = SQL_CURSOR_KEYSET_DRIVEN + SQL_CURSOR_DYNAMIC = SQL_CURSOR_DYNAMIC + SQL_CURSOR_STATIC = SQL_CURSOR_STATIC + SQL_CURSOR_TYPE_DEFAULT = SQL_CURSOR_TYPE_DEFAULT + DBIpp_cm_cs = DBIpp_cm_cs + DBIpp_cm_hs = DBIpp_cm_hs + DBIpp_cm_dd = DBIpp_cm_dd + DBIpp_cm_dw = DBIpp_cm_dw + DBIpp_cm_br = DBIpp_cm_br + DBIpp_cm_XX = DBIpp_cm_XX + DBIpp_ph_qm = DBIpp_ph_qm + DBIpp_ph_cn = DBIpp_ph_cn + DBIpp_ph_cs = DBIpp_ph_cs + DBIpp_ph_sp = DBIpp_ph_sp + DBIpp_ph_XX = DBIpp_ph_XX + DBIpp_st_qq = DBIpp_st_qq + DBIpp_st_bs = DBIpp_st_bs + DBIpp_st_XX = DBIpp_st_XX + DBIstcf_DISCARD_STRING = DBIstcf_DISCARD_STRING + DBIstcf_STRICT = DBIstcf_STRICT + DBIf_TRACE_SQL = DBIf_TRACE_SQL + DBIf_TRACE_CON = DBIf_TRACE_CON + DBIf_TRACE_ENC = DBIf_TRACE_ENC + DBIf_TRACE_DBD = DBIf_TRACE_DBD + DBIf_TRACE_TXN = DBIf_TRACE_TXN + CODE: + RETVAL = ix; + OUTPUT: + RETVAL + + +void +_clone_dbis() + CODE: + dMY_CXT; + dbistate_t * parent_dbis = DBIS; + + (void)cv; + { + MY_CXT_CLONE; + } + dbi_bootinit(parent_dbis); + + +void +_new_handle(class, parent, attr_ref, imp_datasv, imp_class) + SV * class + SV * parent + SV * attr_ref + SV * imp_datasv + SV * imp_class + PPCODE: + dMY_CXT; + HV *outer; + SV *outer_ref; + HV *class_stash = gv_stashsv(class, GV_ADDWARN); + + if (DBIS_TRACE_LEVEL >= 5) { + PerlIO_printf(DBILOGFP, " New %s (for %s, parent=%s, id=%s)\n", + neatsvpv(class,0), SvPV_nolen(imp_class), neatsvpv(parent,0), neatsvpv(imp_datasv,0)); + (void)cv; /* avoid unused warning */ + } + + (void)hv_store((HV*)SvRV(attr_ref), "ImplementorClass", 16, SvREFCNT_inc(imp_class), 0); + + /* make attr into inner handle by blessing it into class */ + sv_bless(attr_ref, class_stash); + /* tie new outer hash to inner handle */ + outer = newHV(); /* create new hash to be outer handle */ + outer_ref = newRV_noinc((SV*)outer); + /* make outer hash into a handle by blessing it into class */ + sv_bless(outer_ref, class_stash); + /* tie outer handle to inner handle */ + sv_magic((SV*)outer, attr_ref, PERL_MAGIC_tied, Nullch, 0); + + dbih_setup_handle(aTHX_ outer_ref, SvPV_nolen(imp_class), parent, SvOK(imp_datasv) ? imp_datasv : Nullsv); + + /* return outer handle, plus inner handle if not in scalar context */ + sv_2mortal(outer_ref); + EXTEND(SP, 2); + PUSHs(outer_ref); + if (GIMME != G_SCALAR) { + PUSHs(attr_ref); + } + + +void +_setup_handle(sv, imp_class, parent, imp_datasv) + SV * sv + char * imp_class + SV * parent + SV * imp_datasv + CODE: + (void)cv; + dbih_setup_handle(aTHX_ sv, imp_class, parent, SvOK(imp_datasv) ? imp_datasv : Nullsv); + ST(0) = &PL_sv_undef; + + +void +_get_imp_data(sv) + SV * sv + CODE: + D_imp_xxh(sv); + (void)cv; + ST(0) = sv_mortalcopy(DBIc_IMP_DATA(imp_xxh)); /* okay if NULL */ + + +void +_handles(sv) + SV * sv + PPCODE: + /* return the outer and inner handle for any given handle */ + D_imp_xxh(sv); + SV *ih = sv_mortalcopy( dbih_inner(aTHX_ sv, "_handles") ); + SV *oh = sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh))); /* XXX dangerous */ + (void)cv; + EXTEND(SP, 2); + PUSHs(oh); /* returns outer handle then inner */ + PUSHs(ih); + + +void +neat(sv, maxlen=0) + SV * sv + U32 maxlen + CODE: + ST(0) = sv_2mortal(newSVpv(neatsvpv(sv, maxlen), 0)); + (void)cv; + + +I32 +hash(key, type=0) + const char *key + long type + CODE: + (void)cv; + RETVAL = dbi_hash(key, type); + OUTPUT: + RETVAL + +void +looks_like_number(...) + PPCODE: + int i; + EXTEND(SP, items); + (void)cv; + for(i=0; i < items ; ++i) { + SV *sv = ST(i); + if (!SvOK(sv) || (SvPOK(sv) && SvCUR(sv)==0)) + PUSHs(&PL_sv_undef); + else if ( looks_like_number(sv) ) + PUSHs(&PL_sv_yes); + else + PUSHs(&PL_sv_no); + } + + +void +_install_method(dbi_class, meth_name, file, attribs=Nullsv) + const char * dbi_class + char * meth_name + char * file + SV * attribs + CODE: + { + dMY_CXT; + /* install another method name/interface for the DBI dispatcher */ + SV *trace_msg = (DBIS_TRACE_LEVEL >= 10) ? sv_2mortal(newSVpv("",0)) : Nullsv; + CV *cv; + SV **svp; + dbi_ima_t *ima; + MAGIC *mg; + (void)dbi_class; + + if (strnNE(meth_name, "DBI::", 5)) /* XXX m/^DBI::\w+::\w+$/ */ + croak("install_method %s: invalid class", meth_name); + + if (trace_msg) + sv_catpvf(trace_msg, "install_method %-21s", meth_name); + + Newxz(ima, 1, dbi_ima_t); + + if (attribs && SvOK(attribs)) { + /* convert and store method attributes in a fast access form */ + if (SvTYPE(SvRV(attribs)) != SVt_PVHV) + croak("install_method %s: bad attribs", meth_name); + + DBD_ATTRIB_GET_IV(attribs, "O",1, svp, ima->flags); + DBD_ATTRIB_GET_UV(attribs, "T",1, svp, ima->method_trace); + DBD_ATTRIB_GET_IV(attribs, "H",1, svp, ima->hidearg); + + if (trace_msg) { + if (ima->flags) sv_catpvf(trace_msg, ", flags 0x%04x", (unsigned)ima->flags); + if (ima->method_trace)sv_catpvf(trace_msg, ", T 0x%08lx", (unsigned long)ima->method_trace); + if (ima->hidearg) sv_catpvf(trace_msg, ", H %u", (unsigned)ima->hidearg); + } + if ( (svp=DBD_ATTRIB_GET_SVP(attribs, "U",1)) != NULL) { + AV *av = (AV*)SvRV(*svp); + ima->minargs = (U8)SvIV(*av_fetch(av, 0, 1)); + ima->maxargs = (U8)SvIV(*av_fetch(av, 1, 1)); + svp = av_fetch(av, 2, 0); + ima->usage_msg = (svp) ? savepv_using_sv(SvPV_nolen(*svp)) : ""; + ima->flags |= IMA_HAS_USAGE; + if (trace_msg && DBIS_TRACE_LEVEL >= 11) + sv_catpvf(trace_msg, ",\n usage: min %d, max %d, '%s'", + ima->minargs, ima->maxargs, ima->usage_msg); + } + } + if (trace_msg) + PerlIO_printf(DBILOGFP,"%s\n", SvPV_nolen(trace_msg)); + file = savepv(file); + cv = newXS(meth_name, XS_DBI_dispatch, file); + SvPVX((SV *)cv) = file; + SvLEN((SV *)cv) = 1; + CvXSUBANY(cv).any_ptr = ima; + ima->meth_type = get_meth_type(GvNAME(CvGV(cv))); + + /* Attach magic to handle duping and freeing of the dbi_ima_t struct. + * Due to the poor interface of the mg dup function, sneak a pointer + * to the original CV in the mg_ptr field (we get called with a + * pointer to the mg, but not the SV) */ + mg = sv_magicext((SV*)cv, NULL, DBI_MAGIC, &dbi_ima_vtbl, + (char *)cv, 0); +#ifdef BROKEN_DUP_ANY_PTR + ima->my_perl = my_perl; /* who owns this struct */ +#else + mg->mg_flags |= MGf_DUP; +#endif + ST(0) = &PL_sv_yes; + } + + +int +trace(class, level_sv=&PL_sv_undef, file=Nullsv) + SV * class + SV * level_sv + SV * file + ALIAS: + _debug_dispatch = 1 + CODE: + { + dMY_CXT; + IV level; + if (!DBIS) { + ix=ix; /* avoid 'unused variable' warnings */ + croak("DBI not initialised"); + } + /* Return old/current value. No change if new value not given. */ + RETVAL = (DBIS) ? DBIS->debug : 0; + level = parse_trace_flags(class, level_sv, RETVAL); + if (level) /* call before or after altering DBI trace level */ + set_trace_file(file); + if (level != RETVAL) { + if ((level & DBIc_TRACE_LEVEL_MASK) > 0) { + PerlIO_printf(DBILOGFP," DBI %s%s default trace level set to 0x%lx/%ld (pid %d pi %p) at %s\n", + XS_VERSION, dbi_build_opt, + (long)(level & DBIc_TRACE_FLAGS_MASK), + (long)(level & DBIc_TRACE_LEVEL_MASK), + (int)PerlProc_getpid(), +#ifdef MULTIPLICITY + (void *)my_perl, +#else + (void*)NULL, +#endif + log_where(Nullsv, 0, "", "", 1, 1, 0) + ); + if (!PL_dowarn) + PerlIO_printf(DBILOGFP," Note: perl is running without the recommended perl -w option\n"); + PerlIO_flush(DBILOGFP); + } + DBIS->debug = level; + sv_setiv(get_sv("DBI::dbi_debug",0x5), level); + } + if (!level) /* call before or after altering DBI trace level */ + set_trace_file(file); + } + OUTPUT: + RETVAL + + + +void +dump_handle(sv, msg="DBI::dump_handle", level=0) + SV * sv + const char *msg + int level + CODE: + (void)cv; + dbih_dumphandle(aTHX_ sv, msg, level); + + + +void +_svdump(sv) + SV * sv + CODE: + { + dMY_CXT; + (void)cv; + PerlIO_printf(DBILOGFP, "DBI::_svdump(%s)", neatsvpv(sv,0)); +#ifdef DEBUGGING + sv_dump(sv); +#endif + } + + +NV +dbi_time() + + +void +dbi_profile(h, statement, method, t1, t2) + SV *h + SV *statement + SV *method + NV t1 + NV t2 + CODE: + SV *leaf = &PL_sv_undef; + (void)cv; /* avoid unused var warnings */ + if (SvROK(method)) + method = SvRV(method); + if (dbih_inner(aTHX_ h, NULL)) { /* is a DBI handle */ + D_imp_xxh(h); + leaf = dbi_profile(h, imp_xxh, statement, method, t1, t2); + } + else if (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV) { + /* iterate over values %$h */ + HV *hv = (HV*)SvRV(h); + SV *tmp; + char *key; + I32 keylen = 0; + hv_iterinit(hv); + while ( (tmp = hv_iternextsv(hv, &key, &keylen)) != NULL ) { + if (SvOK(tmp)) { + D_imp_xxh(tmp); + leaf = dbi_profile(tmp, imp_xxh, statement, method, t1, t2); + } + }; + } + else { + croak("dbi_profile(%s,...) invalid handle argument", neatsvpv(h,0)); + } + if (GIMME_V == G_VOID) + ST(0) = &PL_sv_undef; /* skip sv_mortalcopy if not needed */ + else + ST(0) = sv_mortalcopy(leaf); + + + +SV * +dbi_profile_merge_nodes(dest, ...) + SV * dest + ALIAS: + dbi_profile_merge = 1 + CODE: + { + if (!SvROK(dest) || SvTYPE(SvRV(dest)) != SVt_PVAV) + croak("dbi_profile_merge_nodes(%s,...) destination is not an array reference", neatsvpv(dest,0)); + if (items <= 1) { + (void)cv; /* avoid unused var warnings */ + (void)ix; + RETVAL = 0; + } + else { + /* items==2 for dest + 1 arg, ST(0) is dest, ST(1) is first arg */ + while (--items >= 1) { + SV *thingy = ST(items); + dbi_profile_merge_nodes(dest, thingy); + } + RETVAL = newSVsv(*av_fetch((AV*)SvRV(dest), DBIprof_TOTAL_TIME, 1)); + } + } + OUTPUT: + RETVAL + + +SV * +_concat_hash_sorted(hash_sv, kv_sep_sv, pair_sep_sv, use_neat_sv, num_sort_sv) + SV *hash_sv + SV *kv_sep_sv + SV *pair_sep_sv + SV *use_neat_sv + SV *num_sort_sv + PREINIT: + char *kv_sep, *pair_sep; + STRLEN kv_sep_len, pair_sep_len; + CODE: + if (!SvOK(hash_sv)) + XSRETURN_UNDEF; + if (!SvROK(hash_sv) || SvTYPE(SvRV(hash_sv))!=SVt_PVHV) + croak("hash is not a hash reference"); + + kv_sep = SvPV(kv_sep_sv, kv_sep_len); + pair_sep = SvPV(pair_sep_sv, pair_sep_len); + + RETVAL = _join_hash_sorted( (HV*)SvRV(hash_sv), + kv_sep, kv_sep_len, + pair_sep, pair_sep_len, + /* use_neat should be undef, 0 or 1, may allow sprintf format strings later */ + (SvOK(use_neat_sv)) ? SvIV(use_neat_sv) : 0, + (SvOK(num_sort_sv)) ? SvIV(num_sort_sv) : -1 + ); + OUTPUT: + RETVAL + + +int +sql_type_cast(sv, sql_type, flags=0) + SV * sv + int sql_type + U32 flags + CODE: + RETVAL = sql_type_cast_svpv(aTHX_ sv, sql_type, flags, 0); + OUTPUT: + RETVAL + + + +MODULE = DBI PACKAGE = DBI::var + +void +FETCH(sv) + SV * sv + CODE: + dMY_CXT; + /* Note that we do not come through the dispatcher to get here. */ + char *meth = SvPV_nolen(SvRV(sv)); /* what should this tie do ? */ + char type = *meth++; /* is this a $ or & style */ + imp_xxh_t *imp_xxh = (DBI_LAST_HANDLE_OK) ? DBIh_COM(DBI_LAST_HANDLE) : NULL; + int trace_level = (imp_xxh ? DBIc_TRACE_LEVEL(imp_xxh) : DBIS_TRACE_LEVEL); + NV profile_t1 = 0.0; + + if (imp_xxh && DBIc_has(imp_xxh,DBIcf_Profile)) + profile_t1 = dbi_time(); + + if (trace_level >= 2) { + PerlIO_printf(DBILOGFP," -> $DBI::%s (%c) FETCH from lasth=%s\n", meth, type, + (imp_xxh) ? neatsvpv(DBI_LAST_HANDLE,0): "none"); + } + + if (type == '!') { /* special case for $DBI::lasth */ + /* Currently we can only return the INNER handle. */ + /* This handle should only be used for true/false tests */ + ST(0) = (imp_xxh) ? sv_2mortal(newRV_inc(DBI_LAST_HANDLE)) : &PL_sv_undef; + } + else if ( !imp_xxh ) { + if (trace_level) + warn("Can't read $DBI::%s, last handle unknown or destroyed", meth); + ST(0) = &PL_sv_undef; + } + else if (type == '*') { /* special case for $DBI::err, see also err method */ + SV *errsv = DBIc_ERR(imp_xxh); + ST(0) = sv_mortalcopy(errsv); + } + else if (type == '"') { /* special case for $DBI::state */ + SV *state = DBIc_STATE(imp_xxh); + ST(0) = DBIc_STATE_adjust(imp_xxh, state); + } + else if (type == '$') { /* lookup scalar variable in implementors stash */ + const char *vname = mkvname(aTHX_ DBIc_IMP_STASH(imp_xxh), meth, 0); + SV *vsv = get_sv(vname, 1); + ST(0) = sv_mortalcopy(vsv); + } + else { + /* default to method call via stash of implementor of DBI_LAST_HANDLE */ + GV *imp_gv; + HV *imp_stash = DBIc_IMP_STASH(imp_xxh); +#ifdef DBI_save_hv_fetch_ent + HE save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */ +#endif + profile_t1 = 0.0; /* profile this via dispatch only (else we'll double count) */ + if (trace_level >= 3) + PerlIO_printf(DBILOGFP," >> %s::%s\n", HvNAME(imp_stash), meth); + ST(0) = sv_2mortal(newRV_inc(DBI_LAST_HANDLE)); + if ((imp_gv = gv_fetchmethod(imp_stash,meth)) == NULL) { + croak("Can't locate $DBI::%s object method \"%s\" via package \"%s\"", + meth, meth, HvNAME(imp_stash)); + } + PUSHMARK(mark); /* reset mark (implies one arg as we were called with one arg?) */ + call_sv((SV*)GvCV(imp_gv), GIMME); + SPAGAIN; +#ifdef DBI_save_hv_fetch_ent + PL_hv_fetch_ent_mh = save_mh; +#endif + } + if (trace_level) + PerlIO_printf(DBILOGFP," <- $DBI::%s= %s\n", meth, neatsvpv(ST(0),0)); + if (profile_t1) { + SV *h = sv_2mortal(newRV_inc(DBI_LAST_HANDLE)); + dbi_profile(h, imp_xxh, &PL_sv_undef, (SV*)cv, profile_t1, dbi_time()); + } + + +MODULE = DBI PACKAGE = DBD::_::dr + +void +dbixs_revision(h) + SV * h + CODE: + PERL_UNUSED_VAR(h); + ST(0) = sv_2mortal(newSViv(DBIXS_REVISION)); + + +MODULE = DBI PACKAGE = DBD::_::db + +void +connected(...) + CODE: + /* defined here just to avoid AUTOLOAD */ + (void)cv; + (void)items; + ST(0) = &PL_sv_undef; + + +SV * +preparse(dbh, statement, ps_accept, ps_return, foo=Nullch) + SV * dbh + char * statement + IV ps_accept + IV ps_return + void *foo + + +void +take_imp_data(h) + SV * h + PREINIT: + /* take_imp_data currently in DBD::_::db not DBD::_::common, so for dbh's only */ + D_imp_xxh(h); + MAGIC *mg; + SV *imp_xxh_sv; + SV **tmp_svp; + CODE: + (void)cv; /* unused */ + /* + * Remove and return the imp_xxh_t structure that's attached to the inner + * hash of the handle. Effectively this removes the 'brain' of the handle + * leaving it as an empty shell - brain dead. All method calls on it fail. + * + * The imp_xxh_t structure that's removed and returned is a plain scalar + * (containing binary data). It can be passed to a new DBI->connect call + * in order to have the new $dbh use the same 'connection' as the original + * handle. In this way a multi-threaded connection pool can be implemented. + * + * If the drivers imp_xxh_t structure contains SV*'s, or other interpreter + * specific items, they should be freed by the drivers own take_imp_data() + * method before it then calls SUPER::take_imp_data() to finalize removal + * of the imp_xxh_t structure. + * + * The driver needs to view the take_imp_data method as being nearly the + * same as disconnect+DESTROY only not actually calling the database API to + * disconnect. All that needs to remain valid in the imp_xxh_t structure + * is the underlying database API connection data. Everything else should + * in a 'clean' state such that if the drivers own DESTROY method was + * called it would be able to properly handle the contents of the + * structure. This is important in case a new handle created using this + * imp_data, possibly in a new thread, might end up being DESTROY'd before + * the driver has had a chance to 're-setup' the data. See dbih_setup_handle() + * + * All the above relates to the 'typical use case' for a compiled driver. + * For a pure-perl driver using a socket pair, for example, the drivers + * take_imp_data method might just return a string containing the fileno() + * values of the sockets (without calling this SUPER::take_imp_data() code). + * The key point is that the take_imp_data() method returns an opaque buffer + * containing whatever the driver would need to reuse the same underlying + * 'connection to the database' in a new handle. + * + * In all cases, care should be taken that driver attributes (such as + * AutoCommit) match the state of the underlying connection. + */ + + if (!DBIc_ACTIVE(imp_xxh)) {/* sanity check, may be relaxed later */ + set_err_char(h, imp_xxh, "1", 1, "Can't take_imp_data from handle that's not Active", 0, "take_imp_data"); + XSRETURN(0); + } + + /* Ideally there should be no child statement handles existing when + * take_imp_data is called because when those statement handles are + * destroyed they may need to interact with the 'zombie' parent dbh. + * So we do our best to neautralize them (finish & rebless) + */ + if ((tmp_svp = hv_fetch((HV*)SvRV(h), "ChildHandles", 12, FALSE)) && SvROK(*tmp_svp)) { + AV *av = (AV*)SvRV(*tmp_svp); + HV *zombie_stash = gv_stashpv("DBI::zombie", GV_ADDWARN); + I32 kidslots; + for (kidslots = AvFILL(av); kidslots >= 0; --kidslots) { + SV **hp = av_fetch(av, kidslots, FALSE); + if (hp && SvROK(*hp) && SvMAGICAL(SvRV(*hp))) { + PUSHMARK(sp); + XPUSHs(*hp); + PUTBACK; + call_method("finish", G_SCALAR|G_DISCARD); + SPAGAIN; + PUTBACK; + sv_unmagic(SvRV(*hp), 'P'); /* untie */ + sv_bless(*hp, zombie_stash); /* neutralise */ + } + } + } + /* The above measures may not be sufficient if weakrefs aren't available + * or something has a reference to the inner-handle of an sth. + * We'll require no Active kids, but just warn about others. + */ + if (DBIc_ACTIVE_KIDS(imp_xxh)) { + set_err_char(h, imp_xxh, "1", 1, "Can't take_imp_data from handle while it still has Active kids", 0, "take_imp_data"); + XSRETURN(0); + } + if (DBIc_KIDS(imp_xxh)) + warn("take_imp_data from handle while it still has kids"); + + /* it may be better here to return a copy and poison the original + * rather than detatching and returning the original + */ + + /* --- perform the surgery */ + dbih_getcom2(aTHX_ h, &mg); /* get the MAGIC so we can change it */ + imp_xxh_sv = mg->mg_obj; /* take local copy of the imp_data pointer */ + mg->mg_obj = Nullsv; /* sever the link from handle to imp_xxh */ + mg->mg_ptr = NULL; /* and sever the shortcut too */ + if (DBIc_TRACE_LEVEL(imp_xxh) >= 9) + sv_dump(imp_xxh_sv); + /* --- housekeeping */ + DBIc_ACTIVE_off(imp_xxh); /* silence warning from dbih_clearcom */ + DBIc_IMPSET_off(imp_xxh); /* silence warning from dbih_clearcom */ + dbih_clearcom(imp_xxh); /* free SVs like DBD::_mem::common::DESTROY */ + SvOBJECT_off(imp_xxh_sv); /* no longer needs DESTROY via dbih_clearcom */ + /* restore flags to mark fact imp data holds active connection */ + /* (don't use magical DBIc_ACTIVE_on here) */ + DBIc_FLAGS(imp_xxh) |= DBIcf_IMPSET | DBIcf_ACTIVE; + /* --- tidy up the raw PV for life as a more normal string */ + SvPOK_on(imp_xxh_sv); /* SvCUR & SvEND were set at creation */ + /* --- return the actual imp_xxh_sv on the stack */ + ST(0) = imp_xxh_sv; + + + +MODULE = DBI PACKAGE = DBD::_::st + +void +_get_fbav(sth) + SV * sth + CODE: + D_imp_sth(sth); + AV *av = dbih_get_fbav(imp_sth); + (void)cv; + ST(0) = sv_2mortal(newRV_inc((SV*)av)); + +void +_set_fbav(sth, src_rv) + SV * sth + SV * src_rv + CODE: + D_imp_sth(sth); + int i; + AV *src_av; + AV *dst_av = dbih_get_fbav(imp_sth); + int dst_fields = AvFILL(dst_av)+1; + int src_fields; + (void)cv; + + if (!SvROK(src_rv) || SvTYPE(SvRV(src_rv)) != SVt_PVAV) + croak("_set_fbav(%s): not an array ref", neatsvpv(src_rv,0)); + src_av = (AV*)SvRV(src_rv); + src_fields = AvFILL(src_av)+1; + if (src_fields != dst_fields) { + warn("_set_fbav(%s): array has %d elements, the statement handle row buffer has %d (and NUM_OF_FIELDS is %d)", + neatsvpv(src_rv,0), src_fields, dst_fields, DBIc_NUM_FIELDS(imp_sth)); + SvREADONLY_off(dst_av); + if (src_fields < dst_fields) { + /* shrink the array - sadly this looses column bindings for the lost columns */ + av_fill(dst_av, src_fields-1); + dst_fields = src_fields; + } + else { + av_fill(dst_av, src_fields-1); + /* av_fill pads with immutable undefs which we need to change */ + for(i=dst_fields-1; i < src_fields; ++i) { + sv_setsv(AvARRAY(dst_av)[i], newSV(0)); + } + } + SvREADONLY_on(dst_av); + } + for(i=0; i < dst_fields; ++i) { /* copy over the row */ + /* If we're given the values, then taint them if required */ + if (DBIc_is(imp_sth, DBIcf_TaintOut)) + SvTAINT(AvARRAY(src_av)[i]); + sv_setsv(AvARRAY(dst_av)[i], AvARRAY(src_av)[i]); + } + ST(0) = sv_2mortal(newRV_inc((SV*)dst_av)); + + +void +bind_col(sth, col, ref, attribs=Nullsv) + SV * sth + SV * col + SV * ref + SV * attribs + CODE: + DBD_ATTRIBS_CHECK("bind_col", sth, attribs); + ST(0) = boolSV(dbih_sth_bind_col(sth, col, ref, attribs)); + (void)cv; + + +void +fetchrow_array(sth) + SV * sth + ALIAS: + fetchrow = 1 + PPCODE: + SV *retsv; + if (CvDEPTH(cv) == 99) { + ix = ix; /* avoid 'unused variable' warning' */ + croak("Deep recursion, probably fetchrow-fetch-fetchrow loop"); + } + PUSHMARK(sp); + XPUSHs(sth); + PUTBACK; + if (call_method("fetch", G_SCALAR) != 1) + croak("panic: DBI fetch"); /* should never happen */ + SPAGAIN; + retsv = POPs; + PUTBACK; + if (SvROK(retsv) && SvTYPE(SvRV(retsv)) == SVt_PVAV) { + D_imp_sth(sth); + int num_fields, i; + AV *bound_av; + AV *av = (AV*)SvRV(retsv); + num_fields = AvFILL(av)+1; + EXTEND(sp, num_fields+1); + + /* We now check for bind_col() having been called but fetch */ + /* not returning the fields_svav array. Probably because the */ + /* driver is implemented in perl. XXX This logic may change later. */ + bound_av = DBIc_FIELDS_AV(imp_sth); /* bind_col() called ? */ + if (bound_av && av != bound_av) { + /* let dbih_get_fbav know what's going on */ + bound_av = dbih_get_fbav(imp_sth); + if (DBIc_TRACE_LEVEL(imp_sth) >= 3) { + PerlIO_printf(DBIc_LOGPIO(imp_sth), + "fetchrow: updating fbav 0x%lx from 0x%lx\n", + (long)bound_av, (long)av); + } + for(i=0; i < num_fields; ++i) { /* copy over the row */ + sv_setsv(AvARRAY(bound_av)[i], AvARRAY(av)[i]); + } + } + for(i=0; i < num_fields; ++i) { + PUSHs(AvARRAY(av)[i]); + } + } + + +SV * +fetchrow_hashref(sth, keyattrib=Nullch) + SV * sth + const char *keyattrib + PREINIT: + SV *rowavr; + SV *ka_rv; + D_imp_sth(sth); + CODE: + (void)cv; + PUSHMARK(sp); + XPUSHs(sth); + PUTBACK; + if (!keyattrib || !*keyattrib) { + SV *kn = DBIc_FetchHashKeyName(imp_sth); + if (kn && SvOK(kn)) + keyattrib = SvPVX(kn); + else + keyattrib = "NAME"; + } + ka_rv = *hv_fetch((HV*)DBIc_MY_H(imp_sth), keyattrib,strlen(keyattrib), TRUE); + /* we copy to invoke FETCH magic, and we do that before fetch() so if tainting */ + /* then the taint triggered by the fetch won't then apply to the fetched name */ + ka_rv = newSVsv(ka_rv); + if (call_method("fetch", G_SCALAR) != 1) + croak("panic: DBI fetch"); /* should never happen */ + SPAGAIN; + rowavr = POPs; + PUTBACK; + /* have we got an array ref in rowavr */ + if (SvROK(rowavr) && SvTYPE(SvRV(rowavr)) == SVt_PVAV) { + int i; + AV *rowav = (AV*)SvRV(rowavr); + const int num_fields = AvFILL(rowav)+1; + HV *hv; + AV *ka_av; + if (!(SvROK(ka_rv) && SvTYPE(SvRV(ka_rv))==SVt_PVAV)) { + sv_setiv(DBIc_ERR(imp_sth), 1); + sv_setpvf(DBIc_ERRSTR(imp_sth), + "Can't use attribute '%s' because it doesn't contain a reference to an array (%s)", + keyattrib, neatsvpv(ka_rv,0)); + XSRETURN_UNDEF; + } + ka_av = (AV*)SvRV(ka_rv); + hv = newHV(); + for (i=0; i < num_fields; ++i) { /* honor the original order as sent by the database */ + SV **field_name_svp = av_fetch(ka_av, i, 1); + (void)hv_store_ent(hv, *field_name_svp, newSVsv((SV*)(AvARRAY(rowav)[i])), 0); + } + RETVAL = newRV_inc((SV*)hv); + SvREFCNT_dec(hv); /* since newRV incremented it */ + } + else { + RETVAL = &PL_sv_undef; +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 4)) + RETVAL = newSV(0); /* mutable undef for 5.004_04 */ +#endif + } + SvREFCNT_dec(ka_rv); /* since we created it */ + OUTPUT: + RETVAL + + +void +fetch(sth) + SV * sth + ALIAS: + fetchrow_arrayref = 1 + CODE: + int num_fields; + if (CvDEPTH(cv) == 99) { + (void)ix; /* avoid 'unused variable' warning' */ + croak("Deep recursion. Probably fetch-fetchrow-fetch loop."); + } + PUSHMARK(sp); + XPUSHs(sth); + PUTBACK; + num_fields = call_method("fetchrow", G_ARRAY); /* XXX change the name later */ + SPAGAIN; + if (num_fields == 0) { + ST(0) = &PL_sv_undef; + } else { + D_imp_sth(sth); + AV *av = dbih_get_fbav(imp_sth); + if (num_fields != AvFILL(av)+1) + croak("fetchrow returned %d fields, expected %d", + num_fields, (int)AvFILL(av)+1); + SPAGAIN; + while(--num_fields >= 0) + sv_setsv(AvARRAY(av)[num_fields], POPs); + PUTBACK; + ST(0) = sv_2mortal(newRV_inc((SV*)av)); + } + + +void +rows(sth) + SV * sth + CODE: + D_imp_sth(sth); + const IV rows = DBIc_ROW_COUNT(imp_sth); + ST(0) = sv_2mortal(newSViv(rows)); + (void)cv; + + +void +finish(sth) + SV * sth + CODE: + D_imp_sth(sth); + DBIc_ACTIVE_off(imp_sth); + ST(0) = &PL_sv_yes; + (void)cv; + + +void +DESTROY(sth) + SV * sth + PPCODE: + /* keep in sync with DESTROY in Driver.xst */ + D_imp_sth(sth); + ST(0) = &PL_sv_yes; + /* we don't test IMPSET here because this code applies to pure-perl drivers */ + if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */ + DBIc_ACTIVE_off(imp_sth); + if (DBIc_TRACE_LEVEL(imp_sth)) + PerlIO_printf(DBIc_LOGPIO(imp_sth), " DESTROY %s skipped due to InactiveDestroy\n", SvPV_nolen(sth)); + } + if (DBIc_ACTIVE(imp_sth)) { + D_imp_dbh_from_sth; + if (!PL_dirty && DBIc_ACTIVE(imp_dbh)) { + dSP; + PUSHMARK(sp); + XPUSHs(sth); + PUTBACK; + call_method("finish", G_SCALAR); + SPAGAIN; + PUTBACK; + } + else { + DBIc_ACTIVE_off(imp_sth); + } + } + + +MODULE = DBI PACKAGE = DBI::st + +void +TIEHASH(class, inner_ref) + SV * class + SV * inner_ref + CODE: + HV *stash = gv_stashsv(class, GV_ADDWARN); /* a new hash is supplied to us, we just need to bless and apply tie magic */ + sv_bless(inner_ref, stash); + ST(0) = inner_ref; + +MODULE = DBI PACKAGE = DBD::_::common + + +void +DESTROY(h) + SV * h + CODE: + /* DESTROY defined here just to avoid AUTOLOAD */ + (void)cv; + (void)h; + ST(0) = &PL_sv_undef; + + +void +STORE(h, keysv, valuesv) + SV * h + SV * keysv + SV * valuesv + CODE: + ST(0) = &PL_sv_yes; + if (!dbih_set_attr_k(h, keysv, 0, valuesv)) + ST(0) = &PL_sv_no; + (void)cv; + + +void +FETCH(h, keysv) + SV * h + SV * keysv + CODE: + ST(0) = dbih_get_attr_k(h, keysv, 0); + (void)cv; + + +void +private_data(h) + SV * h + CODE: + D_imp_xxh(h); + (void)cv; + ST(0) = sv_mortalcopy(DBIc_IMP_DATA(imp_xxh)); + + +void +err(h) + SV * h + CODE: + D_imp_xxh(h); + SV *errsv = DBIc_ERR(imp_xxh); + (void)cv; + ST(0) = sv_mortalcopy(errsv); + +void +state(h) + SV * h + CODE: + D_imp_xxh(h); + SV *state = DBIc_STATE(imp_xxh); + (void)cv; + ST(0) = DBIc_STATE_adjust(imp_xxh, state); + +void +errstr(h) + SV * h + CODE: + D_imp_xxh(h); + SV *errstr = DBIc_ERRSTR(imp_xxh); + SV *err; + /* If there's no errstr but there is an err then use err */ + (void)cv; + if (!SvTRUE(errstr) && (err=DBIc_ERR(imp_xxh)) && SvTRUE(err)) + errstr = err; + ST(0) = sv_mortalcopy(errstr); + + +void +set_err(h, err, errstr=&PL_sv_no, state=&PL_sv_undef, method=&PL_sv_undef, result=Nullsv) + SV * h + SV * err + SV * errstr + SV * state + SV * method + SV * result + PPCODE: + { + D_imp_xxh(h); + SV **sem_svp; + (void)cv; + + if (DBIc_has(imp_xxh, DBIcf_HandleSetErr) && SvREADONLY(method)) + method = sv_mortalcopy(method); /* HandleSetErr may want to change it */ + + if (!set_err_sv(h, imp_xxh, err, errstr, state, method)) { + /* set_err was canceled by HandleSetErr, */ + /* don't set "dbi_set_err_method", return an empty list */ + } + else { + /* store provided method name so handler code can find it */ + sem_svp = hv_fetch((HV*)SvRV(h), "dbi_set_err_method", 18, 1); + if (SvOK(method)) { + sv_setpv(*sem_svp, SvPV_nolen(method)); + } + else + (void)SvOK_off(*sem_svp); + EXTEND(SP, 1); + PUSHs( result ? result : &PL_sv_undef ); + } + /* We don't check RaiseError and call die here because that must be */ + /* done by returning through dispatch and letting the DBI handle it */ + } + + +int +trace(h, level=&PL_sv_undef, file=Nullsv) + SV *h + SV *level + SV *file + ALIAS: + debug = 1 + CODE: + RETVAL = set_trace(h, level, file); + (void)cv; /* Unused variables */ + (void)ix; + OUTPUT: + RETVAL + + +void +trace_msg(sv, msg, this_trace=1) + SV *sv + const char *msg + int this_trace + PREINIT: + int current_trace; + PerlIO *pio; + CODE: + { + dMY_CXT; + (void)cv; + if (SvROK(sv)) { + D_imp_xxh(sv); + current_trace = DBIc_TRACE_LEVEL(imp_xxh); + pio = DBIc_LOGPIO(imp_xxh); + } + else { /* called as a static method */ + current_trace = DBIS_TRACE_FLAGS; + pio = DBILOGFP; + } + if (DBIc_TRACE_MATCHES(this_trace, current_trace)) { + PerlIO_puts(pio, msg); + ST(0) = &PL_sv_yes; + } + else { + ST(0) = &PL_sv_no; + } + } + + +void +rows(h) + SV * h + CODE: + /* fallback esp for $DBI::rows after $drh was last used */ + ST(0) = sv_2mortal(newSViv(-1)); + (void)h; + (void)cv; + + +void +swap_inner_handle(rh1, rh2, allow_reparent=0) + SV * rh1 + SV * rh2 + IV allow_reparent + CODE: + { + D_impdata(imp_xxh1, imp_xxh_t, rh1); + D_impdata(imp_xxh2, imp_xxh_t, rh2); + SV *h1i = dbih_inner(aTHX_ rh1, "swap_inner_handle"); + SV *h2i = dbih_inner(aTHX_ rh2, "swap_inner_handle"); + SV *h1 = (rh1 == h1i) ? (SV*)DBIc_MY_H(imp_xxh1) : SvRV(rh1); + SV *h2 = (rh2 == h2i) ? (SV*)DBIc_MY_H(imp_xxh2) : SvRV(rh2); + (void)cv; + + if (DBIc_TYPE(imp_xxh1) != DBIc_TYPE(imp_xxh2)) { + char buf[99]; + sprintf(buf, "Can't swap_inner_handle between %sh and %sh", + dbih_htype_name(DBIc_TYPE(imp_xxh1)), dbih_htype_name(DBIc_TYPE(imp_xxh2))); + DBIh_SET_ERR_CHAR(rh1, imp_xxh1, "1", 1, buf, Nullch, Nullch); + XSRETURN_NO; + } + if (!allow_reparent && DBIc_PARENT_COM(imp_xxh1) != DBIc_PARENT_COM(imp_xxh2)) { + DBIh_SET_ERR_CHAR(rh1, imp_xxh1, "1", 1, + "Can't swap_inner_handle with handle from different parent", + Nullch, Nullch); + XSRETURN_NO; + } + + SvREFCNT_inc(h1i); + SvREFCNT_inc(h2i); + + sv_unmagic(h1, 'P'); /* untie(%$h1) */ + sv_unmagic(h2, 'P'); /* untie(%$h2) */ + + sv_magic(h1, h2i, 'P', Nullch, 0); /* tie %$h1, $h2i */ + DBIc_MY_H(imp_xxh2) = (HV*)h1; + + sv_magic(h2, h1i, 'P', Nullch, 0); /* tie %$h2, $h1i */ + DBIc_MY_H(imp_xxh1) = (HV*)h2; + + SvREFCNT_dec(h1i); + SvREFCNT_dec(h2i); + + ST(0) = &PL_sv_yes; + } + + +MODULE = DBI PACKAGE = DBD::_mem::common + +void +DESTROY(imp_xxh_rv) + SV * imp_xxh_rv + CODE: + /* ignore 'cast increases required alignment' warning */ + imp_xxh_t *imp_xxh = (imp_xxh_t*)SvPVX(SvRV(imp_xxh_rv)); + DBIc_DBISTATE(imp_xxh)->clearcom(imp_xxh); + (void)cv; + +# end |