File Coverage

DBI.xs
Criterion Covered Total %
statement 2195 2607 84.2
branch 2484 4390 56.5
condition n/a
subroutine n/a
pod n/a
total 4679 6997 66.8


line stmt bran cond sub pod time code
1             /* vim: ts=8:sw=4:expandtab
2             *
3             * $Id$
4             *
5             * Copyright (c) 1994-2012 Tim Bunce Ireland.
6             *
7             * See COPYRIGHT section in DBI.pm for usage and distribution rights.
8             */
9              
10             #define IN_DBI_XS 1 /* see DBIXS.h */
11             #define PERL_NO_GET_CONTEXT
12              
13             #include "DBIXS.h" /* DBI public interface for DBD's written in C */
14              
15             # if (defined(_WIN32) && (! defined(HAS_GETTIMEOFDAY)))
16             #include
17             # endif
18              
19             /* The XS dispatcher code can optimize calls to XS driver methods,
20             * bypassing the usual call_sv() and argument handling overheads.
21             * Just-in-case it causes problems there's an (undocumented) way
22             * to disable it by setting an env var.
23             */
24             static int use_xsbypass = 1; /* set in dbi_bootinit() */
25              
26             #ifndef CvISXSUB
27             #define CvISXSUB(sv) CvXSUB(sv)
28             #endif
29              
30             #define DBI_MAGIC '~'
31              
32             /* HvMROMETA introduced in 5.9.5, but mro_meta_init not exported in 5.10.0 */
33             #if (PERL_VERSION < 10)
34             # define MY_cache_gen(stash) 0
35             #else
36             # if ((PERL_VERSION == 10) && (PERL_SUBVERSION == 0))
37             # define MY_cache_gen(stash) \
38             (HvAUX(stash)->xhv_mro_meta \
39             ? HvAUX(stash)->xhv_mro_meta->cache_gen \
40             : 0)
41             # else
42             # define MY_cache_gen(stash) HvMROMETA(stash)->cache_gen
43             # endif
44             #endif
45              
46             /* If the tests fail with errors about 'setlinebuf' then try */
47             /* deleting the lines in the block below except the setvbuf one */
48             #ifndef PerlIO_setlinebuf
49             #ifdef HAS_SETLINEBUF
50             #define PerlIO_setlinebuf(f) setlinebuf(f)
51             #else
52             #ifndef USE_PERLIO
53             #define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0)
54             #endif
55             #endif
56             #endif
57              
58             #ifndef CopFILEGV
59             # define CopFILEGV(cop) cop->cop_filegv
60             # define CopLINE(cop) cop->cop_line
61             # define CopSTASH(cop) cop->cop_stash
62             # define CopSTASHPV(cop) (CopSTASH(cop) ? HvNAME(CopSTASH(cop)) : Nullch)
63             #endif
64             #ifndef PERL_GET_THX
65             #define PERL_GET_THX ((void*)0)
66             #endif
67             #ifndef PerlProc_getpid
68             #define PerlProc_getpid() getpid()
69             extern Pid_t getpid (void);
70             #endif
71             #ifndef aTHXo_
72             #define aTHXo_
73             #endif
74              
75             #if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION == 0))
76             #define DBI_save_hv_fetch_ent
77             #endif
78              
79             /* prior to 5.8.9: when a CV is duped, the mg dup method is called,
80             * then *afterwards*, any_ptr is copied from the old CV to the new CV.
81             * This wipes out anything which the dup method did to any_ptr.
82             * This needs working around */
83             #if defined(USE_ITHREADS) && (PERL_VERSION == 8) && (PERL_SUBVERSION < 9)
84             # define BROKEN_DUP_ANY_PTR
85             #endif
86              
87             #ifndef warn_sv
88             static void warn_sv(SV *sv) { dTHX; warn("%" SVf, SVfARG(sv)); }
89             #endif
90             #ifndef croak_sv
91             static void croak_sv(SV *sv) { dTHX; sv_setsv(ERRSV, sv); croak(NULL); }
92             #endif
93              
94             /* types of method name */
95              
96             typedef enum {
97             methtype_ordinary, /* nothing special about this method name */
98             methtype_DESTROY,
99             methtype_FETCH,
100             methtype_can,
101             methtype_fetch_star, /* fetch*, i.e. fetch() or fetch_...() */
102             methtype_set_err
103             } meth_types;
104              
105              
106             static imp_xxh_t *dbih_getcom _((SV *h));
107             static imp_xxh_t *dbih_getcom2 _((pTHX_ SV *h, MAGIC **mgp));
108             static void dbih_clearcom _((imp_xxh_t *imp_xxh));
109             static int dbih_logmsg _((imp_xxh_t *imp_xxh, const char *fmt, ...));
110             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));
111             static SV *dbih_make_fdsv _((SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name));
112             static AV *dbih_get_fbav _((imp_sth_t *imp_sth));
113             static SV *dbih_event _((SV *h, const char *name, SV*, SV*));
114             static int dbih_set_attr_k _((SV *h, SV *keysv, int dbikey, SV *valuesv));
115             static SV *dbih_get_attr_k _((SV *h, SV *keysv, int dbikey));
116             static int dbih_sth_bind_col _((SV *sth, SV *col, SV *ref, SV *attribs));
117              
118             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));
119             static int set_err_sv _((SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method));
120             static int quote_type _((int sql_type, int p, int s, int *base_type, void *v));
121             static int sql_type_cast_svpv _((pTHX_ SV *sv, int sql_type, U32 flags, void *v));
122             static I32 dbi_hash _((const char *string, long i));
123             static void dbih_dumphandle _((pTHX_ SV *h, const char *msg, int level));
124             static int dbih_dumpcom _((pTHX_ imp_xxh_t *imp_xxh, const char *msg, int level));
125             static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg);
126             #if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
127             static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param);
128             #endif
129             char *neatsvpv _((SV *sv, STRLEN maxlen));
130             SV * preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void *foo);
131             static meth_types get_meth_type(const char * const name);
132              
133             struct imp_drh_st { dbih_drc_t com; };
134             struct imp_dbh_st { dbih_dbc_t com; };
135             struct imp_sth_st { dbih_stc_t com; };
136             struct imp_fdh_st { dbih_fdc_t com; };
137              
138             /* identify the type of a method name for dispatch behaviour */
139             /* (should probably be folded into the IMA flags mechanism) */
140              
141             static meth_types
142 35038           get_meth_type(const char * const name)
143             {
144 35038           switch (name[0]) {
145             case 'D':
146 584 100         if strEQ(name,"DESTROY")
147 292           return methtype_DESTROY;
148 292           break;
149             case 'F':
150 876 100         if strEQ(name,"FETCH")
151 292           return methtype_FETCH;
152 584           break;
153             case 'c':
154 2336 100         if strEQ(name,"can")
155 292           return methtype_can;
156 2044           break;
157             case 'f':
158 2969 100         if strnEQ(name,"fetch", 5) /* fetch* */
159 2044           return methtype_fetch_star;
160 925           break;
161             case 's':
162 4041 100         if strEQ(name,"set_err")
163 292           return methtype_set_err;
164 3749           break;
165             }
166 31826           return methtype_ordinary;
167             }
168              
169              
170             /* Internal Method Attributes (attached to dispatch methods when installed) */
171             /* NOTE: when adding SVs to dbi_ima_t, update dbi_ima_dup() dbi_ima_free()
172             * to ensure that they are duped and correctly ref-counted */
173              
174             typedef struct dbi_ima_st {
175             U8 minargs;
176             U8 maxargs;
177             IV hidearg;
178             /* method_trace controls tracing of method calls in the dispatcher:
179             - if the current trace flags include a trace flag in method_trace
180             then set trace_level to min(2,trace_level) for duration of the call.
181             - else, if trace_level < (method_trace & DBIc_TRACE_LEVEL_MASK)
182             then don't trace the call
183             */
184             U32 method_trace;
185             const char *usage_msg;
186             U32 flags;
187             meth_types meth_type;
188              
189             /* cached outer to inner method mapping */
190             HV *stash; /* the stash we found the GV in */
191             GV *gv; /* the GV containing the inner sub */
192             U32 generation; /* cache invalidation */
193             #ifdef BROKEN_DUP_ANY_PTR
194             PerlInterpreter *my_perl; /* who owns this struct */
195             #endif
196              
197             } dbi_ima_t;
198              
199             /* These values are embedded in the data passed to install_method */
200             #define IMA_HAS_USAGE 0x00000001 /* check parameter usage */
201             #define IMA_FUNC_REDIRECT 0x00000002 /* is $h->func(..., "method") */
202             #define IMA_KEEP_ERR 0x00000004 /* don't reset err & errstr */
203             #define IMA_KEEP_ERR_SUB 0x00000008 /* '' if in a nested call */
204             #define IMA_NO_TAINT_IN 0x00000010 /* don't check for PL_tainted args */
205             #define IMA_NO_TAINT_OUT 0x00000020 /* don't taint results */
206             #define IMA_COPY_UP_STMT 0x00000040 /* copy sth Statement to dbh */
207             #define IMA_END_WORK 0x00000080 /* method is commit or rollback */
208             #define IMA_STUB 0x00000100 /* donothing eg $dbh->connected */
209             #define IMA_CLEAR_STMT 0x00000200 /* clear Statement before call */
210             #define IMA_UNRELATED_TO_STMT 0x00000400 /* profile as empty Statement */
211             #define IMA_NOT_FOUND_OKAY 0x00000800 /* no error if not found */
212             #define IMA_EXECUTE 0x00001000 /* do/execute: DBIcf_Executed */
213             #define IMA_SHOW_ERR_STMT 0x00002000 /* dbh meth relates to Statement*/
214             #define IMA_HIDE_ERR_PARAMVALUES 0x00004000 /* ParamValues are not relevant */
215             #define IMA_IS_FACTORY 0x00008000 /* new h ie connect and prepare */
216             #define IMA_CLEAR_CACHED_KIDS 0x00010000 /* clear CachedKids before call */
217              
218             #define DBIc_STATE_adjust(imp_xxh, state) \
219             (SvOK(state) /* SQLSTATE is implemented by driver */ \
220             ? (strEQ(SvPV_nolen(state),"00000") ? &PL_sv_no : sv_mortalcopy(state))\
221             : (SvTRUE(DBIc_ERR(imp_xxh)) \
222             ? sv_2mortal(newSVpv("S1000",5)) /* General error */ \
223             : &PL_sv_no) /* Success ("00000") */ \
224             )
225              
226             #define DBI_LAST_HANDLE g_dbi_last_h /* special fake inner handle */
227             #define DBI_IS_LAST_HANDLE(h) ((DBI_LAST_HANDLE) == SvRV(h))
228             #define DBI_SET_LAST_HANDLE(h) ((DBI_LAST_HANDLE) = SvRV(h))
229             #define DBI_UNSET_LAST_HANDLE ((DBI_LAST_HANDLE) = &PL_sv_undef)
230             #define DBI_LAST_HANDLE_OK ((DBI_LAST_HANDLE) != &PL_sv_undef)
231              
232             #define DBIS_TRACE_LEVEL (DBIS->debug & DBIc_TRACE_LEVEL_MASK)
233             #define DBIS_TRACE_FLAGS (DBIS->debug) /* includes level */
234              
235             #ifdef PERL_LONG_MAX
236             #define MAX_LongReadLen PERL_LONG_MAX
237             #else
238             #define MAX_LongReadLen 2147483647L
239             #endif
240              
241             #ifdef DBI_USE_THREADS
242             static char *dbi_build_opt = "-ithread";
243             #else
244             static char *dbi_build_opt = "-nothread";
245             #endif
246              
247             /* 32 bit magic FNV-0 and FNV-1 prime */
248             #define FNV_32_PRIME ((UV)0x01000193)
249              
250              
251             /* perl doesn't know anything about the dbi_ima_t struct attached to the
252             * CvXSUBANY(cv).any_ptr slot, so add some magic to the CV to handle
253             * duping and freeing.
254             */
255              
256             static MGVTBL dbi_ima_vtbl = { 0, 0, 0, 0, dbi_ima_free,
257             0,
258             #if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
259             dbi_ima_dup
260             #else
261             0
262             #endif
263             #if (PERL_VERSION > 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION >= 9))
264             , 0
265             #endif
266             };
267              
268 0           static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg)
269             {
270 0           dbi_ima_t *ima = (dbi_ima_t *)(CvXSUBANY((CV*)sv).any_ptr);
271             #ifdef BROKEN_DUP_ANY_PTR
272             if (ima->my_perl != my_perl)
273             return 0;
274             #endif
275 0           SvREFCNT_dec(ima->stash);
276 0           SvREFCNT_dec(ima->gv);
277 0           Safefree(ima);
278 0           return 0;
279             }
280              
281             #if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
282             static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param)
283             {
284             dbi_ima_t *ima, *nima;
285             CV *cv = (CV*) mg->mg_ptr;
286             CV *ncv = (CV*)ptr_table_fetch(PL_ptr_table, (cv));
287              
288             PERL_UNUSED_VAR(param);
289             mg->mg_ptr = (char *)ncv;
290             ima = (dbi_ima_t*) CvXSUBANY(cv).any_ptr;
291             Newx(nima, 1, dbi_ima_t);
292             *nima = *ima; /* structure copy */
293             CvXSUBANY(ncv).any_ptr = nima;
294             nima->stash = NULL;
295             nima->gv = NULL;
296             return 0;
297             }
298             #endif
299              
300              
301              
302             /* --- make DBI safe for multiple perl interpreters --- */
303             /* Originally contributed by Murray Nesbitt of ActiveState, */
304             /* but later updated to use MY_CTX */
305              
306             #define MY_CXT_KEY "DBI::_guts" XS_VERSION
307              
308             typedef struct {
309             SV *dbi_last_h; /* maybe better moved into dbistate_t? */
310             dbistate_t* dbi_state;
311             } my_cxt_t;
312              
313             START_MY_CXT
314              
315             #undef DBIS
316             #define DBIS (MY_CXT.dbi_state)
317              
318             #define g_dbi_last_h (MY_CXT.dbi_last_h)
319              
320             /* allow the 'static' dbi_state struct to be accessed from other files */
321             dbistate_t**
322 0           _dbi_state_lval(pTHX)
323             {
324             dMY_CXT;
325 0           return &(MY_CXT.dbi_state);
326             }
327              
328              
329             /* --- */
330              
331             static void *
332 15476           malloc_using_sv(STRLEN len)
333             {
334             dTHX;
335 15476           SV *sv = newSV(len);
336 15476           void *p = SvPVX(sv);
337 15476           memzero(p, len);
338 15476           return p;
339             }
340              
341             static char *
342 15184           savepv_using_sv(char *str)
343             {
344 15184           char *buf = malloc_using_sv(strlen(str));
345 15184           strcpy(buf, str);
346 15184           return buf;
347             }
348              
349              
350             /* --- support functions for concat_hash_sorted --- */
351              
352             typedef struct str_uv_sort_pair_st {
353             char *key;
354             UV numeric;
355             } str_uv_sort_pair_t;
356              
357             static int
358 36230           _cmp_number(const void *val1, const void *val2)
359             {
360 36230           UV first = ((str_uv_sort_pair_t *)val1)->numeric;
361 36230           UV second = ((str_uv_sort_pair_t *)val2)->numeric;
362              
363 36230 100         if (first > second)
364 18383           return 1;
365 17847 100         if (first < second)
366 17791           return -1;
367             /* only likely to reach here if numeric sort forced for non-numeric keys */
368             /* fallback to comparing the key strings */
369 56           return strcmp(
370 56           ((str_uv_sort_pair_t *)val1)->key,
371 56           ((str_uv_sort_pair_t *)val2)->key
372             );
373             }
374              
375             static int
376 55233           _cmp_str (const void *val1, const void *val2)
377             {
378 55233           return strcmp( *(char **)val1, *(char **)val2);
379             }
380              
381             static char **
382 3317           _sort_hash_keys (HV *hash, int num_sort, STRLEN *total_length)
383             {
384             dTHX;
385             I32 hv_len, key_len;
386             HE *entry;
387             char **keys;
388 3317           unsigned int idx = 0;
389 3317           STRLEN tot_len = 0;
390 3317           bool has_non_numerics = 0;
391             str_uv_sort_pair_t *numbers;
392              
393 3317           hv_len = hv_iterinit(hash);
394 3317 100         if (!hv_len)
395 8           return 0;
396              
397 3309 50         Newz(0, keys, hv_len, char *);
398 3309 50         Newz(0, numbers, hv_len, str_uv_sort_pair_t);
399              
400 34237 100         while ((entry = hv_iternext(hash))) {
401 30928           *(keys+idx) = hv_iterkey(entry, &key_len);
402 30928           tot_len += key_len;
403            
404 30928 100         if (grok_number(*(keys+idx), key_len, &(numbers+idx)->numeric) != IS_NUMBER_IN_UV) {
405 26512           has_non_numerics = 1;
406 26512           (numbers+idx)->numeric = 0;
407             }
408              
409 30928           (numbers+idx)->key = *(keys+idx);
410 30928           ++idx;
411             }
412              
413 3309 50         if (total_length)
414 3309           *total_length = tot_len;
415              
416 3309 100         if (num_sort < 0)
417 42 100         num_sort = (has_non_numerics) ? 0 : 1;
418              
419 3309 100         if (!num_sort) {
420 3267           qsort(keys, hv_len, sizeof(char*), _cmp_str);
421             }
422             else {
423 42           qsort(numbers, hv_len, sizeof(str_uv_sort_pair_t), _cmp_number);
424 4430 100         for (idx = 0; idx < hv_len; ++idx)
425 4388           *(keys+idx) = (numbers+idx)->key;
426             }
427              
428 3309           Safefree(numbers);
429 3317           return keys;
430             }
431              
432              
433             static SV *
434 3317           _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)
435             {
436             dTHX;
437             I32 hv_len;
438 3317           STRLEN total_len = 0;
439             char **keys;
440 3317           unsigned int i = 0;
441             SV *return_sv;
442              
443 3317           keys = _sort_hash_keys(hash, num_sort, &total_len);
444 3317 100         if (!keys)
445 8           return newSVpv("", 0);
446              
447 3309 50         if (!kv_sep_len)
448 0           kv_sep_len = strlen(kv_sep);
449 3309 50         if (!pair_sep_len)
450 0           pair_sep_len = strlen(pair_sep);
451              
452 3309           hv_len = hv_iterinit(hash);
453             /* total_len += Separators + quotes + term null */
454 3309           total_len += kv_sep_len*hv_len + pair_sep_len*hv_len+2*hv_len+1;
455 3309           return_sv = newSV(total_len);
456 3309           sv_setpv(return_sv, ""); /* quell undef warnings */
457              
458 34237 100         for (i=0; i
459 30928           SV **hash_svp = hv_fetch(hash, keys[i], strlen(keys[i]), 0);
460              
461 30928           sv_catpv(return_sv, keys[i]); /* XXX keys can't contain nul chars */
462 30928           sv_catpvn(return_sv, kv_sep, kv_sep_len);
463              
464 30928 50         if (!hash_svp) { /* should never happen */
465 0           warn("No hash entry with key '%s'", keys[i]);
466 0           sv_catpvn(return_sv, "???", 3);
467 0           continue;
468             }
469              
470 30928 100         if (use_neat) {
471 4412           sv_catpv(return_sv, neatsvpv(*hash_svp,0));
472             }
473             else {
474 46273 100         if (SvOK(*hash_svp)) {
    50          
    50          
475             STRLEN hv_val_len;
476 19757 100         char *hv_val = SvPV(*hash_svp, hv_val_len);
477 19757           sv_catpvn(return_sv, "'", 1);
478 19757           sv_catpvn(return_sv, hv_val, hv_val_len);
479 19757           sv_catpvn(return_sv, "'", 1);
480             }
481 6759           else sv_catpvn(return_sv, "undef", 5);
482             }
483              
484 30928 100         if (i < hv_len-1)
485 27619           sv_catpvn(return_sv, pair_sep, pair_sep_len);
486             }
487              
488 3309           Safefree(keys);
489              
490 3317           return return_sv;
491             }
492              
493              
494              
495             /* handy for embedding into condition expression for debugging */
496             /*
497             static int warn1(char *s) { warn("%s", s); return 1; }
498             static int dump1(SV *sv) { dTHX; sv_dump(sv); return 1; }
499             */
500              
501              
502             /* --- */
503              
504             static void
505 0           check_version(const char *name, int dbis_cv, int dbis_cs, int need_dbixs_cv, int drc_s,
506             int dbc_s, int stc_s, int fdc_s)
507             {
508             dTHX;
509             dMY_CXT;
510             static const char msg[] = "you probably need to rebuild the DBD driver (or possibly the DBI)";
511             (void)need_dbixs_cv;
512 0 0         if (dbis_cv != DBISTATE_VERSION || dbis_cs != sizeof(*DBIS))
    0          
513 0           croak("DBI/DBD internal version mismatch (DBI is v%d/s%lu, DBD %s expected v%d/s%d) %s.\n",
514             DBISTATE_VERSION, (long unsigned int)sizeof(*DBIS), name, dbis_cv, dbis_cs, msg);
515             /* Catch structure size changes - We should probably force a recompile if the DBI */
516             /* runtime version is different from the build time. That would be harsh but safe. */
517 0 0         if (drc_s != sizeof(dbih_drc_t) || dbc_s != sizeof(dbih_dbc_t) ||
    0          
    0          
518 0 0         stc_s != sizeof(dbih_stc_t) || fdc_s != sizeof(dbih_fdc_t) )
519 0           croak("%s (dr:%d/%ld, db:%d/%ld, st:%d/%ld, fd:%d/%ld), %s.\n",
520             "DBI/DBD internal structure mismatch",
521             drc_s, (long)sizeof(dbih_drc_t), dbc_s, (long)sizeof(dbih_dbc_t),
522             stc_s, (long)sizeof(dbih_stc_t), fdc_s, (long)sizeof(dbih_fdc_t), msg);
523 0           }
524              
525             static void
526 292           dbi_bootinit(dbistate_t * parent_dbis)
527             {
528             dTHX;
529             dMY_CXT;
530             dbistate_t* DBISx;
531              
532 292           DBISx = (struct dbistate_st*)malloc_using_sv(sizeof(struct dbistate_st));
533 292           DBIS = DBISx;
534              
535             /* make DBIS available to DBD modules the "old" (<= 1.618) way,
536             * so that unrecompiled DBD's will still work against a newer DBI */
537 292           sv_setiv(get_sv("DBI::_dbistate", GV_ADDMULTI),
538             PTR2IV(MY_CXT.dbi_state));
539              
540             /* store version and size so we can spot DBI/DBD version mismatch */
541 292           DBIS->check_version = check_version;
542 292           DBIS->version = DBISTATE_VERSION;
543 292           DBIS->size = sizeof(*DBIS);
544 292           DBIS->xs_version = DBIXS_VERSION;
545              
546 292           DBIS->logmsg = dbih_logmsg;
547 292           DBIS->logfp = PerlIO_stderr();
548 876 50         DBIS->debug = (parent_dbis) ? parent_dbis->debug
    50          
549 584           : SvIV(get_sv("DBI::dbi_debug",0x5));
550 584           DBIS->neatsvpvlen = (parent_dbis) ? parent_dbis->neatsvpvlen
551 292 50         : get_sv("DBI::neat_maxlen", GV_ADDMULTI);
552             #ifdef DBI_USE_THREADS
553             DBIS->thr_owner = PERL_GET_THX;
554             #endif
555              
556             /* store some function pointers so DBD's can call our functions */
557 292           DBIS->getcom = dbih_getcom;
558 292           DBIS->clearcom = dbih_clearcom;
559 292           DBIS->event = dbih_event;
560 292           DBIS->set_attr_k = dbih_set_attr_k;
561 292           DBIS->get_attr_k = dbih_get_attr_k;
562 292           DBIS->get_fbav = dbih_get_fbav;
563 292           DBIS->make_fdsv = dbih_make_fdsv;
564 292           DBIS->neat_svpv = neatsvpv;
565 292           DBIS->bind_as_num = quote_type; /* XXX deprecated */
566 292           DBIS->hash = dbi_hash;
567 292           DBIS->set_err_sv = set_err_sv;
568 292           DBIS->set_err_char= set_err_char;
569 292           DBIS->bind_col = dbih_sth_bind_col;
570 292           DBIS->sql_type_cast_svpv = sql_type_cast_svpv;
571              
572              
573             /* Remember the last handle used. BEWARE! Sneaky stuff here! */
574             /* We want a handle reference but we don't want to increment */
575             /* the handle's reference count and we don't want perl to try */
576             /* to destroy it during global destruction. Take care! */
577 292           DBI_UNSET_LAST_HANDLE; /* ensure setup the correct way */
578              
579             /* trick to avoid 'possible typo' warnings */
580 292           gv_fetchpv("DBI::state", GV_ADDMULTI, SVt_PV);
581 292           gv_fetchpv("DBI::err", GV_ADDMULTI, SVt_PV);
582 292           gv_fetchpv("DBI::errstr", GV_ADDMULTI, SVt_PV);
583 292           gv_fetchpv("DBI::lasth", GV_ADDMULTI, SVt_PV);
584 292           gv_fetchpv("DBI::rows", GV_ADDMULTI, SVt_PV);
585              
586             /* we only need to check the env var on the initial boot
587             * which is handy because it can core dump during CLONE on windows
588             */
589 292 50         if (!parent_dbis && getenv("PERL_DBI_XSBYPASS"))
    50          
590 0           use_xsbypass = atoi(getenv("PERL_DBI_XSBYPASS"));
591 292           }
592              
593              
594             /* ----------------------------------------------------------------- */
595             /* Utility functions */
596              
597              
598             static char *
599 60           dbih_htype_name(int htype)
600             {
601 60           switch(htype) {
602 3           case DBIt_DR: return "dr";
603 11           case DBIt_DB: return "db";
604 46           case DBIt_ST: return "st";
605 0           case DBIt_FD: return "fd";
606 0           default: return "??";
607             }
608             }
609              
610              
611             char *
612 6005           neatsvpv(SV *sv, STRLEN maxlen) /* return a tidy ascii value, for debugging only */
613             {
614             dTHX;
615             dMY_CXT;
616             STRLEN len;
617 6005           SV *nsv = Nullsv;
618 6005           SV *infosv = Nullsv;
619             char *v, *quote;
620              
621             /* We take care not to alter the supplied sv in any way at all. */
622             /* (but if it is SvGMAGICAL we have to call mg_get and that can */
623             /* have side effects, especially as it may be called twice overall.) */
624              
625 6005 100         if (!sv)
626 3           return "Null!"; /* should never happen */
627              
628             /* try to do the right thing with magical values */
629 6002 100         if (SvMAGICAL(sv)) {
630 96 100         if (DBIS_TRACE_LEVEL >= 5) { /* add magic details to help debugging */
631             MAGIC* mg;
632 33           infosv = sv_2mortal(newSVpv(" (magic-",0));
633 33 50         if (SvSMAGICAL(sv)) sv_catpvn(infosv,"s",1);
634 33 50         if (SvGMAGICAL(sv)) sv_catpvn(infosv,"g",1);
635 33 50         if (SvRMAGICAL(sv)) sv_catpvn(infosv,"r",1);
636 33           sv_catpvn(infosv,":",1);
637 66 100         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
638 33           sv_catpvn(infosv, &mg->mg_type, 1);
639 33           sv_catpvn(infosv, ")", 1);
640             }
641 96 100         if (SvGMAGICAL(sv) && !PL_dirty)
    50          
642 36           mg_get(sv); /* trigger magic to FETCH the value */
643             }
644              
645 6002 100         if (!SvOK(sv)) {
    50          
    50          
646 4463 100         if (SvTYPE(sv) >= SVt_PVAV)
647 12           return (char *)sv_reftype(sv,0); /* raw AV/HV etc, not via a ref */
648 4451 100         if (!infosv)
649 4442           return "undef";
650 9           sv_insert(infosv, 0,0, "undef",5);
651 9           return SvPVX(infosv);
652             }
653              
654 1539 100         if (SvNIOK(sv)) { /* is a numeric value - so no surrounding quotes */
655 365 100         if (SvPOK(sv)) { /* already has string version of the value, so use it */
656 150 50         v = SvPV(sv,len);
657 150 100         if (len == 0) { v="''"; len=2; } /* catch &sv_no style special case */
658 150 50         if (!infosv)
659 150           return v;
660 0           sv_insert(infosv, 0,0, v, len);
661 0           return SvPVX(infosv);
662             }
663             /* we don't use SvPV here since we don't want to alter sv in _any_ way */
664 215 50         if (SvUOK(sv))
665 0           nsv = newSVpvf("%"UVuf, SvUVX(sv));
666 215 100         else if (SvIOK(sv))
667 202           nsv = newSVpvf("%"IVdf, SvIVX(sv));
668 13           else nsv = newSVpvf("%"NVgf, SvNVX(sv));
669 215 100         if (infosv)
670 6           sv_catsv(nsv, infosv);
671 215           return SvPVX(sv_2mortal(nsv));
672             }
673              
674 1174           nsv = sv_newmortal();
675 1174           sv_upgrade(nsv, SVt_PV);
676              
677 1174 100         if (SvROK(sv)) {
678 439 50         if (!SvAMAGIC(sv)) /* (un-amagic'd) refs get no special treatment */
    100          
    100          
679 438 50         v = SvPV(sv,len);
680             else {
681             /* handle Overload magic refs */
682 1           (void)SvAMAGIC_off(sv); /* should really be done via local scoping */
683 1 50         v = SvPV(sv,len); /* XXX how does this relate to SvGMAGIC? */
684 1           SvAMAGIC_on(sv);
685             }
686 439           sv_setpvn(nsv, v, len);
687 439 100         if (infosv)
688 3           sv_catsv(nsv, infosv);
689 439 50         return SvPV(nsv, len);
690             }
691              
692 735 50         if (SvPOK(sv)) /* usual simple string case */
693 735 50         v = SvPV(sv,len);
694             else /* handles all else via sv_2pv() */
695 0 0         v = SvPV(sv,len); /* XXX how does this relate to SvGMAGIC? */
696              
697             /* for strings we limit the length and translate codes */
698 735 100         if (maxlen == 0)
699 632 50         maxlen = SvIV(DBIS->neatsvpvlen);
700 735 50         if (maxlen < 6) /* handle daft values */
701 0           maxlen = 6;
702 735           maxlen -= 2; /* account for quotes */
703              
704 735 50         quote = (SvUTF8(sv)) ? "\"" : "'";
705 735 100         if (len > maxlen) {
706 6 50         SvGROW(nsv, (1+maxlen+1+1));
    50          
707 6           sv_setpvn(nsv, quote, 1);
708 6           sv_catpvn(nsv, v, maxlen-3); /* account for three dots */
709 6           sv_catpvn(nsv, "...", 3);
710             } else {
711 729 50         SvGROW(nsv, (1+len+1+1));
    50          
712 729           sv_setpvn(nsv, quote, 1);
713 729           sv_catpvn(nsv, v, len);
714             }
715 735           sv_catpvn(nsv, quote, 1);
716 735 100         if (infosv)
717 6           sv_catsv(nsv, infosv);
718 735 50         v = SvPV(nsv, len);
719 735 50         if (!SvUTF8(sv)) {
720 8785 100         while(len-- > 0) { /* cleanup string (map control chars to ascii etc) */
721 8050           const char c = v[len] & 0x7F; /* ignore top bit for multinational chars */
722 8050 100         if (!isPRINT(c) && !isSPACE(c))
    100          
723 2           v[len] = '.';
724             }
725             }
726 6005           return v;
727             }
728              
729              
730             static void
731 11319           copy_statement_to_parent(pTHX_ SV *h, imp_xxh_t *imp_xxh)
732             {
733             SV *parent;
734 11319 50         if (PL_dirty)
735 0           return;
736 11319           parent = DBIc_PARENT_H(imp_xxh);
737 11319 50         if (parent && SvROK(parent)) {
    100          
738 11285           SV *tmp_sv = *hv_fetch((HV*)SvRV(h), "Statement", 9, 1);
739 11285 100         if (SvOK(tmp_sv))
    50          
    50          
740 9730           (void)hv_store((HV*)SvRV(parent), "Statement", 9, SvREFCNT_inc(tmp_sv), 0);
741             }
742             }
743              
744              
745             static int
746 16           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)
747             {
748             dTHX;
749             char err_buf[28];
750             SV *err_sv, *errstr_sv, *state_sv, *method_sv;
751 16 50         if (!err_c) {
752 0           sprintf(err_buf, "%ld", (long)err_i);
753 0           err_c = &err_buf[0];
754             }
755 16 50         err_sv = (strEQ(err_c,"1")) ? &PL_sv_yes : sv_2mortal(newSVpvn(err_c, strlen(err_c)));
756 16           errstr_sv = sv_2mortal(newSVpvn(errstr, strlen(errstr)));
757 16 50         state_sv = (state && *state) ? sv_2mortal(newSVpvn(state, strlen(state))) : &PL_sv_undef;
    0          
758 16 100         method_sv = (method && *method) ? sv_2mortal(newSVpvn(method, strlen(method))) : &PL_sv_undef;
    50          
759 16           return set_err_sv(h, imp_xxh, err_sv, errstr_sv, state_sv, method_sv);
760             }
761              
762              
763             static int
764 9381           set_err_sv(SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method)
765             {
766             dTHX;
767             SV *h_err;
768             SV *h_errstr;
769             SV *h_state;
770             SV **hook_svp;
771 9381           int err_changed = 0;
772              
773 9381 100         if ( DBIc_has(imp_xxh, DBIcf_HandleSetErr)
774 38 50         && (hook_svp = hv_fetch((HV*)SvRV(h),"HandleSetErr",12,0))
775 38 50         && hook_svp
776 38 50         && ((void)(SvGMAGICAL(*hook_svp) && mg_get(*hook_svp)), SvOK(*hook_svp))
    0          
    50          
    0          
    0          
    50          
777 36           ) {
778 38           dSP;
779             IV items;
780             SV *response_sv;
781 38 100         if (SvREADONLY(err)) err = sv_mortalcopy(err);
782 38 100         if (SvREADONLY(errstr)) errstr = sv_mortalcopy(errstr);
783 38 50         if (SvREADONLY(state)) state = sv_mortalcopy(state);
784 38 50         if (SvREADONLY(method)) method = sv_mortalcopy(method);
785 38 50         if (DBIc_TRACE_LEVEL(imp_xxh) >= 2)
786 0           PerlIO_printf(DBIc_LOGPIO(imp_xxh)," -> HandleSetErr(%s, err=%s, errstr=%s, state=%s, %s)\n",
787             neatsvpv(h,0), neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0),
788             neatsvpv(method,0)
789             );
790 38 50         PUSHMARK(SP);
791 38 50         XPUSHs(sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh))));
792 38 50         XPUSHs(err);
793 38 50         XPUSHs(errstr);
794 38 50         XPUSHs(state);
795 38 50         XPUSHs(method);
796 38           PUTBACK;
797 38           items = call_sv(*hook_svp, G_SCALAR);
798 38           SPAGAIN;
799 38 50         response_sv = (items) ? POPs : &PL_sv_undef;
800 38           PUTBACK;
801 38 50         if (DBIc_TRACE_LEVEL(imp_xxh) >= 1)
802 0           PerlIO_printf(DBIc_LOGPIO(imp_xxh)," <- HandleSetErr= %s (err=%s, errstr=%s, state=%s, %s)\n",
803             neatsvpv(response_sv,0), neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0),
804             neatsvpv(method,0)
805             );
806 38 50         if (SvTRUE(response_sv)) /* handler says it has handled it, so... */
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    100          
    50          
    0          
    100          
807 2           return 0;
808             }
809             else {
810 9343 100         if (DBIc_TRACE_LEVEL(imp_xxh) >= 2)
811 4           PerlIO_printf(DBIc_LOGPIO(imp_xxh)," -- HandleSetErr err=%s, errstr=%s, state=%s, %s\n",
812             neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0), neatsvpv(method,0)
813             );
814             }
815              
816 9379 100         if (!SvOK(err)) { /* clear err / errstr / state */
    50          
    50          
817 6048 50         DBIh_CLEAR_ERROR(imp_xxh);
    50          
    50          
818 6048           return 1;
819             }
820              
821             /* fetch these after calling HandleSetErr */
822 3331           h_err = DBIc_ERR(imp_xxh);
823 3331           h_errstr = DBIc_ERRSTR(imp_xxh);
824 3331           h_state = DBIc_STATE(imp_xxh);
825              
826 3331 50         if (SvTRUE(h_errstr)) {
    50          
    0          
    100          
    50          
    50          
    50          
    50          
    100          
    50          
    0          
    100          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
827             /* append current err, if any, to errstr if it's going to change */
828 27 50         if (SvTRUE(h_err) && SvTRUE(err) && strNE(SvPV_nolen(h_err), SvPV_nolen(err)))
    50          
    50          
    0          
    0          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    0          
    0          
    100          
    50          
    50          
    50          
    0          
    0          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    0          
    100          
    100          
    100          
    100          
829 10 50         sv_catpvf(h_errstr, " [err was %s now %s]", SvPV_nolen(h_err), SvPV_nolen(err));
    50          
830 27 50         if (SvTRUE(h_state) && SvTRUE(state) && strNE(SvPV_nolen(h_state), SvPV_nolen(state)))
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    50          
    50          
    100          
831 4 50         sv_catpvf(h_errstr, " [state was %s now %s]", SvPV_nolen(h_state), SvPV_nolen(state));
    50          
832 52 50         if (strNE(SvPV_nolen(h_errstr), SvPV_nolen(errstr))) {
    50          
    100          
833 25           sv_catpvn(h_errstr, "\n", 1);
834 25           sv_catsv(h_errstr, errstr);
835             }
836             }
837             else
838 3304           sv_setsv(h_errstr, errstr);
839              
840             /* SvTRUE(err) > "0" > "" > undef */
841 3331 50         if (SvTRUE(err) /* new error: so assign */
    50          
    0          
    50          
    0          
    0          
    100          
    50          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    50          
    0          
    100          
    0          
842 21 100         || !SvOK(h_err) /* no existing warn/info: so assign */
    50          
    50          
843             /* new warn ("0" len 1) > info ("" len 0): so assign */
844 12 50         || (SvOK(err) && strlen(SvPV_nolen(err)) > strlen(SvPV_nolen(h_err)))
    0          
    0          
    100          
    50          
    100          
845             ) {
846 3322           sv_setsv(h_err, err);
847 3322           err_changed = 1;
848 3322 50         if (SvTRUE(h_err)) /* new error */
    50          
    50          
    0          
    0          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    0          
    0          
    100          
849 3310           ++DBIc_ErrCount(imp_xxh);
850             }
851              
852 3331 100         if (err_changed) {
853 3322 50         if (SvTRUE(state)) {
    50          
    0          
    100          
    50          
    50          
    50          
    50          
    100          
    50          
    0          
    100          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
854 2996 50         if (strlen(SvPV_nolen(state)) != 5) {
    50          
855 0           warn("set_err: state (%s) is not a 5 character string, using 'S1000' instead", neatsvpv(state,0));
856 0           sv_setpv(h_state, "S1000");
857             }
858             else
859 1498           sv_setsv(h_state, state);
860             }
861             else
862 1824 50         (void)SvOK_off(h_state); /* see DBIc_STATE_adjust */
863              
864             /* ensure that the parent's Statement attribute reflects the latest error */
865             /* so that ShowErrorStatement is reliable */
866 3322           copy_statement_to_parent(aTHX_ h, imp_xxh);
867             }
868              
869 3331           return 1;
870             }
871              
872              
873             /* err_hash returns a U32 'hash' value representing the current err 'level'
874             * (err/warn/info) and errstr. It's used by the dispatcher as a way to detect
875             * a new or changed warning during a 'keep err' method like STORE. Always returns >0.
876             * The value is 1 for no err/warn/info and guarantees that err > warn > info.
877             * (It's a bit of a hack but the original approach in 70fe6bd76 using a new
878             * ErrChangeCount attribute would break binary compatibility with drivers.)
879             * The chance that two realistic errstr values would hash the same, even with
880             * only 30 bits, is deemed to small to even bother documenting.
881             */
882             static U32
883 512953           err_hash(pTHX_ imp_xxh_t *imp_xxh)
884             {
885 512953           SV *err_sv = DBIc_ERR(imp_xxh);
886             SV *errstr_sv;
887 512953           I32 hash = 1;
888 512953 100         if (SvOK(err_sv)) {
    50          
    50          
889 4506           errstr_sv = DBIc_ERRSTR(imp_xxh);
890 4506 50         if (SvOK(errstr_sv))
    0          
    0          
891 4506 50         hash = -dbi_hash(SvPV_nolen(errstr_sv), 0); /* make positive */
892 0           else hash = 0;
893 4506           hash >>= 1; /* free up extra bit (top bit is already free) */
894 9012 0         hash |= (SvTRUE(err_sv)) ? 0x80000000 /* err */
    0          
    0          
    50          
    100          
    100          
    100          
    100          
    50          
    50          
    0          
    0          
    50          
    0          
895 9012 50         : (SvPOK(err_sv) && !SvCUR(err_sv)) ? 0x20000000 /* '' = info */
    50          
    50          
    100          
    50          
    50          
    100          
896             : 0x40000000;/* 0 or '0' = warn */
897             }
898 512953           return hash;
899             }
900              
901              
902             static char *
903 29563           mkvname(pTHX_ HV *stash, const char *item, int uplevel) /* construct a variable name */
904             {
905 29563           SV *sv = sv_newmortal();
906 29563 50         sv_setpv(sv, HvNAME(stash));
    50          
    50          
    0          
    50          
    50          
907 29563 50         if(uplevel) {
908 0 0         while(SvCUR(sv) && *SvEND(sv)!=':')
    0          
909 0           --SvCUR(sv);
910 0 0         if (SvCUR(sv))
911 0           --SvCUR(sv);
912             }
913 29563           sv_catpv(sv, "::");
914 29563           sv_catpv(sv, item);
915 29563 50         return SvPV_nolen(sv);
916             }
917              
918             /* 32 bit magic FNV-0 and FNV-1 prime */
919             #define FNV_32_PRIME ((UV)0x01000193)
920              
921             static I32
922 4516           dbi_hash(const char *key, long type)
923             {
924 4516 100         if (type == 0) {
925 4512           STRLEN klen = strlen(key);
926 4512           U32 hash = 0;
927 354468 100         while (klen--)
928 349956           hash = hash * 33 + *key++;
929 4512           hash &= 0x7FFFFFFF; /* limit to 31 bits */
930 4512           hash |= 0x40000000; /* set bit 31 */
931 4512           return -(I32)hash; /* return negative int */
932             }
933 4 50         else if (type == 1) { /* Fowler/Noll/Vo hash */
934             /* see http://www.isthe.com/chongo/tech/comp/fnv/ */
935 4           U32 hash = 0x811c9dc5;
936 4           const unsigned char *s = (unsigned char *)key; /* unsigned string */
937 20 100         while (*s) {
938             /* multiply by the 32 bit FNV magic prime mod 2^32 */
939 16           hash *= FNV_32_PRIME;
940             /* xor the bottom with the current octet */
941 16           hash ^= (U32)*s++;
942             }
943 4           return hash;
944             }
945 0           croak("DBI::hash(%ld): invalid type", type);
946             return 0; /* NOT REACHED */
947             }
948              
949              
950             static int
951 0           dbih_logmsg(imp_xxh_t *imp_xxh, const char *fmt, ...)
952             {
953             dTHX;
954             va_list args;
955             #ifdef I_STDARG
956 0           va_start(args, fmt);
957             #else
958             va_start(args);
959             #endif
960 0           (void) PerlIO_vprintf(DBIc_DBISTATE(imp_xxh)->logfp, fmt, args);
961 0           va_end(args);
962             (void)imp_xxh;
963 0           return 1;
964             }
965              
966             static void
967 38           close_trace_file(pTHX)
968             {
969             dMY_CXT;
970 38 100         if (DBILOGFP == PerlIO_stderr() || DBILOGFP == PerlIO_stdout())
    100          
971 20           return;
972              
973 18 100         if (DBIS->logfp_ref == NULL)
974 8           PerlIO_close(DBILOGFP);
975             else {
976             /* DAA dec refcount and discard */
977 10           SvREFCNT_dec(DBIS->logfp_ref);
978 10           DBIS->logfp_ref = NULL;
979             }
980             }
981              
982             static int
983 190           set_trace_file(SV *file)
984             {
985             dTHX;
986             dMY_CXT;
987             const char *filename;
988 190           PerlIO *fp = Nullfp;
989             IO *io;
990              
991 190 100         if (!file) /* no arg == no change */
992 152           return 0;
993              
994             /* DAA check for a filehandle */
995 38 100         if (SvROK(file)) {
996 8           io = sv_2io(file);
997 8 50         if (!io || !(fp = IoOFP(io))) {
    50          
998 0           warn("DBI trace filehandle is not valid");
999 0           return 0;
1000             }
1001 8           close_trace_file(aTHX);
1002 8           (void)SvREFCNT_inc(io);
1003 8           DBIS->logfp_ref = io;
1004             }
1005 30 100         else if (isGV_with_GP(file)) {
    50          
    0          
1006 4 50         io = GvIO(file);
    50          
    0          
    50          
1007 4 50         if (!io || !(fp = IoOFP(io))) {
    50          
1008 0           warn("DBI trace filehandle from GLOB is not valid");
1009 0           return 0;
1010             }
1011 4           close_trace_file(aTHX);
1012 4           (void)SvREFCNT_inc(io);
1013 4           DBIS->logfp_ref = io;
1014             }
1015             else {
1016 26 100         filename = (SvOK(file)) ? SvPV_nolen(file) : Nullch;
    50          
    50          
    50          
1017             /* undef arg == reset back to stderr */
1018 26 100         if (!filename || strEQ(filename,"STDERR")
    100          
1019 20 50         || strEQ(filename,"*main::STDERR")) {
1020 6           close_trace_file(aTHX);
1021 6           DBILOGFP = PerlIO_stderr();
1022 6           return 1;
1023             }
1024 20 100         if (strEQ(filename,"STDOUT")) {
1025 12           close_trace_file(aTHX);
1026 12           DBILOGFP = PerlIO_stdout();
1027 12           return 1;
1028             }
1029 8           fp = PerlIO_open(filename, "a+");
1030 8 50         if (fp == Nullfp) {
1031 0           warn("Can't open trace file %s: %s", filename, Strerror(errno));
1032 0           return 0;
1033             }
1034 8           close_trace_file(aTHX);
1035             }
1036 20           DBILOGFP = fp;
1037             /* if this line causes your compiler or linker to choke */
1038             /* then just comment it out, it's not essential. */
1039 20           PerlIO_setlinebuf(fp); /* force line buffered output */
1040 20           return 1;
1041             }
1042              
1043             static IV
1044 190           parse_trace_flags(SV *h, SV *level_sv, IV old_level)
1045             {
1046             dTHX;
1047             IV level;
1048 190 50         if (!level_sv || !SvOK(level_sv))
    100          
    50          
    50          
1049 46           level = old_level; /* undef: no change */
1050             else
1051 144 50         if (SvTRUE(level_sv)) {
    50          
    0          
    50          
    0          
    0          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    0          
    100          
    0          
1052 168 100         if (looks_like_number(level_sv))
1053 58 50         level = SvIV(level_sv); /* number: number */
1054             else { /* string: parse it */
1055 26           dSP;
1056 26 50         PUSHMARK(sp);
1057 26 50         XPUSHs(h);
1058 26 50         XPUSHs(level_sv);
1059 26           PUTBACK;
1060 26 50         if (call_method("parse_trace_flags", G_SCALAR) != 1)
1061 0           croak("panic: parse_trace_flags");/* should never happen */
1062 26           SPAGAIN;
1063 26 50         level = POPi;
1064 26           PUTBACK;
1065             }
1066             }
1067             else /* defined but false: 0 */
1068 60           level = 0;
1069 190           return level;
1070             }
1071              
1072              
1073             static int
1074 166           set_trace(SV *h, SV *level_sv, SV *file)
1075             {
1076             dTHX;
1077 166           D_imp_xxh(h);
1078 166           int RETVAL = DBIc_DBISTATE(imp_xxh)->debug; /* Return trace level in effect now */
1079 166           IV level = parse_trace_flags(h, level_sv, RETVAL);
1080 166           set_trace_file(file);
1081 166 100         if (level != RETVAL) { /* set value */
1082 80 100         if ((level & DBIc_TRACE_LEVEL_MASK) > 0) {
1083 8           PerlIO_printf(DBIc_LOGPIO(imp_xxh),
1084             " %s trace level set to 0x%lx/%ld (DBI @ 0x%lx/%ld) in DBI %s%s (pid %d)\n",
1085             neatsvpv(h,0),
1086             (long)(level & DBIc_TRACE_FLAGS_MASK),
1087             (long)(level & DBIc_TRACE_LEVEL_MASK),
1088 16           (long)DBIc_TRACE_FLAGS(imp_xxh), (long)DBIc_TRACE_LEVEL(imp_xxh),
1089 8           XS_VERSION, dbi_build_opt, (int)PerlProc_getpid());
1090 8 50         if (!PL_dowarn)
1091 0           PerlIO_printf(DBIc_LOGPIO(imp_xxh)," Note: perl is running without the recommended perl -w option\n");
1092 8           PerlIO_flush(DBIc_LOGPIO(imp_xxh));
1093             }
1094 80           sv_setiv(DBIc_DEBUG(imp_xxh), level);
1095             }
1096 166           return RETVAL;
1097             }
1098              
1099              
1100             static SV *
1101 108399           dbih_inner(pTHX_ SV *orv, const char *what)
1102             { /* convert outer to inner handle else croak(what) if what is not NULL */
1103             /* if what is NULL then return NULL for invalid handles */
1104             MAGIC *mg;
1105             SV *ohv; /* outer HV after derefing the RV */
1106             SV *hrv; /* dbi inner handle RV-to-HV */
1107              
1108             /* enable a raw HV (not ref-to-HV) to be passed in, eg DBIc_MY_H */
1109 108399 100         ohv = SvROK(orv) ? SvRV(orv) : orv;
1110              
1111 108399 50         if (!ohv || SvTYPE(ohv) != SVt_PVHV) {
    100          
1112 330 50         if (!what)
1113 330           return NULL;
1114             if (1) {
1115             dMY_CXT;
1116 0 0         if (DBIS_TRACE_LEVEL)
1117 0           sv_dump(orv);
1118             }
1119 0 0         if (!SvOK(orv))
    0          
    0          
1120 0           croak("%s given an undefined handle %s",
1121             what, "(perhaps returned from a previous call which failed)");
1122 0           croak("%s handle %s is not a DBI handle", what, neatsvpv(orv,0));
1123             }
1124 108069 100         if (!SvMAGICAL(ohv)) {
1125 2 50         if (!what)
1126 2           return NULL;
1127 0           sv_dump(orv);
1128 0           croak("%s handle %s is not a DBI handle (has no magic)",
1129             what, neatsvpv(orv,0));
1130             }
1131              
1132 108067 100         if ( (mg=mg_find(ohv,'P')) == NULL) { /* hash tie magic */
1133             /* not tied, maybe it's already an inner handle... */
1134 45990 50         if (mg_find(ohv, DBI_MAGIC) == NULL) {
1135 0 0         if (!what)
1136 0           return NULL;
1137 0           sv_dump(orv);
1138 0           croak("%s handle %s is not a valid DBI handle",
1139             what, neatsvpv(orv,0));
1140             }
1141 45990           hrv = orv; /* was already a DBI handle inner hash */
1142             }
1143             else {
1144 62077           hrv = mg->mg_obj; /* inner hash of tie */
1145             }
1146              
1147 108067           return hrv;
1148             }
1149              
1150              
1151              
1152             /* -------------------------------------------------------------------- */
1153             /* Functions to manage a DBI handle (magic and attributes etc). */
1154              
1155             static imp_xxh_t *
1156 0           dbih_getcom(SV *hrv) /* used by drivers via DBIS func ptr */
1157             {
1158             MAGIC *mg;
1159             SV *sv;
1160              
1161             /* short-cut common case */
1162 0 0         if ( SvROK(hrv)
1163 0 0         && (sv = SvRV(hrv))
1164 0 0         && SvRMAGICAL(sv)
1165 0 0         && (mg = SvMAGIC(sv))
1166 0 0         && mg->mg_type == DBI_MAGIC
1167 0 0         && mg->mg_ptr
1168             )
1169 0           return (imp_xxh_t *) mg->mg_ptr;
1170              
1171             {
1172             dTHX;
1173 0           imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ hrv, 0);
1174 0 0         if (!imp_xxh) /* eg after take_imp_data */
1175 0           croak("Invalid DBI handle %s, has no dbi_imp_data", neatsvpv(hrv,0));
1176 0           return imp_xxh;
1177             }
1178             }
1179              
1180             static imp_xxh_t *
1181 1015393           dbih_getcom2(pTHX_ SV *hrv, MAGIC **mgp) /* Get com struct for handle. Must be fast. */
1182             {
1183             MAGIC *mg;
1184             SV *sv;
1185              
1186             /* important and quick sanity check (esp non-'safe' Oraperl) */
1187 1015393 100         if (SvROK(hrv)) /* must at least be a ref */
1188 995890           sv = SvRV(hrv);
1189             else {
1190             dMY_CXT;
1191 19503 100         if (hrv == DBI_LAST_HANDLE) /* special for var::FETCH */
1192 19497           sv = DBI_LAST_HANDLE;
1193 6 50         else if (sv_derived_from(hrv, "DBI::common")) {
1194             /* probably a class name, if ref($h)->foo() */
1195 6           return 0;
1196             }
1197             else {
1198 0           sv_dump(hrv);
1199 0           croak("Invalid DBI handle %s", neatsvpv(hrv,0));
1200             sv = &PL_sv_undef; /* avoid "might be used uninitialized" warning */
1201             }
1202             }
1203              
1204             /* Short cut for common case. We assume that a magic var always */
1205             /* has magic and that DBI_MAGIC, if present, will be the first. */
1206 1015387 50         if (SvRMAGICAL(sv) && (mg=SvMAGIC(sv))->mg_type == DBI_MAGIC) {
    100          
1207             /* nothing to do here */
1208             }
1209             else {
1210             /* Validate handle (convert outer to inner if required) */
1211 32450           hrv = dbih_inner(aTHX_ hrv, "dbih_getcom");
1212 32450           mg = mg_find(SvRV(hrv), DBI_MAGIC);
1213             }
1214 1015387 100         if (mgp) /* let caller pickup magic struct for this handle */
1215 1           *mgp = mg;
1216              
1217 1015387 50         if (!mg) /* may happen during global destruction */
1218 0           return (imp_xxh_t *) 0;
1219              
1220 1015387           return (imp_xxh_t *) mg->mg_ptr;
1221             }
1222              
1223              
1224             static SV *
1225 264747           dbih_setup_attrib(pTHX_ SV *h, imp_xxh_t *imp_xxh, char *attrib, SV *parent, int read_only, int optional)
1226             {
1227 264747           STRLEN len = strlen(attrib);
1228             SV **asvp;
1229              
1230 264747 100         asvp = hv_fetch((HV*)SvRV(h), attrib, len, !optional);
1231             /* we assume that we won't have any existing 'undef' attributes here */
1232             /* (or, alternately, we take undef to mean 'copy from parent') */
1233 264747 100         if (!(asvp && SvOK(*asvp))) { /* attribute doesn't already exists (the common case) */
    100          
    50          
    50          
1234             SV **psvp;
1235 253197 50         if ((!parent || !SvROK(parent)) && !optional) {
    50          
    0          
1236 0           croak("dbih_setup_attrib(%s): %s not set and no parent supplied",
1237             neatsvpv(h,0), attrib);
1238             }
1239 253197           psvp = hv_fetch((HV*)SvRV(parent), attrib, len, 0);
1240 253197 100         if (psvp) {
1241 136950 100         if (!asvp)
1242 685           asvp = hv_fetch((HV*)SvRV(h), attrib, len, 1);
1243 136950           sv_setsv(*asvp, *psvp); /* copy attribute from parent to handle */
1244             }
1245             else {
1246 116247 50         if (!optional)
1247 0           croak("dbih_setup_attrib(%s): %s not set and not in parent",
1248             neatsvpv(h,0), attrib);
1249             }
1250             }
1251 264747 100         if (DBIc_TRACE_LEVEL(imp_xxh) >= 5) {
1252 27           PerlIO *logfp = DBIc_LOGPIO(imp_xxh);
1253 27           PerlIO_printf(logfp," dbih_setup_attrib(%s, %s, %s)",
1254             neatsvpv(h,0), attrib, neatsvpv(parent,0));
1255 27 100         if (!asvp)
1256 12           PerlIO_printf(logfp," undef (not defined)\n");
1257             else
1258 15 50         if (SvOK(*asvp))
    0          
    0          
1259 15           PerlIO_printf(logfp," %s (already defined)\n", neatsvpv(*asvp,0));
1260 0           else PerlIO_printf(logfp," %s (copied from parent)\n", neatsvpv(*asvp,0));
1261             }
1262 264747 100         if (read_only && asvp)
    50          
1263 88689           SvREADONLY_on(*asvp);
1264 264747 100         return asvp ? *asvp : &PL_sv_undef;
1265             }
1266              
1267              
1268             static SV *
1269 0           dbih_make_fdsv(SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name)
1270             {
1271             dTHX;
1272 0           D_imp_sth(sth);
1273 0           const STRLEN cn_len = strlen(col_name);
1274             imp_fdh_t *imp_fdh;
1275             SV *fdsv;
1276 0 0         if (imp_size < sizeof(imp_fdh_t) || cn_len<10 || strNE("::fd",&col_name[cn_len-4]))
    0          
    0          
1277 0           croak("panic: dbih_makefdsv %s '%s' imp_size %ld invalid",
1278             imp_class, col_name, (long)imp_size);
1279 0 0         if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
1280 0           PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_make_fdsv(%s, %s, %ld, '%s')\n",
1281             neatsvpv(sth,0), imp_class, (long)imp_size, col_name);
1282 0           fdsv = dbih_make_com(sth, (imp_xxh_t*)imp_sth, imp_class, imp_size, cn_len+2, 0);
1283 0           imp_fdh = (imp_fdh_t*)(void*)SvPVX(fdsv);
1284 0           imp_fdh->com.col_name = ((char*)imp_fdh) + imp_size;
1285 0           strcpy(imp_fdh->com.col_name, col_name);
1286 0           return fdsv;
1287             }
1288              
1289              
1290             static SV *
1291 29563           dbih_make_com(SV *p_h, imp_xxh_t *p_imp_xxh, const char *imp_class, STRLEN imp_size, STRLEN extra, SV* imp_templ)
1292             {
1293             dTHX;
1294             static const char *errmsg = "Can't make DBI com handle for %s: %s";
1295             HV *imp_stash;
1296             SV *dbih_imp_sv;
1297             imp_xxh_t *imp;
1298             int trace_level;
1299             PERL_UNUSED_VAR(extra);
1300              
1301 29563 50         if ( (imp_stash = gv_stashpv(imp_class, FALSE)) == NULL)
1302 0           croak(errmsg, imp_class, "unknown package");
1303              
1304 29563 50         if (imp_size == 0) {
1305             /* get size of structure to allocate for common and imp specific data */
1306 29563           const char *imp_size_name = mkvname(aTHX_ imp_stash, "imp_data_size", 0);
1307 29563 50         imp_size = SvIV(get_sv(imp_size_name, 0x05));
1308 29563 50         if (imp_size == 0) {
1309 29563           imp_size = sizeof(imp_sth_t);
1310 29563 50         if (sizeof(imp_dbh_t) > imp_size)
1311 0           imp_size = sizeof(imp_dbh_t);
1312 29563 50         if (sizeof(imp_drh_t) > imp_size)
1313 0           imp_size = sizeof(imp_drh_t);
1314 29563           imp_size += 4;
1315             }
1316             }
1317              
1318 29563 100         if (p_imp_xxh) {
1319 29233           trace_level = DBIc_TRACE_LEVEL(p_imp_xxh);
1320             }
1321             else {
1322             dMY_CXT;
1323 330           trace_level = DBIS_TRACE_LEVEL;
1324             }
1325 29563 100         if (trace_level >= 5) {
1326             dMY_CXT;
1327 3           PerlIO_printf(DBILOGFP," dbih_make_com(%s, %p, %s, %ld, %p) thr#%p\n",
1328             neatsvpv(p_h,0), (void*)p_imp_xxh, imp_class, (long)imp_size, (void*)imp_templ, (void*)PERL_GET_THX);
1329             }
1330              
1331 29563 50         if (imp_templ && SvOK(imp_templ)) {
    0          
    0          
    0          
1332             U32 imp_templ_flags;
1333             /* validate the supplied dbi_imp_data looks reasonable, */
1334 0 0         if (SvCUR(imp_templ) != imp_size)
1335 0           croak("Can't use dbi_imp_data of wrong size (%ld not %ld)",
1336 0           (long)SvCUR(imp_templ), (long)imp_size);
1337              
1338             /* copy the whole template */
1339 0           dbih_imp_sv = newSVsv(imp_templ);
1340 0           imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv);
1341              
1342             /* sanity checks on the supplied imp_data */
1343 0 0         if (DBIc_TYPE(imp) != ((p_imp_xxh) ? DBIc_TYPE(p_imp_xxh)+1 :1) )
    0          
1344 0           croak("Can't use dbi_imp_data from different type of handle");
1345 0 0         if (!DBIc_has(imp, DBIcf_IMPSET))
1346 0           croak("Can't use dbi_imp_data that not from a setup handle");
1347              
1348             /* copy flags, zero out our imp_xxh struct, restore some flags */
1349 0           imp_templ_flags = DBIc_FLAGS(imp);
1350 0 0         switch ( (p_imp_xxh) ? DBIc_TYPE(p_imp_xxh)+1 : DBIt_DR ) {
1351 0           case DBIt_DR: memzero((char*)imp, sizeof(imp_drh_t)); break;
1352 0           case DBIt_DB: memzero((char*)imp, sizeof(imp_dbh_t)); break;
1353 0           case DBIt_ST: memzero((char*)imp, sizeof(imp_sth_t)); break;
1354 0           default: croak("dbih_make_com dbi_imp_data bad h type");
1355             }
1356             /* Only pass on DBIcf_IMPSET to indicate to driver that the imp */
1357             /* structure has been copied and it doesn't need to reconnect. */
1358             /* Similarly DBIcf_ACTIVE is also passed along but isn't key. */
1359 0           DBIc_FLAGS(imp) = imp_templ_flags & (DBIcf_IMPSET|DBIcf_ACTIVE);
1360             }
1361             else {
1362 29563           dbih_imp_sv = newSV(imp_size); /* is grown to at least imp_size+1 */
1363 29563           imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv);
1364 29563           memzero((char*)imp, imp_size);
1365             /* set up SV with SvCUR set ready for take_imp_data */
1366 29563           SvCUR_set(dbih_imp_sv, imp_size);
1367 29563           *SvEND(dbih_imp_sv) = '\0';
1368             }
1369              
1370 29563 100         if (p_imp_xxh) {
1371 29233           DBIc_DBISTATE(imp) = DBIc_DBISTATE(p_imp_xxh);
1372             }
1373             else {
1374             dMY_CXT;
1375 330           DBIc_DBISTATE(imp) = DBIS;
1376             }
1377 29563           DBIc_IMP_STASH(imp) = imp_stash;
1378              
1379 29563 100         if (!p_h) { /* only a driver (drh) has no parent */
1380 330           DBIc_PARENT_H(imp) = &PL_sv_undef;
1381 330           DBIc_PARENT_COM(imp) = NULL;
1382 330           DBIc_TYPE(imp) = DBIt_DR;
1383 330           DBIc_on(imp,DBIcf_WARN /* set only here, children inherit */
1384             |DBIcf_ACTIVE /* drivers are 'Active' by default */
1385             |DBIcf_AutoCommit /* advisory, driver must manage this */
1386             );
1387 330           DBIc_set(imp, DBIcf_PrintWarn, 1);
1388             }
1389             else {
1390 29233           DBIc_PARENT_H(imp) = (SV*)SvREFCNT_inc(p_h); /* ensure it lives */
1391 29233           DBIc_PARENT_COM(imp) = p_imp_xxh; /* shortcut for speed */
1392 29233           DBIc_TYPE(imp) = DBIc_TYPE(p_imp_xxh) + 1;
1393             /* inherit some flags from parent and carry forward some from template */
1394 58466           DBIc_FLAGS(imp) = (DBIc_FLAGS(p_imp_xxh) & ~DBIcf_INHERITMASK)
1395 29233           | (DBIc_FLAGS(imp) & (DBIcf_IMPSET|DBIcf_ACTIVE));
1396 29233           ++DBIc_KIDS(p_imp_xxh);
1397             }
1398             #ifdef DBI_USE_THREADS
1399             DBIc_THR_USER(imp) = PERL_GET_THX ;
1400             #endif
1401              
1402 29563 100         if (DBIc_TYPE(imp) == DBIt_ST) {
1403 25933           imp_sth_t *imp_sth = (imp_sth_t*)imp;
1404 25933           DBIc_ROW_COUNT(imp_sth) = -1;
1405             }
1406              
1407 29563           DBIc_COMSET_on(imp); /* common data now set up */
1408              
1409             /* The implementor should DBIc_IMPSET_on(imp) when setting up */
1410             /* any private data which will need clearing/freeing later. */
1411              
1412 29563           return dbih_imp_sv;
1413             }
1414              
1415              
1416             static void
1417 29563           dbih_setup_handle(pTHX_ SV *orv, char *imp_class, SV *parent, SV *imp_datasv)
1418             {
1419             SV *h;
1420 29563           char *errmsg = "Can't setup DBI handle of %s to %s: %s";
1421             SV *dbih_imp_sv;
1422             SV *dbih_imp_rv;
1423 29563           SV *dbi_imp_data = Nullsv;
1424             SV **svp;
1425             char imp_mem_name[300];
1426             HV *imp_mem_stash;
1427             imp_xxh_t *imp;
1428             imp_xxh_t *parent_imp;
1429             int trace_level;
1430              
1431 29563           h = dbih_inner(aTHX_ orv, "dbih_setup_handle");
1432 29563           parent = dbih_inner(aTHX_ parent, NULL); /* check parent valid (& inner) */
1433 29563 100         if (parent) {
1434 29233           parent_imp = DBIh_COM(parent);
1435 29233           trace_level = DBIc_TRACE_LEVEL(parent_imp);
1436             }
1437             else {
1438             dMY_CXT;
1439 330           parent_imp = NULL;
1440 330           trace_level = DBIS_TRACE_LEVEL;
1441             }
1442              
1443 29563 100         if (trace_level >= 5) {
1444             dMY_CXT;
1445 3           PerlIO_printf(DBILOGFP," dbih_setup_handle(%s=>%s, %s, %lx, %s)\n",
1446             neatsvpv(orv,0), neatsvpv(h,0), imp_class, (long)parent, neatsvpv(imp_datasv,0));
1447             }
1448              
1449 29563 50         if (mg_find(SvRV(h), DBI_MAGIC) != NULL)
1450 0           croak(errmsg, neatsvpv(orv,0), imp_class, "already a DBI (or ~magic) handle");
1451              
1452 29563           strcpy(imp_mem_name, imp_class);
1453 29563           strcat(imp_mem_name, "_mem");
1454 29563 50         if ( (imp_mem_stash = gv_stashpv(imp_mem_name, FALSE)) == NULL)
1455 0           croak(errmsg, neatsvpv(orv,0), imp_mem_name, "unknown _mem package");
1456              
1457 29563 50         if ((svp = hv_fetch((HV*)SvRV(h), "dbi_imp_data", 12, 0))) {
1458 0           dbi_imp_data = *svp;
1459 0 0         if (SvGMAGICAL(dbi_imp_data)) /* call FETCH via magic */
1460 0           mg_get(dbi_imp_data);
1461             }
1462              
1463             DBI_LOCK;
1464              
1465 29563           dbih_imp_sv = dbih_make_com(parent, parent_imp, imp_class, 0, 0, dbi_imp_data);
1466 29563           imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv);
1467              
1468 29563           dbih_imp_rv = newRV_inc(dbih_imp_sv); /* just needed for sv_bless */
1469 29563           sv_bless(dbih_imp_rv, imp_mem_stash);
1470 29563           sv_free(dbih_imp_rv);
1471              
1472 29563           DBIc_MY_H(imp) = (HV*)SvRV(orv); /* take _copy_ of pointer, not new ref */
1473 29563 100         DBIc_IMP_DATA(imp) = (imp_datasv) ? newSVsv(imp_datasv) : &PL_sv_undef;
1474 29563           _imp2com(imp, std.pid) = (U32)PerlProc_getpid();
1475              
1476 29563 50         if (DBIc_TYPE(imp) <= DBIt_ST) {
1477             SV **tmp_svp;
1478             /* Copy some attributes from parent if not defined locally and */
1479             /* also take address of attributes for speed of direct access. */
1480             /* parent is null for drh, in which case h must hold the values */
1481             #define COPY_PARENT(name,ro,opt) SvREFCNT_inc(dbih_setup_attrib(aTHX_ h,imp,(name),parent,ro,opt))
1482             #define DBIc_ATTR(imp, f) _imp2com(imp, attr.f)
1483             /* XXX we should validate that these are the right type (refs etc) */
1484 29563           DBIc_ATTR(imp, Err) = COPY_PARENT("Err",1,0); /* scalar ref */
1485 29563           DBIc_ATTR(imp, State) = COPY_PARENT("State",1,0); /* scalar ref */
1486 29563           DBIc_ATTR(imp, Errstr) = COPY_PARENT("Errstr",1,0); /* scalar ref */
1487 29563           DBIc_ATTR(imp, TraceLevel)=COPY_PARENT("TraceLevel",0,0);/* scalar (int)*/
1488 29563           DBIc_ATTR(imp, FetchHashKeyName) = COPY_PARENT("FetchHashKeyName",0,0); /* scalar ref */
1489              
1490 29563 100         if (parent) {
1491 29233           dbih_setup_attrib(aTHX_ h,imp,"HandleSetErr",parent,0,1);
1492 29233           dbih_setup_attrib(aTHX_ h,imp,"HandleError",parent,0,1);
1493 29233           dbih_setup_attrib(aTHX_ h,imp,"ReadOnly",parent,0,1);
1494 29233           dbih_setup_attrib(aTHX_ h,imp,"Profile",parent,0,1);
1495              
1496             /* setup Callbacks from parents' ChildCallbacks */
1497 29233 100         if (DBIc_has(parent_imp, DBIcf_Callbacks)
1498 1415 50         && (tmp_svp = hv_fetch((HV*)SvRV(parent), "Callbacks", 9, 0))
1499 1415 50         && SvROK(*tmp_svp) && SvTYPE(SvRV(*tmp_svp)) == SVt_PVHV
    50          
1500 1415 100         && (tmp_svp = hv_fetch((HV*)SvRV(*tmp_svp), "ChildCallbacks", 14, 0))
1501 2 50         && SvROK(*tmp_svp) && SvTYPE(SvRV(*tmp_svp)) == SVt_PVHV
    50          
1502             ) {
1503             /* XXX mirrors behaviour of dbih_set_attr_k() of Callbacks */
1504 2           (void)hv_store((HV*)SvRV(h), "Callbacks", 9, newRV_inc(SvRV(*tmp_svp)), 0);
1505 2           DBIc_set(imp, DBIcf_Callbacks, 1);
1506             }
1507              
1508 29233           DBIc_LongReadLen(imp) = DBIc_LongReadLen(parent_imp);
1509             #ifdef sv_rvweaken
1510             if (1) {
1511             AV *av;
1512             /* add weakref to new (outer) handle into parents ChildHandles array */
1513 29233           tmp_svp = hv_fetch((HV*)SvRV(parent), "ChildHandles", 12, 1);
1514 29233 100         if (!SvROK(*tmp_svp)) {
1515 3054           SV *ChildHandles_rvav = newRV_noinc((SV*)newAV());
1516 3054           sv_setsv(*tmp_svp, ChildHandles_rvav);
1517 3054           sv_free(ChildHandles_rvav);
1518             }
1519 29233           av = (AV*)SvRV(*tmp_svp);
1520 29233           av_push(av, (SV*)sv_rvweaken(newRV_inc((SV*)SvRV(orv))));
1521 29233 100         if (av_len(av) % 120 == 0) {
1522             /* time to do some housekeeping to remove dead handles */
1523 3257           I32 i = av_len(av); /* 0 = 1 element */
1524 56850 100         while (i-- >= 0) {
1525 27617           SV *sv = av_shift(av);
1526 27617 100         if (SvOK(sv))
    50          
    50          
1527 3427           av_push(av, sv);
1528             else
1529 24190           sv_free(sv); /* keep it leak-free by Doru Petrescu pdoru.dbi@from.ro */
1530             }
1531             }
1532             }
1533             #endif
1534             }
1535             else {
1536 330           DBIc_LongReadLen(imp) = DBIc_LongReadLen_init;
1537             }
1538              
1539 29563           switch (DBIc_TYPE(imp)) {
1540             case DBIt_DB:
1541             /* cache _inner_ handle, but also see quick_FETCH */
1542 3300           (void)hv_store((HV*)SvRV(h), "Driver", 6, newRV_inc(SvRV(parent)), 0);
1543 3300           (void)hv_fetch((HV*)SvRV(h), "Statement", 9, 1); /* store writable undef */
1544 3300           break;
1545             case DBIt_ST:
1546 25933           DBIc_NUM_FIELDS((imp_sth_t*)imp) = -1;
1547             /* cache _inner_ handle, but also see quick_FETCH */
1548 25933           (void)hv_store((HV*)SvRV(h), "Database", 8, newRV_inc(SvRV(parent)), 0);
1549             /* copy (alias) Statement from the sth up into the dbh */
1550 25933           tmp_svp = hv_fetch((HV*)SvRV(h), "Statement", 9, 1);
1551 25933           (void)hv_store((HV*)SvRV(parent), "Statement", 9, SvREFCNT_inc(*tmp_svp), 0);
1552 29563           break;
1553             }
1554             }
1555             else
1556 0           die("panic: invalid DBIc_TYPE");
1557              
1558             /* Use DBI magic on inner handle to carry handle attributes */
1559             /* Note that we store the imp_sv in mg_obj, but as a shortcut, */
1560             /* also store a direct pointer to imp, aka PVX(dbih_imp_sv), */
1561             /* in mg_ptr (with mg_len set to null, so it wont be freed) */
1562 29563           sv_magic(SvRV(h), dbih_imp_sv, DBI_MAGIC, (char*)imp, 0);
1563 29563           SvREFCNT_dec(dbih_imp_sv); /* since sv_magic() incremented it */
1564 29563           SvRMAGICAL_on(SvRV(h)); /* so DBI magic gets sv_clear'd ok */
1565              
1566             {
1567             dMY_CXT; /* XXX would be nice to get rid of this */
1568 29563           DBI_SET_LAST_HANDLE(h);
1569             }
1570              
1571             if (1) {
1572             /* This is a hack to work-around the fast but poor way old versions of
1573             * DBD::Oracle (and possibly other drivers) check for a valid handle
1574             * using (SvMAGIC(SvRV(h)))->mg_type == 'P'). That doesn't work now
1575             * because the weakref magic is inserted ahead of the tie magic.
1576             * So here we swap the tie and weakref magic so the tie comes first.
1577             */
1578 29563           MAGIC *tie_mg = mg_find(SvRV(orv),'P');
1579 29563           MAGIC *first = SvMAGIC(SvRV(orv));
1580 29563 50         if (tie_mg && first->mg_moremagic == tie_mg && !tie_mg->mg_moremagic) {
    50          
    0          
1581 0           MAGIC *next = tie_mg->mg_moremagic;
1582 0           SvMAGIC(SvRV(orv)) = tie_mg;
1583 0           tie_mg->mg_moremagic = first;
1584 0           first->mg_moremagic = next;
1585             }
1586             }
1587              
1588             DBI_UNLOCK;
1589 29563           }
1590              
1591              
1592             static void
1593 4           dbih_dumphandle(pTHX_ SV *h, const char *msg, int level)
1594             {
1595 4           D_imp_xxh(h);
1596 4 50         if (level >= 9) {
1597 0           sv_dump(h);
1598             }
1599 4           dbih_dumpcom(aTHX_ imp_xxh, msg, level);
1600 4           }
1601              
1602             static int
1603 7           dbih_dumpcom(pTHX_ imp_xxh_t *imp_xxh, const char *msg, int level)
1604             {
1605             dMY_CXT;
1606 7           SV *flags = sv_2mortal(newSVpv("",0));
1607             SV *inner;
1608             static const char pad[] = " ";
1609 7 50         if (!msg)
1610 0           msg = "dbih_dumpcom";
1611 14 50         PerlIO_printf(DBILOGFP," %s (%sh 0x%lx, com 0x%lx, imp %s):\n",
1612 7           msg, dbih_htype_name(DBIc_TYPE(imp_xxh)),
1613 7           (long)DBIc_MY_H(imp_xxh), (long)imp_xxh,
1614 7 50         (PL_dirty) ? "global destruction" : HvNAME(DBIc_IMP_STASH(imp_xxh)));
    50          
    50          
    0          
    50          
    50          
1615 7 50         if (DBIc_COMSET(imp_xxh)) sv_catpv(flags,"COMSET ");
1616 7 50         if (DBIc_IMPSET(imp_xxh)) sv_catpv(flags,"IMPSET ");
1617 7 100         if (DBIc_ACTIVE(imp_xxh)) sv_catpv(flags,"Active ");
1618 7 50         if (DBIc_WARN(imp_xxh)) sv_catpv(flags,"Warn ");
1619 7 50         if (DBIc_COMPAT(imp_xxh)) sv_catpv(flags,"CompatMode ");
1620 7 50         if (DBIc_is(imp_xxh, DBIcf_ChopBlanks)) sv_catpv(flags,"ChopBlanks ");
1621 7 50         if (DBIc_is(imp_xxh, DBIcf_HandleSetErr)) sv_catpv(flags,"HandleSetErr ");
1622 7 50         if (DBIc_is(imp_xxh, DBIcf_HandleError)) sv_catpv(flags,"HandleError ");
1623 7 100         if (DBIc_is(imp_xxh, DBIcf_RaiseError)) sv_catpv(flags,"RaiseError ");
1624 7 100         if (DBIc_is(imp_xxh, DBIcf_PrintError)) sv_catpv(flags,"PrintError ");
1625 7 100         if (DBIc_is(imp_xxh, DBIcf_PrintWarn)) sv_catpv(flags,"PrintWarn ");
1626 7 50         if (DBIc_is(imp_xxh, DBIcf_ShowErrorStatement)) sv_catpv(flags,"ShowErrorStatement ");
1627 7 50         if (DBIc_is(imp_xxh, DBIcf_AutoCommit)) sv_catpv(flags,"AutoCommit ");
1628 7 50         if (DBIc_is(imp_xxh, DBIcf_BegunWork)) sv_catpv(flags,"BegunWork ");
1629 7 50         if (DBIc_is(imp_xxh, DBIcf_LongTruncOk)) sv_catpv(flags,"LongTruncOk ");
1630 7 50         if (DBIc_is(imp_xxh, DBIcf_MultiThread)) sv_catpv(flags,"MultiThread ");
1631 7 50         if (DBIc_is(imp_xxh, DBIcf_TaintIn)) sv_catpv(flags,"TaintIn ");
1632 7 50         if (DBIc_is(imp_xxh, DBIcf_TaintOut)) sv_catpv(flags,"TaintOut ");
1633 7 50         if (DBIc_is(imp_xxh, DBIcf_Profile)) sv_catpv(flags,"Profile ");
1634 7 50         if (DBIc_is(imp_xxh, DBIcf_Callbacks)) sv_catpv(flags,"Callbacks ");
1635 7 50         PerlIO_printf(DBILOGFP,"%s FLAGS 0x%lx: %s\n", pad, (long)DBIc_FLAGS(imp_xxh), SvPV_nolen(flags));
1636 7 50         if (SvOK(DBIc_ERR(imp_xxh)))
    50          
    50          
1637 0           PerlIO_printf(DBILOGFP,"%s ERR %s\n", pad, neatsvpv((SV*)DBIc_ERR(imp_xxh),0));
1638 7 50         if (SvOK(DBIc_ERR(imp_xxh)))
    50          
    50          
1639 0           PerlIO_printf(DBILOGFP,"%s ERRSTR %s\n", pad, neatsvpv((SV*)DBIc_ERRSTR(imp_xxh),0));
1640 7           PerlIO_printf(DBILOGFP,"%s PARENT %s\n", pad, neatsvpv((SV*)DBIc_PARENT_H(imp_xxh),0));
1641 7           PerlIO_printf(DBILOGFP,"%s KIDS %ld (%ld Active)\n", pad,
1642 14           (long)DBIc_KIDS(imp_xxh), (long)DBIc_ACTIVE_KIDS(imp_xxh));
1643 7 50         if (DBIc_IMP_DATA(imp_xxh) && SvOK(DBIc_IMP_DATA(imp_xxh)))
    50          
    50          
    50          
1644 0           PerlIO_printf(DBILOGFP,"%s IMP_DATA %s\n", pad, neatsvpv(DBIc_IMP_DATA(imp_xxh),0));
1645 7 50         if (DBIc_LongReadLen(imp_xxh) != DBIc_LongReadLen_init)
1646 0           PerlIO_printf(DBILOGFP,"%s LongReadLen %ld\n", pad, (long)DBIc_LongReadLen(imp_xxh));
1647              
1648 7 50         if (DBIc_TYPE(imp_xxh) == DBIt_ST) {
1649 0           const imp_sth_t *imp_sth = (imp_sth_t*)imp_xxh;
1650 0           PerlIO_printf(DBILOGFP,"%s NUM_OF_FIELDS %d\n", pad, DBIc_NUM_FIELDS(imp_sth));
1651 0           PerlIO_printf(DBILOGFP,"%s NUM_OF_PARAMS %d\n", pad, DBIc_NUM_PARAMS(imp_sth));
1652             }
1653 7           inner = dbih_inner(aTHX_ (SV*)DBIc_MY_H(imp_xxh), msg);
1654 7 50         if (!inner || !SvROK(inner))
    100          
1655 3           return 1;
1656 4 50         if (DBIc_TYPE(imp_xxh) <= DBIt_DB) {
1657 4           SV **svp = hv_fetch((HV*)SvRV(inner), "CachedKids", 10, 0);
1658 4 50         if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) {
    0          
    0          
1659 0           HV *hv = (HV*)SvRV(*svp);
1660 0 0         PerlIO_printf(DBILOGFP,"%s CachedKids %d\n", pad, (int)HvKEYS(hv));
1661             }
1662             }
1663 4 50         if (level > 0) {
1664             SV* value;
1665             char *key;
1666             I32 keylen;
1667 4           PerlIO_printf(DBILOGFP,"%s cached attributes:\n", pad);
1668 82 100         while ( (value = hv_iternextsv((HV*)SvRV(inner), &key, &keylen)) ) {
1669 78           PerlIO_printf(DBILOGFP,"%s '%s' => %s\n", pad, key, neatsvpv(value,0));
1670             }
1671             }
1672 0 0         else if (DBIc_TYPE(imp_xxh) == DBIt_DB) {
1673 0           SV **svp = hv_fetch((HV*)SvRV(inner), "Name", 4, 0);
1674 0 0         if (svp && SvOK(*svp))
    0          
    0          
    0          
1675 0           PerlIO_printf(DBILOGFP,"%s Name %s\n", pad, neatsvpv(*svp,0));
1676             }
1677 0 0         else if (DBIc_TYPE(imp_xxh) == DBIt_ST) {
1678 0           SV **svp = hv_fetch((HV*)SvRV(inner), "Statement", 9, 0);
1679 0 0         if (svp && SvOK(*svp))
    0          
    0          
    0          
1680 0           PerlIO_printf(DBILOGFP,"%s Statement %s\n", pad, neatsvpv(*svp,0));
1681             }
1682 4           return 1;
1683             }
1684              
1685              
1686             static void
1687 29560           dbih_clearcom(imp_xxh_t *imp_xxh)
1688             {
1689             dTHX;
1690             dTHR;
1691 29560           int dump = FALSE;
1692 29560           int debug = DBIc_TRACE_LEVEL(imp_xxh);
1693 29560           int auto_dump = (debug >= 6);
1694 29560           imp_xxh_t * const parent_xxh = DBIc_PARENT_COM(imp_xxh);
1695             /* Note that we're very much on our own here. DBIc_MY_H(imp_xxh) almost */
1696             /* certainly points to memory which has been freed. Don't use it! */
1697              
1698             /* --- pre-clearing sanity checks --- */
1699              
1700             #ifdef DBI_USE_THREADS
1701             if (DBIc_THR_USER(imp_xxh) != my_perl) { /* don't clear handle that belongs to another thread */
1702             if (debug >= 3) {
1703             PerlIO_printf(DBIc_LOGPIO(imp_xxh)," skipped dbih_clearcom: DBI handle (type=%d, %s) is owned by thread %p not current thread %p\n",
1704             DBIc_TYPE(imp_xxh), HvNAME(DBIc_IMP_STASH(imp_xxh)), (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ;
1705             PerlIO_flush(DBIc_LOGPIO(imp_xxh));
1706             }
1707             return;
1708             }
1709             #endif
1710              
1711 29560 50         if (!DBIc_COMSET(imp_xxh)) { /* should never happen */
1712 0           dbih_dumpcom(aTHX_ imp_xxh, "dbih_clearcom: DBI handle already cleared", 0);
1713 0           return;
1714             }
1715              
1716 29560 100         if (auto_dump)
1717 3           dbih_dumpcom(aTHX_ imp_xxh,"DESTROY (dbih_clearcom)", 0);
1718              
1719 29560 100         if (!PL_dirty) {
1720              
1721 28700 100         if (DBIc_ACTIVE(imp_xxh)) { /* bad news, potentially */
1722             /* warn for sth, warn for dbh only if it has active sth or isn't AutoCommit */
1723 315 50         if (DBIc_TYPE(imp_xxh) >= DBIt_ST
1724 315 50         || (DBIc_ACTIVE_KIDS(imp_xxh) || !DBIc_has(imp_xxh, DBIcf_AutoCommit))
    50          
1725             ) {
1726 0           warn("DBI %s handle 0x%lx cleared whilst still active",
1727 0           dbih_htype_name(DBIc_TYPE(imp_xxh)), (unsigned long)DBIc_MY_H(imp_xxh));
1728 0           dump = TRUE;
1729             }
1730             }
1731              
1732             /* check that the implementor has done its own housekeeping */
1733 28700 50         if (DBIc_IMPSET(imp_xxh)) {
1734 0           warn("DBI %s handle 0x%lx has uncleared implementors data",
1735 0           dbih_htype_name(DBIc_TYPE(imp_xxh)), (unsigned long)DBIc_MY_H(imp_xxh));
1736 0           dump = TRUE;
1737             }
1738              
1739 28700 50         if (DBIc_KIDS(imp_xxh)) {
1740 0           warn("DBI %s handle 0x%lx has %d uncleared child handles",
1741 0           dbih_htype_name(DBIc_TYPE(imp_xxh)),
1742 0           (unsigned long)DBIc_MY_H(imp_xxh), (int)DBIc_KIDS(imp_xxh));
1743 0           dump = TRUE;
1744             }
1745             }
1746              
1747 29560 50         if (dump && !auto_dump) /* else was already dumped above */
    0          
1748 0           dbih_dumpcom(aTHX_ imp_xxh, "dbih_clearcom", 0);
1749              
1750             /* --- pre-clearing adjustments --- */
1751              
1752 29560 100         if (!PL_dirty) {
1753 28700 50         if (parent_xxh) {
1754 28700 100         if (DBIc_ACTIVE(imp_xxh)) /* see also DBIc_ACTIVE_off */
1755 315           --DBIc_ACTIVE_KIDS(parent_xxh);
1756 28700           --DBIc_KIDS(parent_xxh);
1757             }
1758             }
1759              
1760             /* --- clear fields (may invoke object destructors) --- */
1761              
1762 29560 100         if (DBIc_TYPE(imp_xxh) == DBIt_ST) {
1763 25933           imp_sth_t *imp_sth = (imp_sth_t*)imp_xxh;
1764 25933           sv_free((SV*)DBIc_FIELDS_AV(imp_sth));
1765             }
1766              
1767 29560           sv_free(DBIc_IMP_DATA(imp_xxh)); /* do this first */
1768 29560 50         if (DBIc_TYPE(imp_xxh) <= DBIt_ST) { /* DBIt_FD doesn't have attr */
1769 29560           sv_free(_imp2com(imp_xxh, attr.TraceLevel));
1770 29560           sv_free(_imp2com(imp_xxh, attr.State));
1771 29560           sv_free(_imp2com(imp_xxh, attr.Err));
1772 29560           sv_free(_imp2com(imp_xxh, attr.Errstr));
1773 29560           sv_free(_imp2com(imp_xxh, attr.FetchHashKeyName));
1774             }
1775              
1776              
1777 29560           sv_free((SV*)DBIc_PARENT_H(imp_xxh)); /* do this last */
1778              
1779 29560           DBIc_COMSET_off(imp_xxh);
1780              
1781 29560 100         if (debug >= 4)
1782 3           PerlIO_printf(DBIc_LOGPIO(imp_xxh)," dbih_clearcom 0x%lx (com 0x%lx, type %d) done.\n\n",
1783 6           (long)DBIc_MY_H(imp_xxh), (long)imp_xxh, DBIc_TYPE(imp_xxh));
1784             }
1785              
1786              
1787             /* --- Functions for handling field buffer arrays --- */
1788              
1789             static AV *
1790 4020           dbih_setup_fbav(imp_sth_t *imp_sth)
1791             {
1792             /* Usually called to setup the row buffer for new sth.
1793             * Also called if the value of NUM_OF_FIELDS is altered,
1794             * in which case it adjusts the row buffer to match NUM_OF_FIELDS.
1795             */
1796             dTHX;
1797 4020           I32 i = DBIc_NUM_FIELDS(imp_sth);
1798 4020           AV *av = DBIc_FIELDS_AV(imp_sth);
1799              
1800 4020 50         if (i < 0)
1801 0           i = 0;
1802              
1803 4020 100         if (av) {
1804 1845 100         if (av_len(av)+1 == i) /* is existing array the right size? */
1805 1841           return av;
1806             /* we need to adjust the size of the array */
1807 4 50         if (DBIc_TRACE_LEVEL(imp_sth) >= 2)
1808 0           PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav realloc from %ld to %ld fields\n", (long)(av_len(av)+1), (long)i);
1809 4           SvREADONLY_off(av);
1810 4 100         if (i < av_len(av)+1) /* trim to size if too big */
1811 4           av_fill(av, i-1);
1812             }
1813             else {
1814 2175 50         if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
1815 0           PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav alloc for %ld fields\n", (long)i);
1816 2175           av = newAV();
1817 2175           DBIc_FIELDS_AV(imp_sth) = av;
1818              
1819             /* row_count will need to be manually reset by the driver if the */
1820             /* sth is re-executed (since this code won't get rerun) */
1821 2175           DBIc_ROW_COUNT(imp_sth) = 0;
1822             }
1823              
1824             /* load array with writeable SV's. Do this backwards so */
1825             /* the array only gets extended once. */
1826 8530 100         while(i--) /* field 1 stored at index 0 */
1827 6351           av_store(av, i, newSV(0));
1828 2179 50         if (DBIc_TRACE_LEVEL(imp_sth) >= 6)
1829 0           PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav now %ld fields\n", (long)(av_len(av)+1));
1830 2179           SvREADONLY_on(av); /* protect against shift @$row etc */
1831 2179           return av;
1832             }
1833              
1834              
1835             static AV *
1836 103862           dbih_get_fbav(imp_sth_t *imp_sth)
1837             {
1838             AV *av;
1839              
1840 103862 100         if ( (av = DBIc_FIELDS_AV(imp_sth)) == Nullav) {
1841 2117           av = dbih_setup_fbav(imp_sth);
1842             }
1843             else {
1844             dTHX;
1845 101745           int i = av_len(av) + 1;
1846 101745 50         if (i != DBIc_NUM_FIELDS(imp_sth)) {
1847             /*SV *sth = dbih_inner(aTHX_ (SV*)DBIc_MY_H(imp_sth), "_get_fbav");*/
1848             /* warn via PrintWarn */
1849 0           set_err_char(SvRV(DBIc_MY_H(imp_sth)), (imp_xxh_t*)imp_sth,
1850             "0", 0, "Number of row fields inconsistent with NUM_OF_FIELDS (driver bug)", "", "_get_fbav");
1851             /*
1852             DBIc_NUM_FIELDS(imp_sth) = i;
1853             hv_delete((HV*)SvRV(sth), "NUM_OF_FIELDS", 13, G_DISCARD);
1854             */
1855             }
1856             /* don't let SvUTF8 flag persist from one row to the next */
1857             /* (only affects drivers that use sv_setpv, but most XS do) */
1858             /* XXX turn into option later (force on/force off/ignore) */
1859 404195 100         while(i--) /* field 1 stored at index 0 */
1860 302450           SvUTF8_off(AvARRAY(av)[i]);
1861             }
1862              
1863 103862 100         if (DBIc_is(imp_sth, DBIcf_TaintOut)) {
1864             dTHX;
1865             dTHR;
1866 1           TAINT; /* affects sv_setsv()'s called within same perl statement */
1867             }
1868              
1869             /* XXX fancy stuff to happen here later (re scrolling etc) */
1870 103862           ++DBIc_ROW_COUNT(imp_sth);
1871 103862           return av;
1872             }
1873              
1874              
1875             static int
1876 162           dbih_sth_bind_col(SV *sth, SV *col, SV *ref, SV *attribs)
1877             {
1878             dTHX;
1879 162           D_imp_sth(sth);
1880             AV *av;
1881 162 50         int idx = SvIV(col);
1882 162           int fields = DBIc_NUM_FIELDS(imp_sth);
1883              
1884 162 50         if (fields <= 0) {
1885             PERL_UNUSED_VAR(attribs);
1886 0 0         croak("Statement has no result columns to bind%s",
1887 0           DBIc_ACTIVE(imp_sth)
1888             ? "" : " (perhaps you need to successfully call execute first, or again)");
1889             }
1890              
1891 162 100         if ( (av = DBIc_FIELDS_AV(imp_sth)) == Nullav)
1892 58           av = dbih_setup_fbav(imp_sth);
1893              
1894 162 50         if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
1895 0           PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_sth_bind_col %s => %s %s\n",
1896             neatsvpv(col,0), neatsvpv(ref,0), neatsvpv(attribs,0));
1897              
1898 162 100         if (idx < 1 || idx > fields)
    100          
1899 6           croak("bind_col: column %d is not a valid column (1..%d)",
1900             idx, fields);
1901              
1902 156 100         if (!SvOK(ref) && SvREADONLY(ref)) { /* binding to literal undef */
    50          
    50          
    50          
1903             /* presumably the call is just setting the TYPE or other atribs */
1904             /* but this default method ignores attribs, so we just return */
1905 2           return 1;
1906             }
1907              
1908             /* Write this as > SVt_PVMG because in 5.8.x the next type */
1909             /* is SVt_PVBM, whereas in 5.9.x it's SVt_PVGV. */
1910 154 50         if (!SvROK(ref) || SvTYPE(SvRV(ref)) > SVt_PVMG) /* XXX LV */
    50          
1911 0           croak("Can't %s->bind_col(%s, %s,...), need a reference to a scalar",
1912             neatsvpv(sth,0), neatsvpv(col,0), neatsvpv(ref,0));
1913              
1914             /* use supplied scalar as storage for this column */
1915 154           SvREADONLY_off(av);
1916 154           av_store(av, idx-1, SvREFCNT_inc(SvRV(ref)) );
1917 154           SvREADONLY_on(av);
1918 154           return 1;
1919             }
1920              
1921              
1922             static int
1923 0           quote_type(int sql_type, int p, int s, int *t, void *v)
1924             {
1925             /* Returns true if type should be bound as a number else */
1926             /* false implying that binding as a string should be okay. */
1927             /* The true value is either SQL_INTEGER or SQL_DOUBLE which */
1928             /* can be used as a hint if desired. */
1929             (void)p;
1930             (void)s;
1931             (void)t;
1932             (void)v;
1933             /* looks like it's never been used, and doesn't make much sense anyway */
1934 0           warn("Use of DBI internal bind_as_num/quote_type function is deprecated");
1935 0           switch(sql_type) {
1936             case SQL_INTEGER:
1937             case SQL_SMALLINT:
1938             case SQL_TINYINT:
1939             case SQL_BIGINT:
1940 0           return 0;
1941             case SQL_FLOAT:
1942             case SQL_REAL:
1943             case SQL_DOUBLE:
1944 0           return 0;
1945             case SQL_NUMERIC:
1946             case SQL_DECIMAL:
1947 0           return 0; /* bind as string to attempt to retain precision */
1948             }
1949 0           return 1;
1950             }
1951              
1952              
1953             /* Convert a simple string representation of a value into a more specific
1954             * perl type based on an sql_type value.
1955             * The semantics of SQL standard TYPE values are interpreted _very_ loosely
1956             * on the basis of "be liberal in what you accept and let's throw in some
1957             * extra semantics while we're here" :)
1958             * Returns:
1959             * -2: sql_type isn't handled, value unchanged
1960             * -1: sv is undef, value unchanged
1961             * 0: sv couldn't be cast cleanly and DBIstcf_STRICT was used
1962             * 1: sv couldn't be cast cleanly and DBIstcf_STRICT was not used
1963             * 2: sv was cast ok
1964             */
1965              
1966             int
1967 40           sql_type_cast_svpv(pTHX_ SV *sv, int sql_type, U32 flags, void *v)
1968             {
1969 40           int cast_ok = 0;
1970             int grok_flags;
1971             UV uv;
1972              
1973             /* do nothing for undef (NULL) or non-string values */
1974 40 50         if (!sv || !SvOK(sv))
    100          
    50          
    50          
1975 2           return -1;
1976              
1977 38           switch(sql_type) {
1978              
1979             default:
1980 2           return -2; /* not a recognised SQL TYPE, value unchanged */
1981              
1982             case SQL_INTEGER:
1983             /* sv_2iv is liberal, may return SvIV, SvUV, or SvNV */
1984 26           sv_2iv(sv);
1985             /* SvNOK will be set if value is out of range for IV/UV.
1986             * SvIOK should be set but won't if sv is not numeric (in which
1987             * case perl would have warn'd already if -w or warnings are in effect)
1988             */
1989 26 100         cast_ok = (SvIOK(sv) && !SvNOK(sv));
    50          
1990 26           break;
1991              
1992             case SQL_DOUBLE:
1993 6           sv_2nv(sv);
1994             /* SvNOK should be set but won't if sv is not numeric (in which
1995             * case perl would have warn'd already if -w or warnings are in effect)
1996             */
1997 6           cast_ok = SvNOK(sv);
1998 6           break;
1999              
2000             /* caller would like IV else UV else NV */
2001             /* else no error and sv is untouched */
2002             case SQL_NUMERIC:
2003             /* based on the code in perl's toke.c */
2004 4           uv = 0;
2005 4           grok_flags = grok_number(SvPVX(sv), SvCUR(sv), &uv);
2006 4           cast_ok = 1;
2007 4 50         if (grok_flags == IS_NUMBER_IN_UV) { /* +ve int */
2008 0 0         if (uv <= IV_MAX) /* prefer IV over UV */
2009 0           sv_2iv(sv);
2010 0           else sv_2uv(sv);
2011             }
2012 4 50         else if (grok_flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)
2013 0 0         && uv <= IV_MAX
2014             ) {
2015 0           sv_2iv(sv);
2016             }
2017 4 50         else if (grok_flags) { /* is numeric */
2018 0           sv_2nv(sv);
2019             }
2020             else
2021 4           cast_ok = 0;
2022 4           break;
2023              
2024             #if 0 /* XXX future possibilities */
2025             case SQL_BIGINT: /* use Math::BigInt if too large for IV/UV */
2026             #endif
2027             }
2028              
2029 36 100         if (cast_ok) {
2030              
2031 16 100         if (flags & DBIstcf_DISCARD_STRING
2032 2 50         && SvNIOK(sv) /* we set a numeric value */
2033 2 50         && SvPVX(sv) /* we have a buffer to discard */
2034             ) {
2035 2 50         SvOOK_off(sv);
2036 2           sv_force_normal(sv);
2037 2 50         if (SvLEN(sv))
2038 2           Safefree(SvPVX(sv));
2039 2           SvPOK_off(sv);
2040 2           SvPV_set(sv, NULL);
2041 2           SvLEN_set(sv, 0);
2042 2           SvCUR_set(sv, 0);
2043             }
2044             }
2045              
2046 36 100         if (cast_ok)
2047 16           return 2;
2048 20 100         else if (flags & DBIstcf_STRICT)
2049 10           return 0;
2050 40           else return 1;
2051             }
2052              
2053              
2054              
2055             /* --- Generic Handle Attributes (for all handle types) --- */
2056              
2057             static int
2058 79050           dbih_set_attr_k(SV *h, SV *keysv, int dbikey, SV *valuesv)
2059             {
2060             dTHX;
2061             dTHR;
2062 79050           D_imp_xxh(h);
2063             STRLEN keylen;
2064 79050 50         const char *key = SvPV(keysv, keylen);
2065 79050           const int htype = DBIc_TYPE(imp_xxh);
2066 79050 50         int on = (SvTRUE(valuesv));
    50          
    0          
    100          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    0          
    100          
    50          
2067 79050           int internal = 1; /* DBIh_IN_PERL_DBD(imp_xxh); -- for DBD's in perl */
2068 79050           int cacheit = 0;
2069 79050           int weakenit = 0; /* eg for CachedKids ref */
2070             (void)dbikey;
2071              
2072 79050 100         if (DBIc_TRACE_LEVEL(imp_xxh) >= 3)
2073 51           PerlIO_printf(DBIc_LOGPIO(imp_xxh)," STORE %s %s => %s\n",
2074             neatsvpv(h,0), neatsvpv(keysv,0), neatsvpv(valuesv,0));
2075              
2076 79050 50         if (internal && strEQ(key, "Active")) {
    100          
2077 28158 100         if (on) {
2078 9210           D_imp_sth(h);
2079 9210 100         DBIc_ACTIVE_on(imp_xxh);
    50          
    50          
    50          
2080             /* for pure-perl drivers on second and subsequent */
2081             /* execute()'s, else row count keeps rising. */
2082 9210 100         if (htype==DBIt_ST && DBIc_FIELDS_AV(imp_sth))
    100          
2083 9210           DBIc_ROW_COUNT(imp_sth) = 0;
2084             }
2085             else {
2086 4869 100         DBIc_ACTIVE_off(imp_xxh);
    50          
    100          
    50          
    50          
2087             }
2088             }
2089 64971 100         else if (strEQ(key, "FetchHashKeyName")) {
2090 18 50         if (htype >= DBIt_ST)
2091 0           croak("Can't set FetchHashKeyName for a statement handle, set in parent before prepare()");
2092 18           cacheit = 1; /* just save it */
2093             }
2094 64953 100         else if (strEQ(key, "CompatMode")) {
2095 12 100         (on) ? DBIc_COMPAT_on(imp_xxh) : DBIc_COMPAT_off(imp_xxh);
2096             }
2097 64941 100         else if (strEQ(key, "Warn")) {
2098 6 100         (on) ? DBIc_WARN_on(imp_xxh) : DBIc_WARN_off(imp_xxh);
2099             }
2100 64935 100         else if (strEQ(key, "AutoInactiveDestroy")) {
2101 12 100         (on) ? DBIc_AIADESTROY_on(imp_xxh) : DBIc_AIADESTROY_off(imp_xxh);
2102             }
2103 64923 100         else if (strEQ(key, "InactiveDestroy")) {
2104 8 100         (on) ? DBIc_IADESTROY_on(imp_xxh) : DBIc_IADESTROY_off(imp_xxh);
2105             }
2106 64915 100         else if (strEQ(key, "RootClass")) {
2107 14           cacheit = 1; /* just save it */
2108             }
2109 64901 50         else if (strEQ(key, "RowCacheSize")) {
2110 0           cacheit = 0; /* ignore it */
2111             }
2112 64901 100         else if (strEQ(key, "Executed")) {
2113 6036 50         DBIc_set(imp_xxh, DBIcf_Executed, on);
2114             }
2115 58865 100         else if (strEQ(key, "ChopBlanks")) {
2116 10 100         DBIc_set(imp_xxh, DBIcf_ChopBlanks, on);
2117             }
2118 58855 100         else if (strEQ(key, "ErrCount")) {
2119 2 50         DBIc_ErrCount(imp_xxh) = SvUV(valuesv);
2120             }
2121 58853 50         else if (strEQ(key, "LongReadLen")) {
2122 0 0         if (SvNV(valuesv) < 0 || SvNV(valuesv) > MAX_LongReadLen)
    0          
    0          
    0          
    0          
    0          
2123 0           croak("Can't set LongReadLen < 0 or > %ld",MAX_LongReadLen);
2124 0 0         DBIc_LongReadLen(imp_xxh) = SvIV(valuesv);
2125 0           cacheit = 1; /* save it for clone */
2126             }
2127 58853 100         else if (strEQ(key, "LongTruncOk")) {
2128 4 50         DBIc_set(imp_xxh,DBIcf_LongTruncOk, on);
2129             }
2130 58849 100         else if (strEQ(key, "RaiseError")) {
2131 6307 100         DBIc_set(imp_xxh,DBIcf_RaiseError, on);
2132             }
2133 52542 100         else if (strEQ(key, "PrintError")) {
2134 6409 100         DBIc_set(imp_xxh,DBIcf_PrintError, on);
2135             }
2136 46133 100         else if (strEQ(key, "PrintWarn")) {
2137 6038 100         DBIc_set(imp_xxh,DBIcf_PrintWarn, on);
2138             }
2139 40095 100         else if (strEQ(key, "HandleError")) {
2140 4 100         if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) {
    50          
    50          
2141 0           croak("Can't set %s to '%s'", "HandleError", neatsvpv(valuesv,0));
2142             }
2143 4 100         DBIc_set(imp_xxh,DBIcf_HandleError, on);
2144 4           cacheit = 1; /* child copy setup by dbih_setup_handle() */
2145             }
2146 40091 100         else if (strEQ(key, "HandleSetErr")) {
2147 2 50         if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) {
    50          
    50          
2148 0           croak("Can't set %s to '%s'","HandleSetErr",neatsvpv(valuesv,0));
2149             }
2150 2 50         DBIc_set(imp_xxh,DBIcf_HandleSetErr, on);
2151 2           cacheit = 1; /* child copy setup by dbih_setup_handle() */
2152             }
2153 40089 50         else if (strEQ(key, "ChildHandles")) {
2154 0 0         if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVAV)) ) {
    0          
    0          
2155 0           croak("Can't set %s to '%s'", "ChildHandles", neatsvpv(valuesv,0));
2156             }
2157 0           cacheit = 1; /* just save it in the hash */
2158             }
2159 40089 100         else if (strEQ(key, "Profile")) {
2160             static const char profile_class[] = "DBI::Profile";
2161 41 100         if (on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) ) {
    100          
    50          
2162             /* not a hash ref so use DBI::Profile to work out what to do */
2163             dTHR;
2164 20           dSP;
2165             I32 returns;
2166 20           TAINT_NOT; /* the require is presumed innocent till proven guilty */
2167 20           perl_require_pv("DBI/Profile.pm");
2168 20 50         if (SvTRUE(ERRSV)) {
    50          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
2169 0 0         warn("Can't load %s: %s", profile_class, SvPV_nolen(ERRSV));
    0          
    0          
    0          
2170 0           valuesv = &PL_sv_undef;
2171             }
2172             else {
2173 20 50         PUSHMARK(SP);
2174 20 50         XPUSHs(sv_2mortal(newSVpv(profile_class,0)));
2175 20 50         XPUSHs(valuesv);
2176 20           PUTBACK;
2177 20           returns = call_method("_auto_new", G_SCALAR);
2178 20 50         if (returns != 1)
2179 0           croak("%s _auto_new", profile_class);
2180 20           SPAGAIN;
2181 20           valuesv = POPs;
2182 20           PUTBACK;
2183             }
2184 20 50         on = SvTRUE(valuesv); /* in case it returns undef */
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
2185             }
2186 41 100         if (on && !sv_isobject(valuesv)) {
    100          
2187             /* not blessed already - so default to DBI::Profile */
2188             HV *stash;
2189 16           perl_require_pv(profile_class);
2190 16           stash = gv_stashpv(profile_class, GV_ADDWARN);
2191 16           sv_bless(valuesv, stash);
2192             }
2193 41 100         DBIc_set(imp_xxh,DBIcf_Profile, on);
2194 41           cacheit = 1; /* child copy setup by dbih_setup_handle() */
2195             }
2196 40048 100         else if (strEQ(key, "ShowErrorStatement")) {
2197 1083 100         DBIc_set(imp_xxh,DBIcf_ShowErrorStatement, on);
2198             }
2199 38965 50         else if (strEQ(key, "MultiThread") && internal) {
    0          
2200             /* here to allow pure-perl drivers to set MultiThread */
2201 0 0         DBIc_set(imp_xxh,DBIcf_MultiThread, on);
2202 0 0         if (on && DBIc_WARN(imp_xxh)) {
    0          
2203 0           warn("MultiThread support not yet implemented in DBI");
2204             }
2205             }
2206 38965 100         else if (strEQ(key, "Taint")) {
2207             /* 'Taint' is a shortcut for both in and out mode */
2208 22 100         DBIc_set(imp_xxh,DBIcf_TaintIn|DBIcf_TaintOut, on);
2209             }
2210 38943 100         else if (strEQ(key, "TaintIn")) {
2211 8 100         DBIc_set(imp_xxh,DBIcf_TaintIn, on);
2212             }
2213 38935 100         else if (strEQ(key, "TaintOut")) {
2214 7 100         DBIc_set(imp_xxh,DBIcf_TaintOut, on);
2215             }
2216 38928 100         else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "CachedKids")
    100          
    100          
2217             /* only allow hash refs */
2218 9 50         && SvROK(valuesv) && SvTYPE(SvRV(valuesv))==SVt_PVHV
    50          
2219             ) {
2220 9           cacheit = 1;
2221 9           weakenit = 1;
2222             }
2223 38919 100         else if (keylen==9 && strEQ(key, "Callbacks")) {
    100          
2224 27 100         if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) )
    50          
    50          
2225 0           croak("Can't set Callbacks to '%s'",neatsvpv(valuesv,0));
2226             /* see also dbih_setup_handle for ChildCallbacks handling */
2227 27 100         DBIc_set(imp_xxh, DBIcf_Callbacks, on);
2228 27           cacheit = 1;
2229             }
2230 38892 100         else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "AutoCommit")) {
    100          
    100          
2231             /* driver should have intercepted this and either handled it */
2232             /* or set valuesv to either the 'magic' on or off value. */
2233 5519 50         if (SvIV(valuesv) != -900 && SvIV(valuesv) != -901)
    100          
    50          
    50          
2234 0           croak("DBD driver has not implemented the AutoCommit attribute");
2235 5519 50         DBIc_set(imp_xxh,DBIcf_AutoCommit, (SvIV(valuesv)==-901));
    100          
2236             }
2237 33373 100         else if (htype==DBIt_DB && keylen==9 && strEQ(key, "BegunWork")) {
    100          
    100          
2238 2 50         DBIc_set(imp_xxh,DBIcf_BegunWork, on);
2239             }
2240 33371 100         else if (keylen==10 && strEQ(key, "TraceLevel")) {
    100          
2241 98           set_trace(h, valuesv, Nullsv);
2242             }
2243 33273 100         else if (keylen==9 && strEQ(key, "TraceFile")) { /* XXX undocumented and readonly */
    50          
2244 0           set_trace_file(valuesv);
2245             }
2246 40955 100         else if (htype==DBIt_ST && strEQ(key, "NUM_OF_FIELDS")) {
    100          
2247 7682           D_imp_sth(h);
2248 7682 100         int new_num_fields = (SvOK(valuesv)) ? SvIV(valuesv) : -1;
    50          
    50          
    50          
2249 7682           DBIc_NUM_FIELDS(imp_sth) = new_num_fields;
2250 7682 100         if (DBIc_FIELDS_AV(imp_sth)) { /* modify existing fbav */
2251 1845           dbih_setup_fbav(imp_sth);
2252             }
2253 7682           cacheit = 1;
2254             }
2255 30747 100         else if (htype==DBIt_ST && strEQ(key, "NUM_OF_PARAMS")) {
    100          
2256 5156           D_imp_sth(h);
2257 5156 50         DBIc_NUM_PARAMS(imp_sth) = SvIV(valuesv);
2258 5156           cacheit = 1;
2259             }
2260             /* these are here due to clone() needing to set attribs through a public api */
2261 20435 100         else if (htype<=DBIt_DB && (strEQ(key, "Name")
    100          
2262 20422 100         || strEQ(key,"ImplementorClass")
2263 20418 100         || strEQ(key,"ReadOnly")
2264 20139 100         || strEQ(key,"Statement")
2265 20135 100         || strEQ(key,"Username")
2266             /* these are here for backwards histerical raisons */
2267 13828 50         || strEQ(key,"USER") || strEQ(key,"CURRENT_USER")
    50          
2268             ) ) {
2269 6598           cacheit = 1;
2270             }
2271             /* deal with: NAME_(uc|lc), NAME_hash, NAME_(uc|lc)_hash */
2272 13837 100         else if ((keylen==7 || keylen==9 || keylen==12)
    100          
    100          
2273 20 100         && strnEQ(key, "NAME_", 5)
2274 5 100         && ( (keylen==9 && strEQ(key, "NAME_hash"))
    50          
2275 4 100         || ((key[5]=='u' || key[5]=='l') && key[6] == 'c'
    50          
    50          
2276 4 100         && (!key[7] || strnEQ(&key[7], "_hash", 5)))
    50          
2277             )
2278             ) {
2279 5           cacheit = 1;
2280             }
2281             else { /* XXX should really be an event ? */
2282 13832 100         if (isUPPER(*key)) {
2283 2           char *msg = "Can't set %s->{%s}: unrecognised attribute name or invalid value%s";
2284 2           char *hint = "";
2285 2 50         if (strEQ(key, "NUM_FIELDS"))
2286 0           hint = ", perhaps you meant NUM_OF_FIELDS";
2287 2           warn(msg, neatsvpv(h,0), key, hint);
2288 2           return FALSE; /* don't store it */
2289             }
2290             /* Allow private_* attributes to be stored in the cache. */
2291             /* This is designed to make life easier for people subclassing */
2292             /* the DBI classes and may be of use to simple perl DBD's. */
2293 13830 100         if (strnNE(key,"private_",8) && strnNE(key,"dbd_",4) && strnNE(key,"dbi_",4)) {
    100          
    100          
2294 44 50         if (DBIc_TRACE_LEVEL(imp_xxh)) { /* change to DBIc_WARN(imp_xxh) once we can validate prefix against registry */
2295 0           PerlIO_printf(DBIc_LOGPIO(imp_xxh),"$h->{%s}=%s ignored for invalid driver-specific attribute\n",
2296             neatsvpv(keysv,0), neatsvpv(valuesv,0));
2297             }
2298 44           return FALSE;
2299             }
2300 13786           cacheit = 1;
2301             }
2302 79004 100         if (cacheit) {
2303 33342           SV *sv_for_cache = newSVsv(valuesv);
2304 33342           (void)hv_store((HV*)SvRV(h), key, keylen, sv_for_cache, 0);
2305 33342 100         if (weakenit) {
2306             #ifdef sv_rvweaken
2307 9           sv_rvweaken(sv_for_cache);
2308             #endif
2309             }
2310             }
2311 79050           return TRUE;
2312             }
2313              
2314              
2315             static SV *
2316 44691           dbih_get_attr_k(SV *h, SV *keysv, int dbikey)
2317             {
2318             dTHX;
2319             dTHR;
2320 44691           D_imp_xxh(h);
2321             STRLEN keylen;
2322 44691 50         char *key = SvPV(keysv, keylen);
2323 44691           int htype = DBIc_TYPE(imp_xxh);
2324 44691           SV *valuesv = Nullsv;
2325 44691           int cacheit = FALSE;
2326             char *p;
2327             int i;
2328             SV *sv;
2329             SV **svp;
2330             (void)dbikey;
2331              
2332             /* DBI quick_FETCH will service some requests (e.g., cached values) */
2333              
2334 44691 100         if (htype == DBIt_ST) {
2335 6044           switch (*key) {
2336              
2337             case 'D':
2338 18 50         if (keylen==8 && strEQ(key, "Database")) {
    50          
2339 18           D_imp_from_child(imp_dbh, imp_dbh_t, imp_xxh);
2340 18           valuesv = newRV_inc((SV*)DBIc_MY_H(imp_dbh));
2341 18           cacheit = FALSE; /* else creates ref loop */
2342             }
2343 18           break;
2344              
2345             case 'N':
2346 2304 100         if (keylen==8 && strEQ(key, "NULLABLE")) {
    50          
2347 52           valuesv = &PL_sv_undef;
2348 52           break;
2349             }
2350              
2351 2252 100         if (keylen==4 && strEQ(key, "NAME")) {
    50          
2352 56           valuesv = &PL_sv_undef;
2353 56           break;
2354             }
2355              
2356             /* deal with: NAME_(uc|lc), NAME_hash, NAME_(uc|lc)_hash */
2357 2196 100         if ((keylen==7 || keylen==9 || keylen==12)
    100          
    100          
2358 2088 50         && strnEQ(key, "NAME_", 5)
2359 2088 100         && ( (keylen==9 && strEQ(key, "NAME_hash"))
    50          
2360 2040 100         || ((key[5]=='u' || key[5]=='l') && key[6] == 'c'
    50          
    50          
2361 2040 100         && (!key[7] || strnEQ(&key[7], "_hash", 5)))
    50          
2362             )
2363 2088           ) {
2364 2088           D_imp_sth(h);
2365 2088           valuesv = &PL_sv_undef;
2366              
2367             /* fetch from tied outer handle to trigger FETCH magic */
2368 2088           svp = hv_fetch((HV*)DBIc_MY_H(imp_sth), "NAME",4, FALSE);
2369 2088 50         sv = (svp) ? *svp : &PL_sv_undef;
2370 2088 50         if (SvGMAGICAL(sv)) /* call FETCH via magic */
2371 2088           mg_get(sv);
2372              
2373 2088 100         if (SvROK(sv)) {
2374 2078           AV *name_av = (AV*)SvRV(sv);
2375             char *name;
2376 2078           int upcase = (key[5] == 'u');
2377 2078           AV *av = Nullav;
2378 2078           HV *hv = Nullhv;
2379 2078           int num_fields_mismatch = 0;
2380              
2381 2078 100         if (strEQ(&key[strlen(key)-5], "_hash"))
2382 60           hv = newHV();
2383 2018           else av = newAV();
2384 2078           i = DBIc_NUM_FIELDS(imp_sth);
2385              
2386             /* catch invalid NUM_FIELDS */
2387 2078 50         if (i != AvFILL(name_av)+1) {
    50          
2388             /* flag as mismatch, except for "-1 and empty" case */
2389 0 0         if ( ! (i == -1 && 0 == AvFILL(name_av)+1) )
    0          
    0          
    0          
2390 0           num_fields_mismatch = 1;
2391 0 0         i = AvFILL(name_av)+1; /* limit for safe iteration over array */
2392             }
2393              
2394 2078 50         if (DBIc_TRACE_LEVEL(imp_sth) >= 10 || (num_fields_mismatch && DBIc_WARN(imp_xxh))) {
    50          
    0          
2395 0 0         PerlIO_printf(DBIc_LOGPIO(imp_sth)," FETCH $h->{%s} from $h->{NAME} with $h->{NUM_OF_FIELDS} = %d"
    0          
2396             " and %ld entries in $h->{NAME}%s\n",
2397 0           neatsvpv(keysv,0), DBIc_NUM_FIELDS(imp_sth), AvFILL(name_av)+1,
2398             (num_fields_mismatch) ? " (possible bug in driver)" : "");
2399             }
2400              
2401 8162 100         while (--i >= 0) {
2402 6084           sv = newSVsv(AvARRAY(name_av)[i]);
2403 6084 50         name = SvPV_nolen(sv);
2404 6084 100         if (key[5] != 'h') { /* "NAME_hash" */
2405 29981 50         for (p = name; p && *p; ++p) {
    100          
2406             #ifdef toUPPER_LC
2407 23997 100         *p = (upcase) ? toUPPER_LC(*p) : toLOWER_LC(*p);
    50          
    0          
    0          
    0          
    50          
2408             #else
2409             *p = (upcase) ? toUPPER(*p) : toLOWER(*p);
2410             #endif
2411             }
2412             }
2413 6084 100         if (av)
2414 5946           av_store(av, i, sv);
2415             else {
2416 138           (void)hv_store(hv, name, SvCUR(sv), newSViv(i), 0);
2417 138           sv_free(sv);
2418             }
2419             }
2420 2078 100         valuesv = newRV_noinc( (av ? (SV*)av : (SV*)hv) );
2421 2078           cacheit = TRUE; /* can't change */
2422             }
2423             }
2424 159 50         else if (keylen==13 && strEQ(key, "NUM_OF_FIELDS")) {
    100          
2425 51           D_imp_sth(h);
2426 51           IV num_fields = DBIc_NUM_FIELDS(imp_sth);
2427 51 50         valuesv = (num_fields < 0) ? &PL_sv_undef : newSViv(num_fields);
2428 51 50         if (num_fields > 0)
2429 0           cacheit = TRUE; /* can't change once set (XXX except for multiple result sets) */
2430             }
2431 57 50         else if (keylen==13 && strEQ(key, "NUM_OF_PARAMS")) {
    50          
2432 57           D_imp_sth(h);
2433 57           valuesv = newSViv(DBIc_NUM_PARAMS(imp_sth));
2434 57           cacheit = TRUE; /* can't change */
2435             }
2436 2196           break;
2437              
2438             case 'P':
2439 148 100         if (strEQ(key, "PRECISION"))
2440 52           valuesv = &PL_sv_undef;
2441 96 100         else if (strEQ(key, "ParamValues"))
2442 82           valuesv = &PL_sv_undef;
2443 14 50         else if (strEQ(key, "ParamTypes"))
2444 0           valuesv = &PL_sv_undef;
2445 148           break;
2446              
2447             case 'R':
2448 9 100         if (strEQ(key, "RowsInCache"))
2449 4           valuesv = &PL_sv_undef;
2450 9           break;
2451              
2452             case 'S':
2453 360 100         if (strEQ(key, "SCALE"))
2454 356           valuesv = &PL_sv_undef;
2455 360           break;
2456              
2457             case 'T':
2458 122 100         if (strEQ(key, "TYPE"))
2459 52           valuesv = &PL_sv_undef;
2460 6044           break;
2461             }
2462              
2463             }
2464             else
2465 38647 100         if (htype == DBIt_DB) {
2466             /* this is here but is, sadly, not called because
2467             * not-preloading them into the handle attrib cache caused
2468             * wierdness in t/proxy.t that I never got to the bottom
2469             * of. One day maybe. */
2470 38528 100         if (keylen==6 && strEQ(key, "Driver")) {
    100          
2471 2511           D_imp_from_child(imp_dbh, imp_dbh_t, imp_xxh);
2472 2511           valuesv = newRV_inc((SV*)DBIc_MY_H(imp_dbh));
2473 2511           cacheit = FALSE; /* else creates ref loop */
2474             }
2475             }
2476              
2477 44691 100         if (valuesv == Nullsv && htype <= DBIt_DB) {
    100          
2478 36136 100         if (keylen==10 && strEQ(key, "AutoCommit")) {
    100          
2479 12 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_AutoCommit));
2480             }
2481             }
2482              
2483 44691 100         if (valuesv == Nullsv) {
2484 39300           switch (*key) {
2485             case 'A':
2486 11202 100         if (keylen==6 && strEQ(key, "Active")) {
    50          
2487 11155 100         valuesv = boolSV(DBIc_ACTIVE(imp_xxh));
2488             }
2489 47 100         else if (keylen==10 && strEQ(key, "ActiveKids")) {
    50          
2490 29           valuesv = newSViv(DBIc_ACTIVE_KIDS(imp_xxh));
2491             }
2492 18 50         else if (strEQ(key, "AutoInactiveDestroy")) {
2493 18 100         valuesv = boolSV(DBIc_AIADESTROY(imp_xxh));
2494             }
2495 11202           break;
2496              
2497             case 'B':
2498 6 100         if (keylen==9 && strEQ(key, "BegunWork")) {
    50          
2499 4 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_BegunWork));
2500             }
2501 6           break;
2502              
2503             case 'C':
2504 9076 100         if (strEQ(key, "ChildHandles")) {
2505 42           svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE);
2506             /* if something has been stored then return it.
2507             * otherwise return a dummy empty array if weakrefs are
2508             * available, else an undef to indicate that they're not */
2509 42 50         if (svp) {
2510 0           valuesv = newSVsv(*svp);
2511             } else {
2512             #ifdef sv_rvweaken
2513 42           valuesv = newRV_noinc((SV*)newAV());
2514             #else
2515             valuesv = &PL_sv_undef;
2516             #endif
2517             }
2518             }
2519 9034 100         else if (strEQ(key, "ChopBlanks")) {
2520 2967 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_ChopBlanks));
2521             }
2522 6067 100         else if (strEQ(key, "CachedKids")) {
2523 6036           valuesv = &PL_sv_undef;
2524             }
2525 31 100         else if (strEQ(key, "CompatMode")) {
2526 18 100         valuesv = boolSV(DBIc_COMPAT(imp_xxh));
2527             }
2528 9076           break;
2529              
2530             case 'E':
2531 6062 100         if (strEQ(key, "Executed")) {
2532 6048 100         valuesv = boolSV(DBIc_is(imp_xxh, DBIcf_Executed));
2533             }
2534 14 50         else if (strEQ(key, "ErrCount")) {
2535 14           valuesv = newSVuv(DBIc_ErrCount(imp_xxh));
2536             }
2537 6062           break;
2538              
2539             case 'I':
2540 14 50         if (strEQ(key, "InactiveDestroy")) {
2541 14 100         valuesv = boolSV(DBIc_IADESTROY(imp_xxh));
2542             }
2543 14           break;
2544              
2545             case 'K':
2546 56 50         if (keylen==4 && strEQ(key, "Kids")) {
    50          
2547 56           valuesv = newSViv(DBIc_KIDS(imp_xxh));
2548             }
2549 56           break;
2550              
2551             case 'L':
2552 5563 50         if (keylen==11 && strEQ(key, "LongReadLen")) {
    100          
2553 2780           valuesv = newSVnv((NV)DBIc_LongReadLen(imp_xxh));
2554             }
2555 2783 50         else if (keylen==11 && strEQ(key, "LongTruncOk")) {
    50          
2556 2783 50         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_LongTruncOk));
2557             }
2558 5563           break;
2559              
2560             case 'M':
2561 0 0         if (keylen==10 && strEQ(key, "MultiThread")) {
    0          
2562 0 0         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_MultiThread));
2563             }
2564 0           break;
2565              
2566             case 'P':
2567 116 100         if (keylen==10 && strEQ(key, "PrintError")) {
    50          
2568 38 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_PrintError));
2569             }
2570 78 100         else if (keylen==9 && strEQ(key, "PrintWarn")) {
    50          
2571 10 50         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_PrintWarn));
2572             }
2573 116           break;
2574              
2575             case 'R':
2576 2866 100         if (keylen==10 && strEQ(key, "RaiseError")) {
    50          
2577 100 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_RaiseError));
2578             }
2579 2766 100         else if (keylen==12 && strEQ(key, "RowCacheSize")) {
    50          
2580 2           valuesv = &PL_sv_undef;
2581             }
2582 2866           break;
2583              
2584             case 'S':
2585 16 50         if (keylen==18 && strEQ(key, "ShowErrorStatement")) {
    50          
2586 16 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_ShowErrorStatement));
2587             }
2588 16           break;
2589              
2590             case 'T':
2591 159 100         if (keylen==4 && strEQ(key, "Type")) {
    50          
2592 49           char *type = dbih_htype_name(htype);
2593 49           valuesv = newSVpv(type,0);
2594 49           cacheit = TRUE; /* can't change */
2595             }
2596 61 50         else if (keylen==10 && strEQ(key, "TraceLevel")) {
    0          
2597 0 0         valuesv = newSViv( DBIc_DEBUGIV(imp_xxh) );
2598             }
2599 61 100         else if (keylen==5 && strEQ(key, "Taint")) {
    50          
2600 30 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintIn) &&
    100          
2601             DBIc_has(imp_xxh,DBIcf_TaintOut));
2602             }
2603 31 100         else if (keylen==7 && strEQ(key, "TaintIn")) {
    50          
2604 16 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintIn));
2605             }
2606 15 50         else if (keylen==8 && strEQ(key, "TaintOut")) {
    50          
2607 15 100         valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintOut));
2608             }
2609 110           break;
2610              
2611             case 'W':
2612 16 50         if (keylen==4 && strEQ(key, "Warn")) {
    50          
2613 16 50         valuesv = boolSV(DBIc_WARN(imp_xxh));
2614             }
2615 16           break;
2616             }
2617             }
2618              
2619             /* finally check the actual hash */
2620 44691 100         if (valuesv == Nullsv) {
2621 7044           valuesv = &PL_sv_undef;
2622 7044           cacheit = 0;
2623 7044           svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE);
2624 7044 100         if (svp)
2625 5           valuesv = newSVsv(*svp); /* take copy to mortalize */
2626             else /* warn unless it's known attribute name */
2627 11222 100         if ( !( (*key=='H' && strEQ(key, "HandleError"))
    50          
    100          
2628 7031 50         || (*key=='H' && strEQ(key, "HandleSetErr"))
    0          
2629 7031 50         || (*key=='S' && strEQ(key, "Statement"))
    0          
2630 7031 100         || (*key=='P' && strEQ(key, "ParamArrays"))
    50          
2631 7031 100         || (*key=='P' && strEQ(key, "ParamValues"))
    100          
2632 6975 100         || (*key=='P' && strEQ(key, "Profile"))
    50          
2633 6965 100         || (*key=='R' && strEQ(key, "ReadOnly"))
    50          
2634 4202 100         || (*key=='C' && strEQ(key, "CursorName"))
    100          
2635 4200 100         || (*key=='C' && strEQ(key, "Callbacks"))
    50          
2636 4189 100         || (*key=='U' && strEQ(key, "Username"))
    50          
2637 4183           || !isUPPER(*key) /* dbd_*, private_* etc */
2638             ))
2639 2           warn("Can't get %s->{%s}: unrecognised attribute name",neatsvpv(h,0),key);
2640             }
2641              
2642 44691 100         if (cacheit) {
2643 2184           (void)hv_store((HV*)SvRV(h), key, keylen, newSVsv(valuesv), 0);
2644             }
2645 44691 100         if (DBIc_TRACE_LEVEL(imp_xxh) >= 3)
2646 34 50         PerlIO_printf(DBIc_LOGPIO(imp_xxh)," .. FETCH %s %s = %s%s\n", neatsvpv(h,0),
2647             neatsvpv(keysv,0), neatsvpv(valuesv,0), cacheit?" (cached)":"");
2648 44691 100         if (valuesv == &PL_sv_yes || valuesv == &PL_sv_no || valuesv == &PL_sv_undef)
    100          
    100          
2649 37052           return valuesv; /* no need to mortalize yes or no */
2650 44691           return sv_2mortal(valuesv);
2651             }
2652              
2653              
2654              
2655             /* -------------------------------------------------------------------- */
2656             /* Functions implementing Error and Event Handling. */
2657              
2658              
2659             static SV *
2660 0           dbih_event(SV *hrv, const char *evtype, SV *a1, SV *a2)
2661             {
2662             dTHX;
2663             /* We arrive here via DBIh_EVENT* macros (see DBIXS.h) called from */
2664             /* DBD driver C code OR $h->event() method (in DBD::_::common) */
2665             /* XXX VERY OLD INTERFACE/CONCEPT MAY GO SOON */
2666             /* OR MAY EVOLVE INTO A WAY TO HANDLE 'SUCCESS_WITH_INFO'/'WARNINGS' from db */
2667             (void)hrv;
2668             (void)evtype;
2669             (void)a1;
2670             (void)a2;
2671 0           return &PL_sv_undef;
2672             }
2673              
2674              
2675             /* ----------------------------------------------------------------- */
2676              
2677              
2678             STATIC I32
2679 3457           dbi_dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
2680             {
2681             dTHX;
2682             I32 i;
2683             register PERL_CONTEXT *cx;
2684 4580 100         for (i = startingblock; i >= 0; i--) {
2685 4251           cx = &cxstk[i];
2686 4251 100         switch (CxTYPE(cx)) {
2687             default:
2688 1123           continue;
2689             case CXt_EVAL:
2690             case CXt_SUB:
2691             #ifdef CXt_FORMAT
2692             case CXt_FORMAT:
2693             #endif
2694             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
2695 3128           return i;
2696             }
2697             }
2698 329           return i;
2699             }
2700              
2701              
2702             static COP *
2703 310           dbi_caller_cop()
2704             {
2705             dTHX;
2706             register I32 cxix;
2707             register PERL_CONTEXT *cx;
2708 310           register PERL_CONTEXT *ccstack = cxstack;
2709 310           PERL_SI *top_si = PL_curstackinfo;
2710             char *stashname;
2711              
2712 1907           for ( cxix = dbi_dopoptosub_at(ccstack, cxstack_ix) ;; cxix = dbi_dopoptosub_at(ccstack, cxix - 1)) {
2713             /* we may be in a higher stacklevel, so dig down deeper */
2714 2029 100         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
    100          
2715 122           top_si = top_si->si_prev;
2716 122           ccstack = top_si->si_cxstack;
2717 122           cxix = dbi_dopoptosub_at(ccstack, top_si->si_cxix);
2718             }
2719 1907 100         if (cxix < 0) {
2720 182           break;
2721             }
2722 1725 50         if (PL_DBsub && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
    50          
    100          
2723 169           continue;
2724 1556           cx = &ccstack[cxix];
2725 1556 50         stashname = CopSTASHPV(cx->blk_oldcop);
    50          
    50          
    50          
    0          
    50          
    50          
2726 1556 50         if (!stashname)
2727 0           continue;
2728 2984 100         if (!(stashname[0] == 'D' && stashname[1] == 'B'
    50          
    100          
2729 1428 50         && strchr("DI", stashname[2])
2730 1312 50         && (!stashname[3] || (stashname[3] == ':' && stashname[4] == ':'))))
    50          
2731             {
2732 128           return cx->blk_oldcop;
2733             }
2734 1428           cxix = dbi_dopoptosub_at(ccstack, cxix - 1);
2735 1597           }
2736 182           return NULL;
2737             }
2738              
2739             static void
2740 492           dbi_caller_string(SV *buf, COP *cop, char *prefix, int show_line, int show_path)
2741             {
2742             dTHX;
2743             STRLEN len;
2744 492           long line = CopLINE(cop);
2745 492 50         char *file = SvPV(GvSV(CopFILEGV(cop)), len);
2746 492 100         if (!show_path) {
2747             char *sep;
2748 155 50         if ( (sep=strrchr(file,'/')) || (sep=strrchr(file,'\\')))
    0          
2749 155           file = sep+1;
2750             }
2751 492 100         if (show_line) {
2752 481 50         sv_catpvf(buf, "%s%s line %ld", (prefix) ? prefix : "", file, line);
2753             }
2754             else {
2755 11 50         sv_catpvf(buf, "%s%s", (prefix) ? prefix : "", file);
2756             }
2757 492           }
2758              
2759             static char *
2760 366           log_where(SV *buf, int append, char *prefix, char *suffix, int show_line, int show_caller, int show_path)
2761             {
2762             dTHX;
2763             dTHR;
2764 366 50         if (!buf)
2765 366           buf = sv_2mortal(newSVpv("",0));
2766 0 0         else if (!append)
2767 0           sv_setpv(buf,"");
2768 366 100         if (CopLINE(PL_curcop)) {
2769             COP *cop;
2770 364           dbi_caller_string(buf, PL_curcop, prefix, show_line, show_path);
2771 364 100         if (show_caller && (cop = dbi_caller_cop())) {
    100          
2772 128           SV *via = sv_2mortal(newSVpv("",0));
2773 128           dbi_caller_string(via, cop, prefix, show_line, show_path);
2774 128 50         sv_catpvf(buf, " via %s", SvPV_nolen(via));
2775             }
2776             }
2777 366 100         if (PL_dirty)
2778 3           sv_catpvf(buf, " during global destruction");
2779 366 50         if (suffix)
2780 366           sv_catpv(buf, suffix);
2781 366           return SvPVX(buf);
2782             }
2783              
2784              
2785             static void
2786 33136           clear_cached_kids(pTHX_ SV *h, imp_xxh_t *imp_xxh, const char *meth_name, int trace_level)
2787             {
2788 33136 100         if (DBIc_TYPE(imp_xxh) <= DBIt_DB) {
2789 7203           SV **svp = hv_fetch((HV*)SvRV(h), "CachedKids", 10, 0);
2790 7203 100         if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) {
    100          
    50          
2791 260           HV *hv = (HV*)SvRV(*svp);
2792 260 50         if (HvKEYS(hv)) {
    100          
2793 132 50         if (DBIc_TRACE_LEVEL(imp_xxh) > trace_level)
2794 0           trace_level = DBIc_TRACE_LEVEL(imp_xxh);
2795 132 50         if (trace_level >= 2) {
2796 0 0         PerlIO_printf(DBIc_LOGPIO(imp_xxh)," >> %s %s clearing %d CachedKids\n",
2797 0           meth_name, neatsvpv(h,0), (int)HvKEYS(hv));
2798 0           PerlIO_flush(DBIc_LOGPIO(imp_xxh));
2799             }
2800             /* This will probably recurse through dispatch to DESTROY the kids */
2801             /* For drh we should probably explicitly do dbh disconnects */
2802 132           hv_clear(hv);
2803             }
2804             }
2805             }
2806 33136           }
2807              
2808              
2809             static NV
2810 1057463           dbi_time() {
2811             # ifdef HAS_GETTIMEOFDAY
2812             # ifdef PERL_IMPLICIT_SYS
2813             dTHX;
2814             # endif
2815             struct timeval when;
2816 1057463           gettimeofday(&when, (struct timezone *) 0);
2817 1057463           return when.tv_sec + (when.tv_usec / 1000000.0);
2818             # else /* per-second is almost useless */
2819             # ifdef _WIN32 /* use _ftime() on Win32 (MS Visual C++ 6.0) */
2820             # if defined(__BORLANDC__)
2821             # define _timeb timeb
2822             # define _ftime ftime
2823             # endif
2824             struct _timeb when;
2825             _ftime( &when );
2826             return when.time + (when.millitm / 1000.0);
2827             # else
2828             return time(NULL);
2829             # endif
2830             # endif
2831             }
2832              
2833              
2834             static SV *
2835 44867           _profile_next_node(SV *node, const char *name)
2836             {
2837             /* step one level down profile Data tree and auto-vivify if required */
2838             dTHX;
2839 44867           SV *orig_node = node;
2840 44867 100         if (SvROK(node))
2841 44618           node = SvRV(node);
2842 44867 100         if (SvTYPE(node) != SVt_PVHV) {
2843 249           HV *hv = newHV();
2844 249 50         if (SvOK(node)) {
    50          
    50          
2845 0           char *key = "(demoted)";
2846 0           warn("Profile data element %s replaced with new hash ref (for %s) and original value stored with key '%s'",
2847             neatsvpv(orig_node,0), name, key);
2848 0           (void)hv_store(hv, key, strlen(key), SvREFCNT_inc(orig_node), 0);
2849             }
2850 249           sv_setsv(node, newRV_noinc((SV*)hv));
2851 249           node = (SV*)hv;
2852             }
2853 44867           node = *hv_fetch((HV*)node, name, strlen(name), 1);
2854 44867           return node;
2855             }
2856              
2857              
2858             static SV*
2859 60663           dbi_profile(SV *h, imp_xxh_t *imp_xxh, SV *statement_sv, SV *method, NV t1, NV t2)
2860             {
2861             #define DBIprof_MAX_PATH_ELEM 100
2862             #define DBIprof_COUNT 0
2863             #define DBIprof_TOTAL_TIME 1
2864             #define DBIprof_FIRST_TIME 2
2865             #define DBIprof_MIN_TIME 3
2866             #define DBIprof_MAX_TIME 4
2867             #define DBIprof_FIRST_CALLED 5
2868             #define DBIprof_LAST_CALLED 6
2869             #define DBIprof_max_index 6
2870             dTHX;
2871 60663           NV ti = t2 - t1;
2872 60663           int src_idx = 0;
2873 60663           HV *dbh_outer_hv = NULL;
2874 60663           HV *dbh_inner_hv = NULL;
2875             char *statement_pv;
2876             char *method_pv;
2877             SV *profile;
2878             SV *tmp;
2879             SV *dest_node;
2880             AV *av;
2881             HV *h_hv;
2882              
2883 60663           const int call_depth = DBIc_CALL_DEPTH(imp_xxh);
2884 60663 100         const int parent_call_depth = DBIc_PARENT_COM(imp_xxh) ? DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) : 0;
2885             /* Only count calls originating from the application code */
2886 60663 100         if (call_depth > 1 || parent_call_depth > 0)
    100          
2887 43912           return &PL_sv_undef;
2888              
2889 16751 100         if (!DBIc_has(imp_xxh, DBIcf_Profile))
2890 1           return &PL_sv_undef;
2891              
2892 15           method_pv = (SvTYPE(method)==SVt_PVCV) ? GvNAME(CvGV(method))
2893 33500 100         : isGV(method) ? GvNAME(method)
2894 16747 100         : SvOK(method) ? SvPV_nolen(method)
    0          
    0          
    50          
2895 12 50         : "";
2896              
2897             /* we don't profile DESTROY during global destruction */
2898 16750 100         if (PL_dirty && instr(method_pv, "DESTROY"))
    100          
2899 4           return &PL_sv_undef;
2900              
2901 16746           h_hv = (HV*)SvRV(dbih_inner(aTHX_ h, "dbi_profile"));
2902              
2903 16746           profile = *hv_fetch(h_hv, "Profile", 7, 1);
2904 16746 50         if (profile && SvMAGICAL(profile))
    50          
2905 0           mg_get(profile); /* FETCH */
2906 16746 50         if (!profile || !SvROK(profile)) {
    100          
2907 1           DBIc_set(imp_xxh, DBIcf_Profile, 0); /* disable */
2908 1 50         if (SvOK(profile) && !PL_dirty)
    50          
    50          
    0          
2909 0           warn("Profile attribute isn't a hash ref (%s,%ld)", neatsvpv(profile,0), (long)SvTYPE(profile));
2910 1           return &PL_sv_undef;
2911             }
2912              
2913             /* statement_sv: undef = use $h->{Statement}, "" (&sv_no) = use empty string */
2914              
2915 16745 100         if (!SvOK(statement_sv)) {
    50          
    50          
2916 16481           SV **psv = hv_fetch(h_hv, "Statement", 9, 0);
2917 16481 50         statement_sv = (psv && SvOK(*psv)) ? *psv : &PL_sv_no;
    100          
    50          
    50          
2918             }
2919 16745 50         statement_pv = SvPV_nolen(statement_sv);
2920              
2921 16745 50         if (DBIc_TRACE_LEVEL(imp_xxh) >= 4)
2922 0           PerlIO_printf(DBIc_LOGPIO(imp_xxh), " dbi_profile +%" NVff "s %s %s\n",
2923             ti, method_pv, neatsvpv(statement_sv,0));
2924              
2925 16745           dest_node = _profile_next_node(profile, "Data");
2926              
2927 16745           tmp = *hv_fetch((HV*)SvRV(profile), "Path", 4, 1);
2928 33425 50         if (SvROK(tmp) && SvTYPE(SvRV(tmp))==SVt_PVAV) {
    50          
2929             int len;
2930 16745           av = (AV*)SvRV(tmp);
2931 16745           len = av_len(av); /* -1=empty, 0=one element */
2932              
2933 44830 100         while ( src_idx <= len ) {
2934 28150           SV *pathsv = AvARRAY(av)[src_idx++];
2935              
2936 28249 100         if (SvROK(pathsv) && SvTYPE(SvRV(pathsv))==SVt_PVCV) {
    100          
2937             /* call sub, use returned list of values as path */
2938             /* returning a ref to undef vetos this profile data */
2939 164           dSP;
2940             I32 ax;
2941 164           SV *code_sv = SvRV(pathsv);
2942             I32 items;
2943             I32 item_idx;
2944 164 50         EXTEND(SP, 4);
2945 164 50         PUSHMARK(SP);
2946 164           PUSHs(h); /* push inner handle, then others params */
2947 164           PUSHs( sv_2mortal(newSVpv(method_pv,0)));
2948 164           PUTBACK;
2949 164           SAVE_DEFSV; /* local($_) = $statement */
2950 164           DEFSV_set(statement_sv);
2951 164           items = call_sv(code_sv, G_ARRAY);
2952 164           SPAGAIN;
2953 164           SP -= items ;
2954 164           ax = (SP - PL_stack_base) + 1 ;
2955 300 100         for (item_idx=0; item_idx < items; ++item_idx) {
2956 201           SV *item_sv = ST(item_idx);
2957 201 100         if (SvROK(item_sv)) {
2958 65 50         if (!SvOK(SvRV(item_sv)))
    50          
    50          
2959 65           items = -2; /* flag that we're rejecting this profile data */
2960             else /* other refs reserved */
2961 0           warn("Ignored ref returned by code ref in Profile Path");
2962 65           break;
2963             }
2964 136 50         dest_node = _profile_next_node(dest_node, (SvOK(item_sv) ? SvPV_nolen(item_sv) : "undef"));
    0          
    0          
    50          
2965             }
2966 164           PUTBACK;
2967 164 100         if (items == -2) /* this profile data was vetoed */
2968 65           return &PL_sv_undef;
2969             }
2970 27986 100         else if (SvROK(pathsv)) {
2971             /* only meant for refs to scalars currently */
2972 22 50         const char *p = SvPV_nolen(SvRV(pathsv));
2973 22           dest_node = _profile_next_node(dest_node, p);
2974             }
2975 27964 50         else if (SvOK(pathsv)) {
    0          
    0          
2976             STRLEN len;
2977 27964 50         const char *p = SvPV(pathsv,len);
2978 27964 100         if (p[0] == '!') { /* special cases */
2979 27794 100         if (p[1] == 'S' && strEQ(p, "!Statement")) {
    50          
2980 16537           dest_node = _profile_next_node(dest_node, statement_pv);
2981             }
2982 11257 100         else if (p[1] == 'M' && strEQ(p, "!MethodName")) {
    50          
2983 11227           dest_node = _profile_next_node(dest_node, method_pv);
2984             }
2985 30 50         else if (p[1] == 'M' && strEQ(p, "!MethodClass")) {
    0          
2986 0 0         if (SvTYPE(method) == SVt_PVCV) {
2987 0 0         p = SvPV_nolen((SV*)CvGV(method));
2988             }
2989 0 0         else if (isGV(method)) {
2990             /* just using SvPV_nolen(method) sometimes causes an error: */
2991             /* "Can't coerce GLOB to string" so we use gv_efullname() */
2992 0           SV *tmpsv = sv_2mortal(newSVpv("",0));
2993             #if (PERL_VERSION < 6)
2994             gv_efullname(tmpsv, (GV*)method);
2995             #else
2996 0           gv_efullname4(tmpsv, (GV*)method, "", TRUE);
2997             #endif
2998 0 0         p = SvPV_nolen(tmpsv);
2999 0 0         if (*p == '*') ++p; /* skip past leading '*' glob sigil */
3000             }
3001             else {
3002 0           p = method_pv;
3003             }
3004 0           dest_node = _profile_next_node(dest_node, p);
3005             }
3006 30 100         else if (p[1] == 'F' && strEQ(p, "!File")) {
    100          
3007 4           dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 0, 0, 0));
3008             }
3009 26 100         else if (p[1] == 'F' && strEQ(p, "!File2")) {
    50          
3010 4           dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 0, 1, 0));
3011             }
3012 22 100         else if (p[1] == 'C' && strEQ(p, "!Caller")) {
    100          
3013 4           dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 1, 0, 0));
3014             }
3015 18 100         else if (p[1] == 'C' && strEQ(p, "!Caller2")) {
    50          
3016 10           dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 1, 1, 0));
3017             }
3018 16 50         else if (p[1] == 'T' && (strEQ(p, "!Time") || strnEQ(p, "!Time~", 6))) {
    100          
    50          
3019             char timebuf[20];
3020 8           int factor = 1;
3021 8 100         if (p[5] == '~') {
3022 4           factor = atoi(&p[6]);
3023 4 50         if (factor == 0) /* sanity check to avoid div by zero error */
3024 0           factor = 3600;
3025             }
3026 8           sprintf(timebuf, "%ld", ((long)(dbi_time()/factor))*factor);
3027 8           dest_node = _profile_next_node(dest_node, timebuf);
3028             }
3029             else {
3030 0           warn("Unknown ! element in DBI::Profile Path: %s", p);
3031 27794           dest_node = _profile_next_node(dest_node, p);
3032             }
3033             }
3034 192 100         else if (p[0] == '{' && p[len-1] == '}') { /* treat as name of dbh attribute to use */
    50          
3035             SV **attr_svp;
3036 22 50         if (!dbh_inner_hv) { /* cache dbh handles the first time we need them */
3037 22 100         imp_dbh_t *imp_dbh = (DBIc_TYPE(imp_xxh) <= DBIt_DB) ? (imp_dbh_t*)imp_xxh : (imp_dbh_t*)DBIc_PARENT_COM(imp_xxh);
3038 22           dbh_outer_hv = DBIc_MY_H(imp_dbh);
3039 22 50         if (SvTYPE(dbh_outer_hv) != SVt_PVHV)
3040 0           return &PL_sv_undef; /* presumably global destruction - bail */
3041 22           dbh_inner_hv = (HV*)SvRV(dbih_inner(aTHX_ (SV*)dbh_outer_hv, "profile"));
3042 22 50         if (SvTYPE(dbh_inner_hv) != SVt_PVHV)
3043 0           return &PL_sv_undef; /* presumably global destruction - bail */
3044             }
3045             /* fetch from inner first, then outer if key doesn't exist */
3046             /* (yes, this is an evil premature optimization) */
3047 22           p += 1; len -= 2; /* ignore the braces */
3048 22 100         if ((attr_svp = hv_fetch(dbh_inner_hv, p, len, 0)) == NULL) {
3049             /* try outer (tied) hash - for things like AutoCommit */
3050             /* (will always return something even for unknowns) */
3051 6 50         if ((attr_svp = hv_fetch(dbh_outer_hv, p, len, 0))) {
3052 6 50         if (SvGMAGICAL(*attr_svp))
3053 6           mg_get(*attr_svp); /* FETCH */
3054             }
3055             }
3056 22 50         if (!attr_svp)
3057 0           p -= 1; /* unignore the braces */
3058 22 100         else if (!SvOK(*attr_svp))
    50          
    50          
3059 6           p = "";
3060 16 50         else if (!SvTRUE(*attr_svp) && SvPOK(*attr_svp) && SvNIOK(*attr_svp))
    50          
    0          
    50          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3061 0           p = "0"; /* catch &sv_no style special case */
3062             else
3063 16 50         p = SvPV_nolen(*attr_svp);
3064 22           dest_node = _profile_next_node(dest_node, p);
3065             }
3066             else {
3067 27964           dest_node = _profile_next_node(dest_node, p);
3068             }
3069             }
3070             /* else undef, so ignore */
3071             }
3072             }
3073             else { /* a bad Path value is treated as a Path of just Statement */
3074 0           dest_node = _profile_next_node(dest_node, statement_pv);
3075             }
3076              
3077              
3078 16680 100         if (!SvOK(dest_node)) {
    50          
    50          
3079 410           av = newAV();
3080 410           sv_setsv(dest_node, newRV_noinc((SV*)av));
3081 410           av_store(av, DBIprof_COUNT, newSViv(1));
3082 410           av_store(av, DBIprof_TOTAL_TIME, newSVnv(ti));
3083 410           av_store(av, DBIprof_FIRST_TIME, newSVnv(ti));
3084 410           av_store(av, DBIprof_MIN_TIME, newSVnv(ti));
3085 410           av_store(av, DBIprof_MAX_TIME, newSVnv(ti));
3086 410           av_store(av, DBIprof_FIRST_CALLED, newSVnv(t1));
3087 410           av_store(av, DBIprof_LAST_CALLED, newSVnv(t1));
3088             }
3089             else {
3090 16270           tmp = dest_node;
3091 16270 50         if (SvROK(tmp))
3092 16270           tmp = SvRV(tmp);
3093 16270 50         if (SvTYPE(tmp) != SVt_PVAV)
3094 0           croak("Invalid Profile data leaf element: %s (type %ld)",
3095 0           neatsvpv(tmp,0), (long)SvTYPE(tmp));
3096 16270           av = (AV*)tmp;
3097 16270           sv_inc( *av_fetch(av, DBIprof_COUNT, 1));
3098 16270           tmp = *av_fetch(av, DBIprof_TOTAL_TIME, 1);
3099 16270 100         sv_setnv(tmp, SvNV(tmp) + ti);
3100 16270           tmp = *av_fetch(av, DBIprof_MIN_TIME, 1);
3101 16270 100         if (ti < SvNV(tmp)) sv_setnv(tmp, ti);
    100          
3102 16270           tmp = *av_fetch(av, DBIprof_MAX_TIME, 1);
3103 16270 100         if (ti > SvNV(tmp)) sv_setnv(tmp, ti);
    100          
3104 16270           sv_setnv( *av_fetch(av, DBIprof_LAST_CALLED, 1), t1);
3105             }
3106 16680           return dest_node; /* use with caution - copy first, ie sv_mortalcopy() */
3107             }
3108              
3109              
3110             static void
3111 372           dbi_profile_merge_nodes(SV *dest, SV *increment)
3112             {
3113             dTHX;
3114             AV *d_av, *i_av;
3115             SV *tmp;
3116             SV *tmp2;
3117             NV i_nv;
3118             int i_is_earlier;
3119              
3120 372 50         if (!SvROK(dest) || SvTYPE(SvRV(dest)) != SVt_PVAV)
    50          
3121 0           croak("dbi_profile_merge_nodes(%s, ...) requires array ref", neatsvpv(dest,0));
3122 372           d_av = (AV*)SvRV(dest);
3123              
3124 372 100         if (av_len(d_av) < DBIprof_max_index) {
3125             int idx;
3126 46           av_extend(d_av, DBIprof_max_index);
3127 368 100         for(idx=0; idx<=DBIprof_max_index; ++idx) {
3128 322           tmp = *av_fetch(d_av, idx, 1);
3129 322 50         if (!SvOK(tmp) && idx != DBIprof_MIN_TIME && idx != DBIprof_FIRST_CALLED)
    50          
    50          
    100          
    100          
3130 230           sv_setnv(tmp, 0.0); /* leave 'min' values as undef */
3131             }
3132             }
3133              
3134 372 50         if (!SvOK(increment))
    0          
    0          
3135 0           return;
3136              
3137 372 50         if (SvROK(increment) && SvTYPE(SvRV(increment)) == SVt_PVHV) {
    100          
3138 2           HV *hv = (HV*)SvRV(increment);
3139             char *key;
3140 2           I32 keylen = 0;
3141 2           hv_iterinit(hv);
3142 6 100         while ( (tmp = hv_iternextsv(hv, &key, &keylen)) != NULL ) {
3143 4           dbi_profile_merge_nodes(dest, tmp);
3144             };
3145 2           return;
3146             }
3147              
3148 370 50         if (!SvROK(increment) || SvTYPE(SvRV(increment)) != SVt_PVAV)
    50          
3149 0           croak("dbi_profile_merge_nodes: increment %s not an array or hash ref", neatsvpv(increment,0));
3150 370           i_av = (AV*)SvRV(increment);
3151              
3152 370           tmp = *av_fetch(d_av, DBIprof_COUNT, 1);
3153 370           tmp2 = *av_fetch(i_av, DBIprof_COUNT, 1);
3154 370 50         if (SvIOK(tmp) && SvIOK(tmp2))
    0          
3155 0 0         sv_setiv( tmp, SvIV(tmp) + SvIV(tmp2) );
    0          
3156             else
3157 370 100         sv_setnv( tmp, SvNV(tmp) + SvNV(tmp2) );
    100          
3158              
3159 370           tmp = *av_fetch(d_av, DBIprof_TOTAL_TIME, 1);
3160 370 100         sv_setnv( tmp, SvNV(tmp) + SvNV( *av_fetch(i_av, DBIprof_TOTAL_TIME, 1)) );
    100          
3161              
3162 370 100         i_nv = SvNV(*av_fetch(i_av, DBIprof_MIN_TIME, 1));
3163 370           tmp = *av_fetch(d_av, DBIprof_MIN_TIME, 1);
3164 370 100         if (!SvOK(tmp) || i_nv < SvNV(tmp)) sv_setnv(tmp, i_nv);
    50          
    50          
    100          
    100          
3165              
3166 370 100         i_nv = SvNV(*av_fetch(i_av, DBIprof_MAX_TIME, 1));
3167 370           tmp = *av_fetch(d_av, DBIprof_MAX_TIME, 1);
3168 370 100         if (i_nv > SvNV(tmp)) sv_setnv(tmp, i_nv);
    100          
3169              
3170 370 100         i_nv = SvNV(*av_fetch(i_av, DBIprof_FIRST_CALLED, 1));
3171 370           tmp = *av_fetch(d_av, DBIprof_FIRST_CALLED, 1);
3172 370 100         i_is_earlier = (!SvOK(tmp) || i_nv < SvNV(tmp));
    50          
    50          
    100          
    100          
3173 370 100         if (i_is_earlier)
3174 77           sv_setnv(tmp, i_nv);
3175              
3176 370 100         i_nv = SvNV(*av_fetch(i_av, DBIprof_FIRST_TIME, 1));
3177 370           tmp = *av_fetch(d_av, DBIprof_FIRST_TIME, 1);
3178 370 100         if (i_is_earlier || !SvOK(tmp)) {
    50          
    0          
    0          
3179             /* If the increment has an earlier DBIprof_FIRST_CALLED
3180             then we set the DBIprof_FIRST_TIME from the increment */
3181 77           sv_setnv(tmp, i_nv);
3182             }
3183              
3184 370 100         i_nv = SvNV(*av_fetch(i_av, DBIprof_LAST_CALLED, 1));
3185 370           tmp = *av_fetch(d_av, DBIprof_LAST_CALLED, 1);
3186 370 100         if (i_nv > SvNV(tmp)) sv_setnv(tmp, i_nv);
    100          
3187             }
3188              
3189              
3190             /* ----------------------------------------------------------------- */
3191             /* --- The DBI dispatcher. The heart of the perl DBI. --- */
3192              
3193             XS(XS_DBI_dispatch); /* prototype to pass -Wmissing-prototypes */
3194 611852           XS(XS_DBI_dispatch)
3195             {
3196 611852           dXSARGS;
3197 611852           dORIGMARK;
3198             dMY_CXT;
3199              
3200 611852           SV *h = ST(0); /* the DBI handle we are working with */
3201 611852           SV *st1 = ST(1); /* used in debugging */
3202 611852           SV *st2 = ST(2); /* used in debugging */
3203 611852           SV *orig_h = h;
3204             SV *err_sv;
3205             SV **tmp_svp;
3206 611852           SV **hook_svp = 0;
3207             MAGIC *mg;
3208 611852 100         int gimme = GIMME;
    100          
3209 611852           I32 trace_flags = DBIS->debug; /* local copy may change during dispatch */
3210 611852           I32 trace_level = (trace_flags & DBIc_TRACE_LEVEL_MASK);
3211             int is_DESTROY;
3212             meth_types meth_type;
3213 611852           int is_unrelated_to_Statement = 0;
3214 611852           U32 keep_error = FALSE;
3215 611852           UV ErrCount = UV_MAX;
3216             int i, outitems;
3217             int call_depth;
3218             int is_nested_call;
3219 611852           NV profile_t1 = 0.0;
3220 611852           int is_orig_method_name = 1;
3221              
3222 611852           const char *meth_name = GvNAME(CvGV(cv));
3223 611852           dbi_ima_t *ima = (dbi_ima_t*)CvXSUBANY(cv).any_ptr;
3224             U32 ima_flags;
3225 611852           imp_xxh_t *imp_xxh = NULL;
3226 611852           SV *imp_msv = Nullsv;
3227 611852           SV *qsv = Nullsv; /* quick result from a shortcut method */
3228              
3229              
3230             #ifdef BROKEN_DUP_ANY_PTR
3231             if (ima->my_perl != my_perl) {
3232             /* we couldn't dup the ima struct at clone time, so do it now */
3233             dbi_ima_t *nima;
3234             Newx(nima, 1, dbi_ima_t);
3235             *nima = *ima; /* structure copy */
3236             CvXSUBANY(cv).any_ptr = nima;
3237             nima->stash = NULL;
3238             nima->gv = NULL;
3239             nima->my_perl = my_perl;
3240             ima = nima;
3241             }
3242             #endif
3243              
3244 611852           ima_flags = ima->flags;
3245 611852           meth_type = ima->meth_type;
3246 611852 100         if (trace_level >= 9) {
3247 116           PerlIO *logfp = DBILOGFP;
3248 116 50         PerlIO_printf(logfp,"%c >> %-11s DISPATCH (%s rc%ld/%ld @%ld g%x ima%lx pid#%ld)",
    50          
3249 116           (PL_dirty?'!':' '), meth_name, neatsvpv(h,0),
3250 348           (long)SvREFCNT(h), (SvROK(h) ? (long)SvREFCNT(SvRV(h)) : (long)-1),
3251 116           (long)items, (int)gimme, (long)ima_flags, (long)PerlProc_getpid());
3252 116           PerlIO_puts(logfp, log_where(0, 0, " at ","\n", 1, (trace_level >= 3), (trace_level >= 4)));
3253 116           PerlIO_flush(logfp);
3254             }
3255              
3256 611852 100         if ( ( (is_DESTROY=(meth_type == methtype_DESTROY))) ) {
3257             /* note that croak()'s won't propagate, only append to $@ */
3258 59123           keep_error = TRUE;
3259             }
3260              
3261             /* If h is a tied hash ref, switch to the inner ref 'behind' the tie.
3262             This means *all* DBI methods work with the inner (non-tied) ref.
3263             This makes it much easier for methods to access the real hash
3264             data (without having to go through FETCH and STORE methods) and
3265             for tie and non-tie methods to call each other.
3266             */
3267 611852 100         if (SvROK(h)
3268 611846 50         && SvRMAGICAL(SvRV(h))
3269 611846 100         && (
3270 611846           ((mg=SvMAGIC(SvRV(h)))->mg_type == 'P')
3271 455725 50         || ((mg=mg_find(SvRV(h),'P')) != NULL)
3272             )
3273             ) {
3274 156121 50         if (mg->mg_obj==NULL || !SvOK(mg->mg_obj) || SvRV(mg->mg_obj)==NULL) { /* maybe global destruction */
    100          
    50          
    50          
    50          
3275 54 50         if (trace_level >= 3)
3276 0 0         PerlIO_printf(DBILOGFP,
3277             "%c <> %s for %s ignored (inner handle gone)\n",
3278 0           (PL_dirty?'!':' '), meth_name, neatsvpv(h,0));
3279 54           XSRETURN(0);
3280             }
3281             /* Distinguish DESTROY of tie (outer) from DESTROY of inner ref */
3282             /* This may one day be used to manually destroy extra internal */
3283             /* refs if the application ceases to use the handle. */
3284 156067 100         if (is_DESTROY) {
3285 29505           imp_xxh = DBIh_COM(mg->mg_obj);
3286             #ifdef DBI_USE_THREADS
3287             if (imp_xxh && DBIc_THR_USER(imp_xxh) != my_perl) {
3288             goto is_DESTROY_wrong_thread;
3289             }
3290             #endif
3291 29505 100         if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB)
    100          
3292 3573           clear_cached_kids(aTHX_ mg->mg_obj, imp_xxh, meth_name, trace_level);
3293             /* XXX might be better to move this down to after call_depth has been
3294             * incremented and then also SvREFCNT_dec(mg->mg_obj) to force an immediate
3295             * DESTROY of the inner handle if there are no other refs to it.
3296             * That way the inner DESTROY is properly flagged as a nested call,
3297             * and the outer DESTROY gets profiled more accurately, and callbacks work.
3298             */
3299 29505 100         if (trace_level >= 3) {
3300 4 50         PerlIO_printf(DBILOGFP,
3301             "%c <> DESTROY(%s) ignored for outer handle (inner %s has ref cnt %ld)\n",
3302 4           (PL_dirty?'!':' '), neatsvpv(h,0), neatsvpv(mg->mg_obj,0),
3303 4           (long)SvREFCNT(SvRV(mg->mg_obj))
3304             );
3305             }
3306             /* for now we ignore it since it'll be followed soon by */
3307             /* a destroy of the inner hash and that'll do the real work */
3308              
3309             /* However, we must at least modify DBIc_MY_H() as that is */
3310             /* pointing (without a refcnt inc) to the scalar that is */
3311             /* being destroyed, so it'll contain random values later. */
3312 29505 100         if (imp_xxh)
3313 29504           DBIc_MY_H(imp_xxh) = (HV*)SvRV(mg->mg_obj); /* inner (untied) HV */
3314              
3315 29505           XSRETURN(0);
3316             }
3317 126562           h = mg->mg_obj; /* switch h to inner ref */
3318 126562           ST(0) = h; /* switch handle on stack to inner ref */
3319             }
3320              
3321 582293           imp_xxh = dbih_getcom2(aTHX_ h, 0); /* get common Internal Handle Attributes */
3322 582293 100         if (!imp_xxh) {
3323 11 100         if (meth_type == methtype_can) { /* ref($h)->can("foo") */
3324 6 50         const char *can_meth = SvPV_nolen(st1);
3325 6           SV *rv = &PL_sv_undef;
3326 6           GV *gv = gv_fetchmethod_autoload(gv_stashsv(orig_h,FALSE), can_meth, FALSE);
3327 6 100         if (gv && isGV(gv))
    50          
3328 4           rv = sv_2mortal(newRV_inc((SV*)GvCV(gv)));
3329 6 50         if (trace_level >= 1) {
3330 0           PerlIO_printf(DBILOGFP," <- %s(%s) = %p\n", meth_name, can_meth, neatsvpv(rv,0));
3331             }
3332 6           ST(0) = rv;
3333 6           XSRETURN(1);
3334             }
3335 5 50         if (trace_level)
3336 0 0         PerlIO_printf(DBILOGFP, "%c <> %s for %s ignored (no imp_data)\n",
3337 0           (PL_dirty?'!':' '), meth_name, neatsvpv(h,0));
3338 5 100         if (!is_DESTROY)
3339 4 50         warn("Can't call %s method on handle %s%s", meth_name, neatsvpv(h,0),
3340 4           SvROK(h) ? " after take_imp_data()" : " (not a reference)");
3341 5           XSRETURN(0);
3342             }
3343              
3344 582282 100         if (DBIc_has(imp_xxh,DBIcf_Profile)) {
3345 60806           profile_t1 = dbi_time(); /* just get start time here */
3346             }
3347              
3348             #ifdef DBI_USE_THREADS
3349             {
3350             PerlInterpreter * h_perl;
3351             is_DESTROY_wrong_thread:
3352             h_perl = DBIc_THR_USER(imp_xxh) ;
3353             if (h_perl != my_perl) {
3354             /* XXX could call a 'handle clone' method here?, for dbh's at least */
3355             if (is_DESTROY) {
3356             if (trace_level >= 3) {
3357             PerlIO_printf(DBILOGFP," DESTROY ignored because DBI %sh handle (%s) is owned by thread %p not current thread %p\n",
3358             dbih_htype_name(DBIc_TYPE(imp_xxh)), HvNAME(DBIc_IMP_STASH(imp_xxh)),
3359             (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ;
3360             PerlIO_flush(DBILOGFP);
3361             }
3362             XSRETURN(0); /* don't DESTROY handle, if it is not our's !*/
3363             }
3364             croak("%s %s failed: handle %d is owned by thread %lx not current thread %lx (%s)",
3365             HvNAME(DBIc_IMP_STASH(imp_xxh)), meth_name, DBIc_TYPE(imp_xxh),
3366             (unsigned long)h_perl, (unsigned long)my_perl,
3367             "handles can't be shared between threads and your driver may need a CLONE method added");
3368             }
3369             }
3370             #endif
3371              
3372 582282 50         if ((i = DBIc_DEBUGIV(imp_xxh))) { /* merge handle into global */
    100          
3373 373           I32 h_trace_level = (i & DBIc_TRACE_LEVEL_MASK);
3374 373 100         if ( h_trace_level > trace_level )
3375 44           trace_level = h_trace_level;
3376 373           trace_flags = (trace_flags & ~DBIc_TRACE_LEVEL_MASK)
3377 373           | ( i & ~DBIc_TRACE_LEVEL_MASK)
3378             | trace_level;
3379             }
3380              
3381             /* Check method call against Internal Method Attributes */
3382 582282 100         if (ima_flags) {
3383              
3384 356152 100         if (ima_flags & (IMA_STUB|IMA_FUNC_REDIRECT|IMA_KEEP_ERR|IMA_KEEP_ERR_SUB|IMA_CLEAR_STMT)) {
3385              
3386 289748 100         if (ima_flags & IMA_STUB) {
3387 106 50         if (meth_type == methtype_can) {
3388 106 50         const char *can_meth = SvPV_nolen(st1);
3389 106           SV *dbi_msv = Nullsv;
3390             /* find handle implementors method (GV or CV) */
3391 106 100         if ( (imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), can_meth, FALSE)) ) {
3392             /* return DBI's CV, not the implementors CV (else we'd bypass dispatch) */
3393             /* and anyway, we may have hit a private method not part of the DBI */
3394 2           GV *gv = gv_fetchmethod_autoload(SvSTASH(SvRV(orig_h)), can_meth, FALSE);
3395 2 50         if (gv && isGV(gv))
    50          
3396 2           dbi_msv = (SV*)GvCV(gv);
3397             }
3398 106 100         if (trace_level >= 1) {
3399 4           PerlIO *logfp = DBILOGFP;
3400 4 50         PerlIO_printf(logfp," <- %s(%s) = %p (%s %p)\n", meth_name, can_meth, (void*)dbi_msv,
3401 0 0         (imp_msv && isGV(imp_msv)) ? HvNAME(GvSTASH(imp_msv)) : "?", (void*)imp_msv);
    0          
    0          
    0          
    0          
    0          
    0          
3402             }
3403 106 100         ST(0) = (dbi_msv) ? sv_2mortal(newRV_inc(dbi_msv)) : &PL_sv_undef;
3404 106           XSRETURN(1);
3405             }
3406 0           XSRETURN(0);
3407             }
3408 289642 100         if (ima_flags & IMA_FUNC_REDIRECT) {
3409             /* XXX this doesn't redispatch, nor consider the IMA of the new method */
3410 7066           SV *meth_name_sv = POPs;
3411 7066           PUTBACK;
3412 7066           --items;
3413 7066 50         if (!SvPOK(meth_name_sv) || SvNIOK(meth_name_sv))
    50          
3414 0           croak("%s->%s() invalid redirect method name %s",
3415             neatsvpv(h,0), meth_name, neatsvpv(meth_name_sv,0));
3416 7066 50         meth_name = SvPV_nolen(meth_name_sv);
3417 7066           meth_type = get_meth_type(meth_name);
3418 7066           is_orig_method_name = 0;
3419             }
3420 289642 100         if (ima_flags & IMA_KEEP_ERR)
3421 257216           keep_error = TRUE;
3422 289642 100         if ((ima_flags & IMA_KEEP_ERR_SUB)
3423 93658 100         && !PL_dirty
3424 93174 100         && DBIc_PARENT_COM(imp_xxh) && DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) > 0)
    100          
3425 32223           keep_error = TRUE;
3426 289642 100         if (ima_flags & IMA_CLEAR_STMT) {
3427             /* don't use SvOK_off: dbh's Statement may be ref to sth's */
3428 32426           (void)hv_store((HV*)SvRV(h), "Statement", 9, &PL_sv_undef, 0);
3429             }
3430 289642 100         if (ima_flags & IMA_CLEAR_CACHED_KIDS)
3431 29563           clear_cached_kids(aTHX_ h, imp_xxh, meth_name, trace_flags);
3432              
3433             }
3434              
3435 356046 100         if (ima_flags & IMA_HAS_USAGE) {
3436 114255           const char *err = NULL;
3437             char msg[200];
3438              
3439 114255 50         if (ima->minargs && (items < ima->minargs
    50          
3440 114255 100         || (ima->maxargs>0 && items > ima->maxargs))) {
    100          
3441 6           sprintf(msg,
3442             "DBI %s: invalid number of arguments: got handle + %ld, expected handle + between %d and %d\n",
3443 6           meth_name, (long)items-1, (int)ima->minargs-1, (int)ima->maxargs-1);
3444 2           err = msg;
3445             }
3446             /* arg type checking could be added here later */
3447 114255 100         if (err) {
3448 114255 50         croak("%sUsage: %s->%s(%s)", err, "$h", meth_name,
3449 2           (ima->usage_msg) ? ima->usage_msg : "...?");
3450             }
3451             }
3452             }
3453              
3454 582174 100         is_unrelated_to_Statement = ( (DBIc_TYPE(imp_xxh) == DBIt_ST) ? 0
    100          
3455 213221           : (DBIc_TYPE(imp_xxh) == DBIt_DR) ? 1
3456             : (ima_flags & IMA_UNRELATED_TO_STMT) );
3457              
3458 582174 100         if (PL_tainting && items > 1 /* method call has args */
    100          
3459 71 100         && DBIc_is(imp_xxh, DBIcf_TaintIn) /* taint checks requested */
3460 34 100         && !(ima_flags & IMA_NO_TAINT_IN)
3461             ) {
3462 39 100         for(i=1; i < items; ++i) {
3463 22 100         if (SvTAINTED(ST(i))) {
    50          
3464             char buf[100];
3465 2 50         sprintf(buf,"parameter %d of %s->%s method call",
3466 2           i, SvPV_nolen(h), meth_name);
3467 2           PL_tainted = 1; /* needed for TAINT_PROPER to work */
3468 2 50         TAINT_PROPER(buf); /* die's */
3469             }
3470             }
3471             }
3472              
3473             /* record this inner handle for use by DBI::var::FETCH */
3474 582172 100         if (is_DESTROY) {
3475              
3476             /* force destruction of any outstanding children */
3477 29563 100         if ((tmp_svp = hv_fetch((HV*)SvRV(h), "ChildHandles", 12, FALSE)) && SvROK(*tmp_svp)) {
    50          
3478 3052           AV *av = (AV*)SvRV(*tmp_svp);
3479             I32 kidslots;
3480 3052           PerlIO *logfp = DBILOGFP;
3481              
3482 3052 50         for (kidslots = AvFILL(av); kidslots >= 0; --kidslots) {
    50          
3483 3052           SV **hp = av_fetch(av, kidslots, FALSE);
3484 3052 50         if (!hp || !SvROK(*hp) || SvTYPE(SvRV(*hp))!=SVt_PVHV)
    50          
    0          
3485             break;
3486              
3487 0 0         if (trace_level >= 1) {
3488 0           PerlIO_printf(logfp, "on DESTROY handle %s still has child %s (refcnt %ld, obj %d, dirty=%d)\n",
3489 0           neatsvpv(h,0), neatsvpv(*hp, 0), (long)SvREFCNT(*hp), !!sv_isobject(*hp), PL_dirty);
3490 0 0         if (trace_level >= 9)
3491 0           sv_dump(SvRV(*hp));
3492             }
3493 0 0         if (sv_isobject(*hp)) { /* call DESTROY on the handle */
3494 0 0         PUSHMARK(SP);
3495 0 0         XPUSHs(*hp);
3496 0           PUTBACK;
3497 0           call_method("DESTROY", G_VOID|G_EVAL|G_KEEPERR);
3498 0           MSPAGAIN;
3499             }
3500             else {
3501 0           imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ *hp, 0);
3502 0 0         if (imp_xxh && DBIc_COMSET(imp_xxh)) {
    0          
3503 0           dbih_clearcom(imp_xxh);
3504 0           sv_setsv(*hp, &PL_sv_undef);
3505             }
3506             }
3507             }
3508             }
3509              
3510 29563 100         if (DBIc_TYPE(imp_xxh) <= DBIt_DB ) { /* is dbh or drh */
3511             imp_xxh_t *parent_imp;
3512              
3513 3630 100         if (SvOK(DBIc_ERR(imp_xxh)) && (parent_imp = DBIc_PARENT_COM(imp_xxh))
    50          
    50          
    50          
3514 47 100         && !PL_dirty /* XXX - remove? */
3515             ) {
3516             /* copy err/errstr/state values to $DBI::err etc still work */
3517 37           sv_setsv(DBIc_ERR(parent_imp), DBIc_ERR(imp_xxh));
3518 37           sv_setsv(DBIc_ERRSTR(parent_imp), DBIc_ERRSTR(imp_xxh));
3519 37           sv_setsv(DBIc_STATE(parent_imp), DBIc_STATE(imp_xxh));
3520             }
3521             }
3522              
3523 29563 100         if (DBIc_AIADESTROY(imp_xxh)) { /* wants ineffective destroy after fork */
3524 10 100         if ((U32)PerlProc_getpid() != _imp2com(imp_xxh, std.pid))
3525 4           DBIc_set(imp_xxh, DBIcf_IADESTROY, 1);
3526             }
3527 29563 100         if (DBIc_IADESTROY(imp_xxh)) { /* wants ineffective destroy */
3528 8 100         DBIc_ACTIVE_off(imp_xxh);
    50          
    50          
    50          
    50          
3529             }
3530 29563           call_depth = 0;
3531 29563           is_nested_call = 0;
3532             }
3533             else {
3534 552609           DBI_SET_LAST_HANDLE(h);
3535 552609           SAVEINT(DBIc_CALL_DEPTH(imp_xxh));
3536 552609           call_depth = ++DBIc_CALL_DEPTH(imp_xxh);
3537              
3538 552609 100         if (ima_flags & IMA_COPY_UP_STMT) { /* execute() */
3539 7997           copy_statement_to_parent(aTHX_ h, imp_xxh);
3540             }
3541 552609           is_nested_call =
3542             (call_depth > 1
3543 785704 100         || (!PL_dirty /* not in global destruction [CPAN #75614] */
    100          
3544 232591 100         && DBIc_PARENT_COM(imp_xxh)
3545 465686 100         && DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh))) >= 1);
    100          
3546              
3547             }
3548              
3549              
3550             /* --- dispatch --- */
3551              
3552 897763 100         if (!keep_error && meth_type != methtype_set_err) {
    100          
3553             SV *err_sv;
3554 315591 100         if (trace_level && SvOK(err_sv=DBIc_ERR(imp_xxh))) {
    50          
    50          
    50          
3555 0           PerlIO *logfp = DBILOGFP;
3556 0 0         PerlIO_printf(logfp, " !! The %s '%s' was CLEARED by call to %s method\n",
    0          
    0          
    0          
    0          
3557 0 0         SvTRUE(err_sv) ? "ERROR" : strlen(SvPV_nolen(err_sv)) ? "warn" : "info",
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3558 0           neatsvpv(DBIc_ERR(imp_xxh),0), meth_name);
3559             }
3560 315591 50         DBIh_CLEAR_ERROR(imp_xxh);
    50          
    50          
3561             }
3562             else { /* we check for change in ErrCount/err_hash during call */
3563 266581           ErrCount = DBIc_ErrCount(imp_xxh);
3564 266581 100         if (keep_error)
3565 257216           keep_error = err_hash(aTHX_ imp_xxh);
3566             }
3567              
3568 582172 100         if (DBIc_has(imp_xxh,DBIcf_Callbacks)
3569 64512 50         && (tmp_svp = hv_fetch((HV*)SvRV(h), "Callbacks", 9, 0))
3570 64512 100         && ( (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), meth_name, strlen(meth_name), 0))
3571             /* the "*" fallback callback only applies to non-nested calls
3572             * and also doesn't apply to the 'set_err' or DESTROY methods.
3573             * Nor during global destruction.
3574             * Other restrictions may be added over time.
3575             * It's an undocumented hack.
3576             */
3577 61582 100         || (!is_nested_call && !PL_dirty && meth_type != methtype_set_err &&
    100          
    100          
    100          
3578 40905 100         meth_type != methtype_DESTROY &&
3579 40905           (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), "*", 1, 0))
3580             )
3581             )
3582 2940 50         && SvROK(*hook_svp)
3583             ) {
3584             SV *orig_defsv;
3585             SV *temp_defsv;
3586 2940           SV *code = SvRV(*hook_svp);
3587 2940           I32 skip_dispatch = 0;
3588 2940 50         if (trace_level)
3589 0 0         PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked with %ld args\n",
3590 0           (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0), (long)items);
3591              
3592             /* we don't use ENTER,SAVETMPS & FREETMPS,LEAVE because we may need mortal
3593             * results to live long enough to be returned to our caller
3594             */
3595             /* we want to localize $_ for the callback but can't just do that alone
3596             * because we're not using SAVETMPS & FREETMPS, so we have to get sneaky.
3597             * We still localize, so we're safe from the callback die-ing,
3598             * but after the callback we manually restore the original $_.
3599             */
3600 2940 50         orig_defsv = DEFSV; /* remember the current $_ */
3601 2940           SAVE_DEFSV; /* local($_) = $method_name */
3602 2940           temp_defsv = sv_2mortal(newSVpv(meth_name,0));
3603             # ifdef SvTEMP_off
3604 2940           SvTEMP_off(temp_defsv);
3605             # endif
3606 2940           DEFSV_set(temp_defsv);
3607              
3608 2940 50         EXTEND(SP, items+1);
    100          
3609 2940 50         PUSHMARK(SP);
3610 2940           PUSHs(orig_h); /* push outer handle, then others params */
3611 14762 100         for (i=1; i < items; ++i) { /* start at 1 to skip handle */
3612 11822           PUSHs( ST(i) );
3613             }
3614 2940           PUTBACK;
3615 2940           outitems = call_sv(code, G_ARRAY); /* call the callback code */
3616 2938           MSPAGAIN;
3617              
3618             /* The callback code can undef $_ to indicate to skip dispatch */
3619 2938 50         skip_dispatch = !SvOK(DEFSV);
    100          
    50          
    50          
    50          
    50          
3620             /* put $_ back now, but with an incremented ref count to compensate
3621             * for the ref count decrement that will happen when we exit the scope.
3622             */
3623 2938           DEFSV_set(SvREFCNT_inc(orig_defsv));
3624              
3625 2938 50         if (trace_level)
3626 0 0         PerlIO_printf(DBILOGFP, "%c }} %s callback %s returned%s\n",
    0          
3627 0           (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0),
3628             skip_dispatch ? ", actual method will not be called" : ""
3629             );
3630 2938 100         if (skip_dispatch) { /* XXX experimental */
3631 1501           int ix = outitems;
3632             /* copy the new items down to the destination list */
3633 3000 100         while (ix-- > 0) {
3634             if(0)warn("\tcopy down %d: %s overwriting %s\n", ix, SvPV_nolen(TOPs), SvPV_nolen(ST(ix)) );
3635 1499           ST(ix) = POPs;
3636             }
3637 1501           imp_msv = *hook_svp; /* for trace and profile */
3638 1501           goto post_dispatch;
3639             }
3640             else {
3641 1437 100         if (outitems != 0)
3642 2           die("Callback for %s returned %d values but must not return any (temporary restriction in current version)",
3643             meth_name, (int)outitems);
3644             /* POP's and PUTBACK? to clear stack */
3645             }
3646             }
3647              
3648             /* set Executed after Callbacks so it's not set if callback elects to skip the method */
3649 580667 100         if (ima_flags & IMA_EXECUTE) {
3650 12756           imp_xxh_t *parent = DBIc_PARENT_COM(imp_xxh);
3651 12756           DBIc_on(imp_xxh, DBIcf_Executed);
3652 12756 50         if (parent)
3653 12756           DBIc_on(parent, DBIcf_Executed);
3654             }
3655              
3656             /* The "quick_FETCH" logic... */
3657             /* Shortcut for fetching attributes to bypass method call overheads */
3658 580667 100         if (meth_type == methtype_FETCH && !DBIc_COMPAT(imp_xxh)) {
    100          
3659             STRLEN kl;
3660 97551 50         const char *key = SvPV(st1, kl);
3661             SV **attr_svp;
3662 97551 50         if (*key != '_' && (attr_svp=hv_fetch((HV*)SvRV(h), key, kl, 0))) {
    100          
3663 48980           qsv = *attr_svp;
3664             /* disable FETCH from cache for special attributes */
3665 48980 100         if (SvROK(qsv) && SvTYPE(SvRV(qsv))==SVt_PVHV && *key=='D' &&
    100          
    100          
    100          
3666 2511 50         ( (kl==6 && DBIc_TYPE(imp_xxh)==DBIt_DB && strEQ(key,"Driver"))
    50          
3667 18 50         || (kl==8 && DBIc_TYPE(imp_xxh)==DBIt_ST && strEQ(key,"Database")) )
    50          
    50          
3668             ) {
3669 2529           qsv = Nullsv;
3670             }
3671             /* disable profiling of FETCH of Profile data */
3672 48980 100         if (*key == 'P' && strEQ(key, "Profile"))
    100          
3673 157           profile_t1 = 0.0;
3674             }
3675 97551 100         if (qsv) { /* skip real method call if we already have a 'quick' value */
3676 46451           ST(0) = sv_mortalcopy(qsv);
3677 46451           outitems = 1;
3678 97551           goto post_dispatch;
3679             }
3680             }
3681              
3682             {
3683             CV *meth_cv;
3684             #ifdef DBI_save_hv_fetch_ent
3685             HE save_mh;
3686             if (meth_type == methtype_FETCH)
3687             save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */
3688             #endif
3689              
3690 534216 100         if (trace_flags) {
3691 1035           SAVEI32(DBIS->debug); /* fall back to orig value later */
3692 1035           DBIS->debug = trace_flags; /* make new value global (for now) */
3693 1035 50         if (ima) {
3694             /* enabling trace via flags takes precedence over disabling due to min level */
3695 1035 100         if ((trace_flags & DBIc_TRACE_FLAGS_MASK) & (ima->method_trace & DBIc_TRACE_FLAGS_MASK))
3696 24           trace_level = (trace_level < 2) ? 2 : trace_level; /* min */
3697             else
3698 1011 100         if (trace_level < (DBIc_TRACE_LEVEL_MASK & ima->method_trace))
3699 174           trace_level = 0; /* silence dispatch log for this method */
3700             }
3701             }
3702              
3703 534216 100         if (is_orig_method_name
3704 527150 100         && ima->stash == DBIc_IMP_STASH(imp_xxh)
3705 455242 100         && ima->generation == PL_sub_generation +
3706 455242 50         MY_cache_gen(DBIc_IMP_STASH(imp_xxh))
3707             )
3708 455200           imp_msv = (SV*)ima->gv;
3709             else {
3710 79016           imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh),
3711             meth_name, FALSE);
3712 79016 100         if (is_orig_method_name) {
3713             /* clear stale entry, if any */
3714 71950           SvREFCNT_dec(ima->stash);
3715 71950           SvREFCNT_dec(ima->gv);
3716 71950 100         if (!imp_msv) {
3717 128           ima->stash = NULL;
3718 128           ima->gv = NULL;
3719             }
3720             else {
3721 71822           ima->stash = (HV*)SvREFCNT_inc(DBIc_IMP_STASH(imp_xxh));
3722 71822           ima->gv = (GV*)SvREFCNT_inc(imp_msv);
3723 71822           ima->generation = PL_sub_generation +
3724 71822 50         MY_cache_gen(DBIc_IMP_STASH(imp_xxh));
3725             }
3726             }
3727             }
3728              
3729             /* if method was a 'func' then try falling back to real 'func' method */
3730 534216 100         if (!imp_msv && (ima_flags & IMA_FUNC_REDIRECT)) {
    100          
3731 3           imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), "func", FALSE);
3732 3 50         if (imp_msv) {
3733             /* driver does have func method so undo the earlier 'func' stack changes */
3734 3           PUSHs(sv_2mortal(newSVpv(meth_name,0)));
3735 3           PUTBACK;
3736 3           ++items;
3737 3           meth_name = "func";
3738 3           meth_type = methtype_ordinary;
3739             }
3740             }
3741              
3742 534216 100         if (trace_level >= (is_nested_call ? 4 : 2)) {
    100          
3743 167           PerlIO *logfp = DBILOGFP;
3744             /* Full pkg method name (or just meth_name for ANON CODE) */
3745 167 50         const char *imp_meth_name = (imp_msv && isGV(imp_msv)) ? GvNAME(imp_msv) : meth_name;
    50          
3746 167           HV *imp_stash = DBIc_IMP_STASH(imp_xxh);
3747 297 100         PerlIO_printf(logfp, "%c -> %s ",
3748 130 50         call_depth>1 ? '0'+call_depth-1 : (PL_dirty?'!':' '), imp_meth_name);
3749 167 50         if (imp_meth_name[0] == 'A' && strEQ(imp_meth_name,"AUTOLOAD"))
    0          
3750 0           PerlIO_printf(logfp, "\"%s\" ", meth_name);
3751 167 50         if (imp_msv && isGV(imp_msv) && GvSTASH(imp_msv) != imp_stash)
    50          
    100          
3752 24 50         PerlIO_printf(logfp, "in %s ", HvNAME(GvSTASH(imp_msv)));
    50          
    50          
    0          
    50          
    50          
3753 167 50         PerlIO_printf(logfp, "for %s (%s", HvNAME(imp_stash),
    50          
    50          
    50          
    0          
    50          
    50          
3754 167           SvPV_nolen(orig_h));
3755 167 100         if (h != orig_h) /* show inner handle to aid tracing */
3756 57           PerlIO_printf(logfp, "~0x%lx", (long)SvRV(h));
3757 110           else PerlIO_printf(logfp, "~INNER");
3758 474 100         for(i=1; i
3759 614 50         PerlIO_printf(logfp," %s",
3760 307 100         (ima && i==ima->hidearg) ? "****" : neatsvpv(ST(i),0));
3761             }
3762             #ifdef DBI_USE_THREADS
3763             PerlIO_printf(logfp, ") thr#%p\n", (void*)DBIc_THR_USER(imp_xxh));
3764             #else
3765 167           PerlIO_printf(logfp, ")\n");
3766             #endif
3767 167           PerlIO_flush(logfp);
3768             }
3769              
3770 534216 100         if (!imp_msv || ! ((meth_cv = GvCV(imp_msv))) ) {
    50          
3771 128 50         if (PL_dirty || is_DESTROY) {
    50          
3772 0           outitems = 0;
3773 0           goto post_dispatch;
3774             }
3775 128 100         if (ima_flags & IMA_NOT_FOUND_OKAY) {
3776 124           outitems = 0;
3777 124           goto post_dispatch;
3778             }
3779 12 50         croak("Can't locate DBI object method \"%s\" via package \"%s\"",
    50          
3780 8 50         meth_name, HvNAME(DBIc_IMP_STASH(imp_xxh)));
    0          
    50          
    50          
3781             }
3782              
3783 534088 50         PUSHMARK(mark); /* mark arguments again so we can pass them on */
3784              
3785             /* Note: the handle on the stack is still an object blessed into a
3786             * DBI::* class and not the DBD::*::* class whose method is being
3787             * invoked. This is correct and should be largely transparent.
3788             */
3789              
3790             /* SHORT-CUT ALERT! */
3791 534088 50         if (use_xsbypass && CvISXSUB(meth_cv) && CvXSUB(meth_cv)) {
    100          
    50          
3792              
3793             /* If we are calling an XSUB we jump directly to its C code and
3794             * bypass perl_call_sv(), pp_entersub() etc. This is fast.
3795             * This code is based on a small section of pp_entersub().
3796             */
3797 165600           (void)(*CvXSUB(meth_cv))(aTHXo_ meth_cv); /* Call the C code directly */
3798              
3799 331188 100         if (gimme == G_SCALAR) { /* Enforce sanity in scalar context */
3800 164082 100         if (ax != PL_stack_sp - PL_stack_base ) { /* outitems != 1 */
3801 50644           ST(0) =
3802 25322           (ax > PL_stack_sp - PL_stack_base)
3803             ? &PL_sv_undef /* outitems == 0 */
3804 25322 50         : *PL_stack_sp; /* outitems > 1 */
3805 25322           PL_stack_sp = PL_stack_base + ax;
3806             }
3807 164082           outitems = 1;
3808             }
3809             else {
3810 1512           outitems = PL_stack_sp - (PL_stack_base + ax - 1);
3811             }
3812              
3813             }
3814             else {
3815             /* sv_dump(imp_msv); */
3816 368488 100         outitems = call_sv((SV*)meth_cv,
3817             (is_DESTROY ? gimme | G_EVAL | G_KEEPERR : gimme) );
3818             }
3819              
3820 534056           XSprePUSH; /* reset SP to base of stack frame */
3821              
3822             #ifdef DBI_save_hv_fetch_ent
3823             if (meth_type == methtype_FETCH)
3824             PL_hv_fetch_ent_mh = save_mh; /* see start of block */
3825             #endif
3826             }
3827              
3828             post_dispatch:
3829              
3830 582132 100         if (is_DESTROY && DBI_IS_LAST_HANDLE(h)) { /* if destroying _this_ handle */
    100          
3831 26629           SV *lhp = DBIc_PARENT_H(imp_xxh);
3832 26629 50         if (lhp && SvROK(lhp)) {
    100          
3833 26346           DBI_SET_LAST_HANDLE(lhp);
3834             }
3835             else {
3836 283           DBI_UNSET_LAST_HANDLE;
3837             }
3838             }
3839              
3840 582132 100         if (keep_error) {
3841             /* if we didn't clear err before the call, check to see if a new error
3842             * or warning has been recorded. If so, turn off keep_error so it gets acted on
3843             */
3844 257212 100         if (DBIc_ErrCount(imp_xxh) > ErrCount || err_hash(aTHX_ imp_xxh) != keep_error) {
    100          
3845 1485           keep_error = 0;
3846             }
3847             }
3848              
3849 582132           err_sv = DBIc_ERR(imp_xxh);
3850              
3851 582132 100         if (trace_level >= (is_nested_call ? 3 : 1)) {
    100          
3852 222           PerlIO *logfp = DBILOGFP;
3853 222 50         const int is_fetch = (meth_type == methtype_fetch_star && DBIc_TYPE(imp_xxh)==DBIt_ST);
    0          
3854 222 50         const IV row_count = (is_fetch) ? DBIc_ROW_COUNT((imp_sth_t*)imp_xxh) : 0;
3855 222 50         if (is_fetch && row_count>=2 && trace_level<=4 && SvOK(ST(0))) {
    0          
    0          
    0          
    0          
    0          
3856             /* skip the 'middle' rows to reduce output */
3857             goto skip_meth_return_trace;
3858             }
3859 222 50         if (SvOK(err_sv)) {
    50          
    50          
3860 0 0         PerlIO_printf(logfp, " %s %s %s %s (err#%ld)\n", (keep_error) ? " " : "!!",
    0          
    0          
    0          
    0          
    0          
3861 0 0         SvTRUE(err_sv) ? "ERROR:" : strlen(SvPV_nolen(err_sv)) ? "warn:" : "info:",
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3862 0           neatsvpv(err_sv,0), neatsvpv(DBIc_ERRSTR(imp_xxh),0), (long)DBIc_ErrCount(imp_xxh));
3863             }
3864 394 100         PerlIO_printf(logfp,"%c%c <%c %s",
    50          
    100          
3865 172 100         (call_depth > 1) ? '0'+call_depth-1 : (PL_dirty?'!':' '),
3866 222           (DBIc_is(imp_xxh, DBIcf_TaintIn|DBIcf_TaintOut)) ? 'T' : ' ',
3867             (qsv) ? '>' : '-',
3868             meth_name);
3869 222 100         if (trace_level==1 && (items>=2||is_DESTROY)) { /* make level 1 more useful */
    100          
    100          
3870             /* we only have the first two parameters available here */
3871 28 100         if (is_DESTROY) /* show handle as first arg to DESTROY */
3872             /* want to show outer handle so trace makes sense */
3873             /* but outer handle has been destroyed so we fake it */
3874 3 50         PerlIO_printf(logfp,"(%s=HASH(0x%p)", HvNAME(SvSTASH(SvRV(orig_h))), (void*)DBIc_MY_H(imp_xxh));
    50          
    50          
    0          
    50          
    50          
3875             else
3876 25           PerlIO_printf(logfp,"(%s", neatsvpv(st1,0));
3877 28 100         if (items >= 3)
3878 20           PerlIO_printf(logfp,", %s", neatsvpv(st2,0));
3879 28 100         PerlIO_printf(logfp,"%s)", (items > 3) ? ", ..." : "");
3880             }
3881              
3882 222 50         if (gimme & G_ARRAY)
3883 222           PerlIO_printf(logfp,"= (");
3884 0           else PerlIO_printf(logfp,"=");
3885 478 100         for(i=0; i < outitems; ++i) {
3886 256           SV *s = ST(i);
3887 256 100         if ( SvROK(s) && SvTYPE(SvRV(s))==SVt_PVAV) {
    50          
3888 0           AV *av = (AV*)SvRV(s);
3889             int avi;
3890 0 0         int avi_last = SvIV(DBIS->neatsvpvlen) / 10;
3891 0 0         if (avi_last < 39)
3892 0           avi_last = 39;
3893 0           PerlIO_printf(logfp, " [");
3894 0 0         for (avi=0; avi <= AvFILL(av); ++avi) {
    0          
3895 0           PerlIO_printf(logfp, " %s", neatsvpv(AvARRAY(av)[avi],0));
3896 0 0         if (avi >= avi_last && AvFILL(av) - avi > 1) {
    0          
    0          
3897 0 0         PerlIO_printf(logfp, " ... %ld others skipped", AvFILL(av) - avi);
3898 0           break;
3899             }
3900             }
3901 0           PerlIO_printf(logfp, " ]");
3902             }
3903             else {
3904 256           PerlIO_printf(logfp, " %s", neatsvpv(s,0));
3905 256 100         if ( SvROK(s) && SvTYPE(SvRV(s))==SVt_PVHV && !SvOBJECT(SvRV(s)) )
    50          
    100          
3906 5 50         PerlIO_printf(logfp, "%ldkeys", (long)HvKEYS(SvRV(s)));
3907             }
3908             }
3909 222 50         if (gimme & G_ARRAY) {
3910 222           PerlIO_printf(logfp," ) [%d items]", outitems);
3911             }
3912 222 50         if (is_fetch && row_count) {
    0          
3913 0           PerlIO_printf(logfp," row%"IVdf, row_count);
3914             }
3915 222 100         if (qsv) /* flag as quick and peek at the first arg (still on the stack) */
3916 11           PerlIO_printf(logfp," (%s from cache)", neatsvpv(st1,0));
3917 211 50         else if (!imp_msv)
3918 0           PerlIO_printf(logfp," (not implemented)");
3919             /* XXX add flag to show pid here? */
3920             /* add file and line number information */
3921 222           PerlIO_puts(logfp, log_where(0, 0, " at ", "\n", 1, (trace_level >= 3), (trace_level >= 4)));
3922             skip_meth_return_trace:
3923 222           PerlIO_flush(logfp);
3924             }
3925              
3926 582132 100         if (ima_flags & IMA_END_WORK) { /* commit() or rollback() */
3927             /* XXX does not consider if the method call actually worked or not */
3928 4           DBIc_off(imp_xxh, DBIcf_Executed);
3929              
3930 4 100         if (DBIc_has(imp_xxh, DBIcf_BegunWork)) {
3931 2           DBIc_off(imp_xxh, DBIcf_BegunWork);
3932 2 50         if (!DBIc_has(imp_xxh, DBIcf_AutoCommit)) {
3933             /* We only get here if the driver hasn't implemented their own code */
3934             /* for begin_work, or has but hasn't correctly turned AutoCommit */
3935             /* back on in their commit or rollback code. So we have to do it. */
3936             /* This is bad because it'll probably trigger a spurious commit() */
3937             /* and may mess up the error handling below for the commit/rollback */
3938 2 50         PUSHMARK(SP);
3939 2 50         XPUSHs(h);
3940 2 50         XPUSHs(sv_2mortal(newSVpv("AutoCommit",0)));
3941 2 50         XPUSHs(&PL_sv_yes);
3942 2           PUTBACK;
3943 2           call_method("STORE", G_VOID);
3944 582132           MSPAGAIN;
3945             }
3946             }
3947             }
3948              
3949             if (PL_tainting
3950             && DBIc_is(imp_xxh, DBIcf_TaintOut) /* taint checks requested */
3951             /* XXX this would taint *everything* being returned from *any* */
3952             /* method that doesn't have IMA_NO_TAINT_OUT set. */
3953             /* DISABLED: just tainting fetched data in get_fbav seems ok */
3954             && 0/* XXX disabled*/ /* !(ima_flags & IMA_NO_TAINT_OUT) */
3955             ) {
3956             dTHR;
3957             TAINT; /* affects sv_setsv()'s within same perl statement */
3958             for(i=0; i < outitems; ++i) {
3959             I32 avi;
3960             char *p;
3961             SV *s;
3962             SV *agg = ST(i);
3963             if ( !SvROK(agg) )
3964             continue;
3965             agg = SvRV(agg);
3966             #define DBI_OUT_TAINTABLE(s) (!SvREADONLY(s) && !SvTAINTED(s))
3967             switch (SvTYPE(agg)) {
3968             case SVt_PVAV:
3969             for(avi=0; avi <= AvFILL((AV*)agg); ++avi) {
3970             s = AvARRAY((AV*)agg)[avi];
3971             if (DBI_OUT_TAINTABLE(s))
3972             SvTAINTED_on(s);
3973             }
3974             break;
3975             case SVt_PVHV:
3976             hv_iterinit((HV*)agg);
3977             while( (s = hv_iternextsv((HV*)agg, &p, &avi)) ) {
3978             if (DBI_OUT_TAINTABLE(s))
3979             SvTAINTED_on(s);
3980             }
3981             break;
3982             default:
3983             if (DBIc_WARN(imp_xxh)) {
3984             PerlIO_printf(DBILOGFP,"Don't know how to taint contents of returned %s (type %d)\n",
3985             neatsvpv(agg,0), (int)SvTYPE(agg));
3986             }
3987             }
3988             }
3989             }
3990              
3991             /* if method returned a new handle, and that handle has an error on it
3992             * then copy the error up into the parent handle
3993             */
3994 582132 100         if (ima_flags & IMA_IS_FACTORY && SvROK(ST(0))) {
    100          
3995 32414           SV *h_new = ST(0);
3996 32414           D_impdata(imp_xxh_new, imp_xxh_t, h_new);
3997 32414 50         if (SvOK(DBIc_ERR(imp_xxh_new))) {
    50          
    50          
3998 0           set_err_sv(h, imp_xxh, DBIc_ERR(imp_xxh_new), DBIc_ERRSTR(imp_xxh_new), DBIc_STATE(imp_xxh_new), &PL_sv_no);
3999             }
4000             }
4001              
4002 669601 100         if ( !keep_error /* is a new err/warn/info */
    50          
    100          
    100          
    50          
4003 326405 100         && !is_nested_call /* skip nested (internal) calls */
4004 84168 50         && (
4005             /* is an error and has RaiseError|PrintError|HandleError set */
4006 87469 0         (SvTRUE(err_sv) && DBIc_has(imp_xxh, DBIcf_RaiseError|DBIcf_PrintError|DBIcf_HandleError))
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    50          
    0          
    0          
    50          
    0          
    100          
4007             /* is a warn (not info) and has PrintWarn set */
4008 80995 100         || ( SvOK(err_sv) && strlen(SvPV_nolen(err_sv)) && DBIc_has(imp_xxh, DBIcf_PrintWarn))
    50          
    50          
    100          
    100          
    50          
4009             )
4010 167           ) {
4011             SV *msg;
4012 3310           SV **statement_svp = NULL;
4013 3310 50         const int is_warning = (!SvTRUE(err_sv) && strlen(SvPV_nolen(err_sv))==1);
    50          
    0          
    50          
    0          
    0          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    50          
    50          
4014 3310           const char *err_meth_name = meth_name;
4015             char intro[200];
4016              
4017 3310 100         if (meth_type == methtype_set_err) {
4018 56           SV **sem_svp = hv_fetch((HV*)SvRV(h), "dbi_set_err_method", 18, GV_ADDWARN);
4019 56 100         if (SvOK(*sem_svp))
    50          
    50          
4020 8 50         err_meth_name = SvPV_nolen(*sem_svp);
4021             }
4022              
4023             /* XXX change to vsprintf into sv directly */
4024 6620 50         sprintf(intro,"%s %s %s: ", HvNAME(DBIc_IMP_STASH(imp_xxh)), err_meth_name,
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    0          
    50          
    50          
4025 3310 0         SvTRUE(err_sv) ? "failed" : is_warning ? "warning" : "information");
    0          
    0          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    0          
    0          
    50          
    0          
    50          
4026 3310           msg = sv_2mortal(newSVpv(intro,0));
4027 3310 50         if (SvOK(DBIc_ERRSTR(imp_xxh)))
    0          
    0          
4028 3310           sv_catsv(msg, DBIc_ERRSTR(imp_xxh));
4029             else
4030 0           sv_catpvf(msg, "(err=%s, errstr=undef, state=%s)",
4031 0           neatsvpv(DBIc_ERR(imp_xxh),0), neatsvpv(DBIc_STATE(imp_xxh),0) );
4032              
4033 3310 100         if ( DBIc_has(imp_xxh, DBIcf_ShowErrorStatement)
4034 160 100         && !is_unrelated_to_Statement
4035 152 100         && (DBIc_TYPE(imp_xxh) == DBIt_ST || ima_flags & IMA_SHOW_ERR_STMT)
    50          
4036 152 50         && (statement_svp = hv_fetch((HV*)SvRV(h), "Statement", 9, 0))
4037 152 50         && statement_svp && SvOK(*statement_svp)
    50          
    0          
    0          
4038             ) {
4039 152           SV **svp = 0;
4040 152           sv_catpv(msg, " [for Statement \"");
4041 152           sv_catsv(msg, *statement_svp);
4042              
4043             /* fetch from tied outer handle to trigger FETCH magic */
4044             /* could add DBIcf_ShowErrorParams (default to on?) */
4045 152 100         if (!(ima_flags & IMA_HIDE_ERR_PARAMVALUES)) {
4046 144           svp = hv_fetch((HV*)DBIc_MY_H(imp_xxh),"ParamValues",11,FALSE);
4047 144 50         if (svp && SvMAGICAL(*svp))
    50          
4048 144           mg_get(*svp); /* XXX may recurse, may croak. could use eval */
4049             }
4050 160 100         if (svp && SvRV(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV && HvKEYS(SvRV(*svp))>0 ) {
    100          
    50          
    50          
    50          
4051 8           SV *param_values_sv = sv_2mortal(_join_hash_sorted((HV*)SvRV(*svp), "=",1, ", ",2, 1, -1));
4052 8           sv_catpv(msg, "\" with ParamValues: ");
4053 8           sv_catsv(msg, param_values_sv);
4054 8           sv_catpvn(msg, "]", 1);
4055             }
4056             else {
4057 3310           sv_catpv(msg, "\"]");
4058             }
4059             }
4060              
4061             if (0) {
4062             COP *cop = dbi_caller_cop();
4063             if (cop && (CopLINE(cop) != CopLINE(PL_curcop) || CopFILEGV(cop) != CopFILEGV(PL_curcop))) {
4064             dbi_caller_string(msg, cop, " called via ", 1, 0);
4065             }
4066             }
4067              
4068 3310           hook_svp = NULL;
4069 3310 50         if ( SvTRUE(err_sv)
    50          
    50          
    0          
    0          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    0          
    0          
    100          
4070 3301 100         && DBIc_has(imp_xxh, DBIcf_HandleError)
4071 8 50         && (hook_svp = hv_fetch((HV*)SvRV(h),"HandleError",11,0))
4072 8 50         && hook_svp && SvOK(*hook_svp)
    50          
    0          
    0          
4073             ) {
4074 8           dSP;
4075 8           PerlIO *logfp = DBILOGFP;
4076             IV items;
4077             SV *status;
4078             SV *result; /* point to result SV that's pointed to by the stack */
4079 8 50         if (outitems) {
4080 8           result = *(sp-outitems+1);
4081 8 50         if (SvREADONLY(result)) {
4082 8           *(sp-outitems+1) = result = sv_2mortal(newSVsv(result));
4083             }
4084             }
4085             else {
4086 0           result = sv_newmortal();
4087             }
4088 8 50         if (trace_level)
4089 0 0         PerlIO_printf(logfp," -> HandleError on %s via %s%s%s%s\n",
    0          
    0          
4090             neatsvpv(h,0), neatsvpv(*hook_svp,0),
4091             (!outitems ? "" : " ("),
4092             (!outitems ? "" : neatsvpv(result ,0)),
4093             (!outitems ? "" : ")")
4094             );
4095 8 50         PUSHMARK(SP);
4096 8 50         XPUSHs(msg);
4097 8 50         XPUSHs(sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh))));
4098 8 50         XPUSHs( result );
4099 8           PUTBACK;
4100 8           items = call_sv(*hook_svp, G_SCALAR);
4101 6           MSPAGAIN;
4102 6 50         status = (items) ? POPs : &PL_sv_undef;
4103 6           PUTBACK;
4104 6 50         if (trace_level)
4105 0 0         PerlIO_printf(logfp," <- HandleError= %s%s%s%s\n",
    0          
    0          
4106             neatsvpv(status,0),
4107             (!outitems ? "" : " ("),
4108             (!outitems ? "" : neatsvpv(result,0)),
4109             (!outitems ? "" : ")")
4110             );
4111 6 50         if (!SvTRUE(status)) /* handler says it didn't handle it, so... */
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    100          
    50          
    0          
    100          
    0          
4112 2           hook_svp = 0; /* pretend we didn't have a handler... */
4113             }
4114              
4115 3308 50         if (profile_t1) { /* see also dbi_profile() call a few lines below */
4116 0 0         SV *statement_sv = (is_unrelated_to_Statement) ? &PL_sv_no : &PL_sv_undef;
4117 0 0         dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv,
4118             profile_t1, dbi_time());
4119             }
4120 3308 100         if (is_warning) {
4121 9 50         if (DBIc_has(imp_xxh, DBIcf_PrintWarn))
4122 9           warn_sv(msg);
4123             }
4124 3299 100         else if (!hook_svp && SvTRUE(err_sv)) {
    50          
    50          
    50          
    0          
    0          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    50          
4125 3295 100         if (DBIc_has(imp_xxh, DBIcf_PrintError))
4126 26           warn_sv(msg);
4127 3295 100         if (DBIc_has(imp_xxh, DBIcf_RaiseError))
4128 3141           croak_sv(msg);
4129             }
4130             }
4131 578822 100         else if (profile_t1) { /* see also dbi_profile() call a few lines above */
4132 60649 100         SV *statement_sv = (is_unrelated_to_Statement) ? &PL_sv_no : &PL_sv_undef;
4133 60649 100         dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv,
4134             profile_t1, dbi_time());
4135             }
4136 578989           XSRETURN(outitems);
4137             }
4138              
4139              
4140              
4141             /* -------------------------------------------------------------------- */
4142              
4143             /* comment and placeholder styles to accept and return */
4144              
4145             #define DBIpp_cm_cs 0x000001 /* C style */
4146             #define DBIpp_cm_hs 0x000002 /* # */
4147             #define DBIpp_cm_dd 0x000004 /* -- */
4148             #define DBIpp_cm_br 0x000008 /* {} */
4149             #define DBIpp_cm_dw 0x000010 /* '-- ' dash dash whitespace */
4150             #define DBIpp_cm_XX 0x00001F /* any of the above */
4151              
4152             #define DBIpp_ph_qm 0x000100 /* ? */
4153             #define DBIpp_ph_cn 0x000200 /* :1 */
4154             #define DBIpp_ph_cs 0x000400 /* :name */
4155             #define DBIpp_ph_sp 0x000800 /* %s (as return only, not accept) */
4156             #define DBIpp_ph_XX 0x000F00 /* any of the above */
4157              
4158             #define DBIpp_st_qq 0x010000 /* '' char escape */
4159             #define DBIpp_st_bs 0x020000 /* \ char escape */
4160             #define DBIpp_st_XX 0x030000 /* any of the above */
4161              
4162             #define DBIpp_L_BRACE '{'
4163             #define DBIpp_R_BRACE '}'
4164             #define PS_accept(flag) DBIbf_has(ps_accept,(flag))
4165             #define PS_return(flag) DBIbf_has(ps_return,(flag))
4166              
4167             SV *
4168 52           preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void *foo)
4169             {
4170             dTHX;
4171 52           D_imp_xxh(dbh);
4172             /*
4173             The idea here is that ps_accept defines which constructs to
4174             recognize (accept) as valid in the source string (other
4175             constructs are ignored), and ps_return defines which
4176             constructs are valid to return in the result string.
4177              
4178             If a construct that is valid in the input is also valid in the
4179             output then it's simply copied. If it's not valid in the output
4180             then it's editied into one of the valid forms (ideally the most
4181             'standard' and/or information preserving one).
4182              
4183             For example, if ps_accept includes '--' style comments but
4184             ps_return doesn't, but ps_return does include '#' style
4185             comments then any '--' style comments would be rewritten as '#'
4186             style comments.
4187              
4188             Similarly for placeholders. DBD::Oracle, for example, would say
4189             '?', ':1' and ':name' are all acceptable input, but only
4190             ':name' should be returned.
4191              
4192             (There's a tricky issue with the '--' comment style because it can
4193             clash with valid syntax, i.e., "... set foo=foo--1 ..." so it
4194             would be *bad* to misinterpret that as the start of a comment.
4195             Perhaps we need a DBIpp_cm_dw (for dash-dash-whitespace) style
4196             to allow for that.)
4197              
4198             Also, we'll only support DBIpp_cm_br as an input style. And
4199             even then, only with reluctance. We may (need to) drop it when
4200             we add support for odbc escape sequences.
4201             */
4202 52           int idx = 1;
4203              
4204 52           char in_quote = '\0';
4205 52           char in_comment = '\0';
4206 52           char rt_comment = '\0';
4207             char *dest, *start;
4208             const char *src;
4209 52           const char *style = "", *laststyle = NULL;
4210             SV *new_stmt_sv;
4211              
4212             (void)foo;
4213              
4214             if (!(ps_return | DBIpp_ph_XX)) { /* no return ph type specified */
4215             ps_return |= ps_accept | DBIpp_ph_XX; /* so copy from ps_accept */
4216             }
4217              
4218             /* XXX this allocation strategy won't work when we get to more advanced stuff */
4219 52           new_stmt_sv = newSV(strlen(statement) * 3);
4220 52           sv_setpv(new_stmt_sv,"");
4221 52           src = statement;
4222 52           dest = SvPVX(new_stmt_sv);
4223              
4224 684 100         while( *src )
4225             {
4226 636 50         if (*src == '%' && PS_return(DBIpp_ph_sp))
    0          
4227 0           *dest++ = '%';
4228              
4229 636 100         if (in_comment)
4230             {
4231 116 100         if ( (in_comment == '-' && (*src == '\n' || *(src+1) == '\0'))
    100          
    50          
4232 108 100         || (in_comment == '#' && (*src == '\n' || *(src+1) == '\0'))
    100          
    50          
4233 102 100         || (in_comment == DBIpp_L_BRACE && *src == DBIpp_R_BRACE) /* XXX nesting? */
    100          
4234 98 100         || (in_comment == '/' && *src == '*' && *(src+1) == '/')
    100          
    50          
4235             ) {
4236 28           switch (rt_comment) {
4237 4           case '/': *dest++ = '*'; *dest++ = '/'; break;
4238 4           case '-': *dest++ = '\n'; break;
4239 2           case '#': *dest++ = '\n'; break;
4240 8           case DBIpp_L_BRACE: *dest++ = DBIpp_R_BRACE; break;
4241             case '\0': /* ensure deleting a comment doesn't join two tokens */
4242 10 100         if (in_comment=='/' || in_comment==DBIpp_L_BRACE)
    100          
4243 4           *dest++ = ' '; /* ('-' and '#' styles use the newline) */
4244 10           break;
4245             }
4246 28 100         if (in_comment == '/')
4247 10           src++;
4248 28 100         src += (*src != '\n' || *(dest-1)=='\n') ? 1 : 0;
    100          
4249 28           in_comment = '\0';
4250 28           rt_comment = '\0';
4251             }
4252             else
4253 88 100         if (rt_comment)
4254 76           *dest++ = *src++;
4255             else
4256 12           src++; /* delete (don't copy) the comment */
4257 116           continue;
4258             }
4259              
4260 520 100         if (in_quote)
4261             {
4262 100 100         if (*src == in_quote) {
4263 8           in_quote = 0;
4264             }
4265 100           *dest++ = *src++;
4266 100           continue;
4267             }
4268              
4269             /* Look for comments */
4270 420 100         if (*src == '-' && *(src+1) == '-' &&
    50          
    100          
4271 2 50         (PS_accept(DBIpp_cm_dd) || (*(src+2) == ' ' && PS_accept(DBIpp_cm_dw)))
    50          
4272             )
4273             {
4274 8           in_comment = *src;
4275 8           src += 2; /* skip past 2nd char of double char delimiters */
4276 8 50         if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) {
    50          
4277 0           *dest++ = rt_comment = '-';
4278 0           *dest++ = '-';
4279 0 0         if (PS_return(DBIpp_cm_dw) && *src!=' ')
    0          
4280 0           *dest++ = ' '; /* insert needed white space */
4281             }
4282 8 50         else if (PS_return(DBIpp_cm_cs)) {
4283 0           *dest++ = rt_comment = '/';
4284 0           *dest++ = '*';
4285             }
4286 8 50         else if (PS_return(DBIpp_cm_hs)) {
4287 0           *dest++ = rt_comment = '#';
4288             }
4289 8 100         else if (PS_return(DBIpp_cm_br)) {
4290 4           *dest++ = rt_comment = DBIpp_L_BRACE;
4291             }
4292 8           continue;
4293             }
4294 412 100         else if (*src == '/' && *(src+1) == '*' && PS_accept(DBIpp_cm_cs))
    50          
    50          
4295             {
4296 12           in_comment = *src;
4297 12           src += 2; /* skip past 2nd char of double char delimiters */
4298 12 100         if (PS_return(DBIpp_cm_cs)) {
4299 2           *dest++ = rt_comment = '/';
4300 2           *dest++ = '*';
4301             }
4302 10 50         else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) {
    100          
4303 2           *dest++ = rt_comment = '-';
4304 2           *dest++ = '-';
4305 2 50         if (PS_return(DBIpp_cm_dw)) *dest++ = ' ';
4306             }
4307 8 100         else if (PS_return(DBIpp_cm_hs)) {
4308 2           *dest++ = rt_comment = '#';
4309             }
4310 6 100         else if (PS_return(DBIpp_cm_br)) {
4311 4           *dest++ = rt_comment = DBIpp_L_BRACE;
4312             }
4313 12           continue;
4314             }
4315 400 100         else if (*src == '#' && PS_accept(DBIpp_cm_hs))
    50          
4316             {
4317 6           in_comment = *src;
4318 6           src++;
4319 6 50         if (PS_return(DBIpp_cm_hs)) {
4320 0           *dest++ = rt_comment = '#';
4321             }
4322 6 50         else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) {
    100          
4323 2           *dest++ = rt_comment = '-';
4324 2           *dest++ = '-';
4325 2 50         if (PS_return(DBIpp_cm_dw)) *dest++ = ' ';
4326             }
4327 4 100         else if (PS_return(DBIpp_cm_cs)) {
4328 2           *dest++ = rt_comment = '/';
4329 2           *dest++ = '*';
4330             }
4331 2 50         else if (PS_return(DBIpp_cm_br)) {
4332 0           *dest++ = rt_comment = DBIpp_L_BRACE;
4333             }
4334 6           continue;
4335             }
4336 394 100         else if (*src == DBIpp_L_BRACE && PS_accept(DBIpp_cm_br))
    50          
4337             {
4338 6           in_comment = *src;
4339 6           src++;
4340 6 100         if (PS_return(DBIpp_cm_br)) {
4341 2           *dest++ = rt_comment = DBIpp_L_BRACE;
4342             }
4343 4 50         else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) {
    50          
4344 0           *dest++ = rt_comment = '-';
4345 0           *dest++ = '-';
4346 0 0         if (PS_return(DBIpp_cm_dw)) *dest++ = ' ';
4347             }
4348 4 100         else if (PS_return(DBIpp_cm_cs)) {
4349 2           *dest++ = rt_comment = '/';
4350 2           *dest++ = '*';
4351             }
4352 2 50         else if (PS_return(DBIpp_cm_hs)) {
4353 0           *dest++ = rt_comment = '#';
4354             }
4355 6           continue;
4356             }
4357              
4358 388 100         if ( !(*src==':' && (PS_accept(DBIpp_ph_cn) || PS_accept(DBIpp_ph_cs)))
    100          
    50          
4359 372 100         && !(*src=='?' && PS_accept(DBIpp_ph_qm))
    50          
4360             ){
4361 338 100         if (*src == '\'' || *src == '"')
    100          
4362 12           in_quote = *src;
4363 338           *dest++ = *src++;
4364 338           continue;
4365             }
4366              
4367             /* only here for : or ? outside of a comment or literal */
4368              
4369 50           start = dest; /* save name inc colon */
4370 50           *dest++ = *src++; /* copy and move past first char */
4371              
4372 50 100         if (*start == '?') /* X/Open Standard */
4373             {
4374 34           style = "?";
4375              
4376 34 50         if (PS_return(DBIpp_ph_qm))
4377             ;
4378 34 100         else if (PS_return(DBIpp_ph_cn)) { /* '?' -> ':p1' (etc) */
4379 32           sprintf(start,":p%d", idx++);
4380 32           dest = start+strlen(start);
4381             }
4382 2 50         else if (PS_return(DBIpp_ph_sp)) { /* '?' -> '%s' */
4383 2           *start = '%';
4384 34           *dest++ = 's';
4385             }
4386             }
4387 16 100         else if (isDIGIT(*src)) { /* :1 */
4388 10           const int pln = atoi(src);
4389 10           style = ":1";
4390              
4391 10 50         if (PS_return(DBIpp_ph_cn)) { /* ':1'->':p1' */
4392 0           idx = pln;
4393 0           *dest++ = 'p';
4394 0 0         while(isDIGIT(*src))
4395 0           *dest++ = *src++;
4396             }
4397 10 100         else if (PS_return(DBIpp_ph_qm) /* ':1' -> '?' */
4398 2 50         || PS_return(DBIpp_ph_sp) /* ':1' -> '%s' */
4399             ) {
4400 10 100         PS_return(DBIpp_ph_qm) ? sprintf(start,"?") : sprintf(start,"%%s");
4401 10           dest = start + strlen(start);
4402 10 100         if (pln != idx) {
4403             char buf[99];
4404 2           sprintf(buf, "preparse found placeholder :%d out of sequence, expected :%d", pln, idx);
4405 2           set_err_char(dbh, imp_xxh, "1", 1, buf, 0, "preparse");
4406 2           return &PL_sv_undef;
4407             }
4408 16 100         while(isDIGIT(*src)) src++;
4409 8           idx++;
4410             }
4411             }
4412 6 50         else if (isALNUM(*src)) /* :name */
4413             {
4414 6           style = ":name";
4415              
4416 6 50         if (PS_return(DBIpp_ph_cs)) {
4417             ;
4418             }
4419 6 100         else if (PS_return(DBIpp_ph_qm) /* ':name' -> '?' */
4420 2 50         || PS_return(DBIpp_ph_sp) /* ':name' -> '%s' */
4421             ) {
4422 6 100         PS_return(DBIpp_ph_qm) ? sprintf(start,"?") : sprintf(start,"%%s");
4423 6           dest = start + strlen(start);
4424 32 100         while (isALNUM(*src)) /* consume name, includes '_' */
4425 26           src++;
4426             }
4427             }
4428             /* perhaps ':=' PL/SQL construct */
4429 0           else { continue; }
4430              
4431 48           *dest = '\0'; /* handy for debugging */
4432              
4433 48 100         if (laststyle && style != laststyle) {
    100          
4434             char buf[99];
4435 2           sprintf(buf, "preparse found mixed placeholder styles (%s / %s)", style, laststyle);
4436 2           set_err_char(dbh, imp_xxh, "1", 1, buf, 0, "preparse");
4437 2           return &PL_sv_undef;
4438             }
4439 46           laststyle = style;
4440             }
4441 48           *dest = '\0';
4442              
4443             /* warn about probable parsing errors, but continue anyway (returning processed string) */
4444 48           switch (in_quote)
4445             {
4446             case '\'':
4447 2           set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated single-quoted string", 0, "preparse");
4448 2           break;
4449             case '\"':
4450 2           set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated double-quoted string", 0, "preparse");
4451 2           break;
4452             }
4453 48           switch (in_comment)
4454             {
4455             case DBIpp_L_BRACE:
4456 2           set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated bracketed {...} comment", 0, "preparse");
4457 2           break;
4458             case '/':
4459 2           set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated bracketed C-style comment", 0, "preparse");
4460 2           break;
4461             }
4462              
4463 48           SvCUR_set(new_stmt_sv, strlen(SvPVX(new_stmt_sv)));
4464 48           *SvEND(new_stmt_sv) = '\0';
4465 48           return new_stmt_sv;
4466             }
4467              
4468              
4469             /* -------------------------------------------------------------------- */
4470             /* The DBI Perl interface (via XS) starts here. Currently these are */
4471             /* all internal support functions. Note install_method and see DBI.pm */
4472              
4473             MODULE = DBI PACKAGE = DBI
4474              
4475             REQUIRE: 1.929
4476             PROTOTYPES: DISABLE
4477              
4478              
4479             BOOT:
4480             {
4481             MY_CXT_INIT;
4482             PERL_UNUSED_VAR(MY_CXT);
4483             }
4484             PERL_UNUSED_VAR(cv);
4485             PERL_UNUSED_VAR(items);
4486 292           dbi_bootinit(NULL);
4487             /* make this sub into a fake XS so it can bee seen by DBD::* modules;
4488             * never actually call it as an XS sub, or it will crash and burn! */
4489 292           (void) newXS("DBI::_dbi_state_lval", (XSUBADDR_t)_dbi_state_lval, __FILE__);
4490              
4491              
4492             I32
4493             constant()
4494             PROTOTYPE:
4495             ALIAS:
4496             SQL_ALL_TYPES = SQL_ALL_TYPES
4497             SQL_ARRAY = SQL_ARRAY
4498             SQL_ARRAY_LOCATOR = SQL_ARRAY_LOCATOR
4499             SQL_BIGINT = SQL_BIGINT
4500             SQL_BINARY = SQL_BINARY
4501             SQL_BIT = SQL_BIT
4502             SQL_BLOB = SQL_BLOB
4503             SQL_BLOB_LOCATOR = SQL_BLOB_LOCATOR
4504             SQL_BOOLEAN = SQL_BOOLEAN
4505             SQL_CHAR = SQL_CHAR
4506             SQL_CLOB = SQL_CLOB
4507             SQL_CLOB_LOCATOR = SQL_CLOB_LOCATOR
4508             SQL_DATE = SQL_DATE
4509             SQL_DATETIME = SQL_DATETIME
4510             SQL_DECIMAL = SQL_DECIMAL
4511             SQL_DOUBLE = SQL_DOUBLE
4512             SQL_FLOAT = SQL_FLOAT
4513             SQL_GUID = SQL_GUID
4514             SQL_INTEGER = SQL_INTEGER
4515             SQL_INTERVAL = SQL_INTERVAL
4516             SQL_INTERVAL_DAY = SQL_INTERVAL_DAY
4517             SQL_INTERVAL_DAY_TO_HOUR = SQL_INTERVAL_DAY_TO_HOUR
4518             SQL_INTERVAL_DAY_TO_MINUTE = SQL_INTERVAL_DAY_TO_MINUTE
4519             SQL_INTERVAL_DAY_TO_SECOND = SQL_INTERVAL_DAY_TO_SECOND
4520             SQL_INTERVAL_HOUR = SQL_INTERVAL_HOUR
4521             SQL_INTERVAL_HOUR_TO_MINUTE = SQL_INTERVAL_HOUR_TO_MINUTE
4522             SQL_INTERVAL_HOUR_TO_SECOND = SQL_INTERVAL_HOUR_TO_SECOND
4523             SQL_INTERVAL_MINUTE = SQL_INTERVAL_MINUTE
4524             SQL_INTERVAL_MINUTE_TO_SECOND = SQL_INTERVAL_MINUTE_TO_SECOND
4525             SQL_INTERVAL_MONTH = SQL_INTERVAL_MONTH
4526             SQL_INTERVAL_SECOND = SQL_INTERVAL_SECOND
4527             SQL_INTERVAL_YEAR = SQL_INTERVAL_YEAR
4528             SQL_INTERVAL_YEAR_TO_MONTH = SQL_INTERVAL_YEAR_TO_MONTH
4529             SQL_LONGVARBINARY = SQL_LONGVARBINARY
4530             SQL_LONGVARCHAR = SQL_LONGVARCHAR
4531             SQL_MULTISET = SQL_MULTISET
4532             SQL_MULTISET_LOCATOR = SQL_MULTISET_LOCATOR
4533             SQL_NUMERIC = SQL_NUMERIC
4534             SQL_REAL = SQL_REAL
4535             SQL_REF = SQL_REF
4536             SQL_ROW = SQL_ROW
4537             SQL_SMALLINT = SQL_SMALLINT
4538             SQL_TIME = SQL_TIME
4539             SQL_TIMESTAMP = SQL_TIMESTAMP
4540             SQL_TINYINT = SQL_TINYINT
4541             SQL_TYPE_DATE = SQL_TYPE_DATE
4542             SQL_TYPE_TIME = SQL_TYPE_TIME
4543             SQL_TYPE_TIMESTAMP = SQL_TYPE_TIMESTAMP
4544             SQL_TYPE_TIMESTAMP_WITH_TIMEZONE = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE
4545             SQL_TYPE_TIME_WITH_TIMEZONE = SQL_TYPE_TIME_WITH_TIMEZONE
4546             SQL_UDT = SQL_UDT
4547             SQL_UDT_LOCATOR = SQL_UDT_LOCATOR
4548             SQL_UNKNOWN_TYPE = SQL_UNKNOWN_TYPE
4549             SQL_VARBINARY = SQL_VARBINARY
4550             SQL_VARCHAR = SQL_VARCHAR
4551             SQL_WCHAR = SQL_WCHAR
4552             SQL_WLONGVARCHAR = SQL_WLONGVARCHAR
4553             SQL_WVARCHAR = SQL_WVARCHAR
4554             SQL_CURSOR_FORWARD_ONLY = SQL_CURSOR_FORWARD_ONLY
4555             SQL_CURSOR_KEYSET_DRIVEN = SQL_CURSOR_KEYSET_DRIVEN
4556             SQL_CURSOR_DYNAMIC = SQL_CURSOR_DYNAMIC
4557             SQL_CURSOR_STATIC = SQL_CURSOR_STATIC
4558             SQL_CURSOR_TYPE_DEFAULT = SQL_CURSOR_TYPE_DEFAULT
4559             DBIpp_cm_cs = DBIpp_cm_cs
4560             DBIpp_cm_hs = DBIpp_cm_hs
4561             DBIpp_cm_dd = DBIpp_cm_dd
4562             DBIpp_cm_dw = DBIpp_cm_dw
4563             DBIpp_cm_br = DBIpp_cm_br
4564             DBIpp_cm_XX = DBIpp_cm_XX
4565             DBIpp_ph_qm = DBIpp_ph_qm
4566             DBIpp_ph_cn = DBIpp_ph_cn
4567             DBIpp_ph_cs = DBIpp_ph_cs
4568             DBIpp_ph_sp = DBIpp_ph_sp
4569             DBIpp_ph_XX = DBIpp_ph_XX
4570             DBIpp_st_qq = DBIpp_st_qq
4571             DBIpp_st_bs = DBIpp_st_bs
4572             DBIpp_st_XX = DBIpp_st_XX
4573             DBIstcf_DISCARD_STRING = DBIstcf_DISCARD_STRING
4574             DBIstcf_STRICT = DBIstcf_STRICT
4575             DBIf_TRACE_SQL = DBIf_TRACE_SQL
4576             DBIf_TRACE_CON = DBIf_TRACE_CON
4577             DBIf_TRACE_ENC = DBIf_TRACE_ENC
4578             DBIf_TRACE_DBD = DBIf_TRACE_DBD
4579             DBIf_TRACE_TXN = DBIf_TRACE_TXN
4580             CODE:
4581 1298           RETVAL = ix;
4582             OUTPUT:
4583             RETVAL
4584              
4585              
4586             void
4587             _clone_dbis()
4588             CODE:
4589             dMY_CXT;
4590 0           dbistate_t * parent_dbis = DBIS;
4591              
4592             (void)cv;
4593             {
4594             MY_CXT_CLONE;
4595             }
4596 0           dbi_bootinit(parent_dbis);
4597              
4598              
4599             void
4600             _new_handle(class, parent, attr_ref, imp_datasv, imp_class)
4601             SV * class
4602             SV * parent
4603             SV * attr_ref
4604             SV * imp_datasv
4605             SV * imp_class
4606             PPCODE:
4607             dMY_CXT;
4608             HV *outer;
4609             SV *outer_ref;
4610 29563           HV *class_stash = gv_stashsv(class, GV_ADDWARN);
4611              
4612 29563 100         if (DBIS_TRACE_LEVEL >= 5) {
4613 3 50         PerlIO_printf(DBILOGFP, " New %s (for %s, parent=%s, id=%s)\n",
4614 3           neatsvpv(class,0), SvPV_nolen(imp_class), neatsvpv(parent,0), neatsvpv(imp_datasv,0));
4615             PERL_UNUSED_VAR(cv);
4616             }
4617              
4618 29563           (void)hv_store((HV*)SvRV(attr_ref), "ImplementorClass", 16, SvREFCNT_inc(imp_class), 0);
4619              
4620             /* make attr into inner handle by blessing it into class */
4621 29563           sv_bless(attr_ref, class_stash);
4622             /* tie new outer hash to inner handle */
4623 29563           outer = newHV(); /* create new hash to be outer handle */
4624 29563           outer_ref = newRV_noinc((SV*)outer);
4625             /* make outer hash into a handle by blessing it into class */
4626 29563           sv_bless(outer_ref, class_stash);
4627             /* tie outer handle to inner handle */
4628 29563           sv_magic((SV*)outer, attr_ref, PERL_MAGIC_tied, Nullch, 0);
4629              
4630 29563 100         dbih_setup_handle(aTHX_ outer_ref, SvPV_nolen(imp_class), parent, SvOK(imp_datasv) ? imp_datasv : Nullsv);
    50          
    50          
    50          
4631              
4632             /* return outer handle, plus inner handle if not in scalar context */
4633 29563           sv_2mortal(outer_ref);
4634 29563 50         EXTEND(SP, 2);
4635 29563           PUSHs(outer_ref);
4636 29563 100         if (GIMME != G_SCALAR) {
    100          
4637 28373           PUSHs(attr_ref);
4638             }
4639              
4640              
4641             void
4642             _setup_handle(sv, imp_class, parent, imp_datasv)
4643             SV * sv
4644             char * imp_class
4645             SV * parent
4646             SV * imp_datasv
4647             CODE:
4648             (void)cv;
4649 0 0         dbih_setup_handle(aTHX_ sv, imp_class, parent, SvOK(imp_datasv) ? imp_datasv : Nullsv);
    0          
    0          
4650 0           ST(0) = &PL_sv_undef;
4651              
4652              
4653             void
4654             _get_imp_data(sv)
4655             SV * sv
4656             CODE:
4657 2           D_imp_xxh(sv);
4658             (void)cv;
4659 2           ST(0) = sv_mortalcopy(DBIc_IMP_DATA(imp_xxh)); /* okay if NULL */
4660              
4661              
4662             void
4663             _handles(sv)
4664             SV * sv
4665             PPCODE:
4666             /* return the outer and inner handle for any given handle */
4667 14           D_imp_xxh(sv);
4668 14           SV *ih = sv_mortalcopy( dbih_inner(aTHX_ sv, "_handles") );
4669 14           SV *oh = sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh))); /* XXX dangerous */
4670             (void)cv;
4671 14 50         EXTEND(SP, 2);
4672 14           PUSHs(oh); /* returns outer handle then inner */
4673 14 50         if (GIMME != G_SCALAR) {
    50          
4674 14           PUSHs(ih);
4675             }
4676              
4677              
4678             void
4679             neat(sv, maxlen=0)
4680             SV * sv
4681             U32 maxlen
4682             CODE:
4683 377           ST(0) = sv_2mortal(newSVpv(neatsvpv(sv, maxlen), 0));
4684             (void)cv;
4685              
4686              
4687             I32
4688             hash(key, type=0)
4689             const char *key
4690             long type
4691             CODE:
4692             (void)cv;
4693 10           RETVAL = dbi_hash(key, type);
4694             OUTPUT:
4695             RETVAL
4696              
4697             void
4698             looks_like_number(...)
4699             PPCODE:
4700             int i;
4701 608 50         EXTEND(SP, items);
    50          
4702             (void)cv;
4703 1228 100         for(i=0; i < items ; ++i) {
4704 620           SV *sv = ST(i);
4705 620 100         if (!SvOK(sv) || (SvPOK(sv) && SvCUR(sv)==0))
    50          
    50          
    100          
    100          
4706 8           PUSHs(&PL_sv_undef);
4707 612 100         else if ( looks_like_number(sv) )
4708 363           PUSHs(&PL_sv_yes);
4709             else
4710 249           PUSHs(&PL_sv_no);
4711             }
4712              
4713              
4714             void
4715             _install_method(dbi_class, meth_name, file, attribs=Nullsv)
4716             const char * dbi_class
4717             char * meth_name
4718             char * file
4719             SV * attribs
4720             CODE:
4721             {
4722             dMY_CXT;
4723             /* install another method name/interface for the DBI dispatcher */
4724 27972 50         SV *trace_msg = (DBIS_TRACE_LEVEL >= 10) ? sv_2mortal(newSVpv("",0)) : Nullsv;
4725             CV *cv;
4726             SV **svp;
4727             dbi_ima_t *ima;
4728             MAGIC *mg;
4729             (void)dbi_class;
4730              
4731 27972 50         if (strnNE(meth_name, "DBI::", 5)) /* XXX m/^DBI::\w+::\w+$/ */
4732 0           croak("install_method %s: invalid class", meth_name);
4733              
4734 27972 50         if (trace_msg)
4735 0           sv_catpvf(trace_msg, "install_method %-21s", meth_name);
4736              
4737 27972           Newxz(ima, 1, dbi_ima_t);
4738              
4739 27972 50         if (attribs && SvOK(attribs)) {
    100          
    50          
    50          
4740             /* convert and store method attributes in a fast access form */
4741 26220 50         if (SvTYPE(SvRV(attribs)) != SVt_PVHV)
4742 0           croak("install_method %s: bad attribs", meth_name);
4743              
4744 26220 50         DBD_ATTRIB_GET_IV(attribs, "O",1, svp, ima->flags);
    50          
    50          
    100          
    50          
4745 26220 50         DBD_ATTRIB_GET_UV(attribs, "T",1, svp, ima->method_trace);
    50          
    50          
    100          
    50          
4746 26220 50         DBD_ATTRIB_GET_IV(attribs, "H",1, svp, ima->hidearg);
    50          
    50          
    100          
    50          
4747              
4748 26220 50         if (trace_msg) {
4749 0 0         if (ima->flags) sv_catpvf(trace_msg, ", flags 0x%04x", (unsigned)ima->flags);
4750 0 0         if (ima->method_trace)sv_catpvf(trace_msg, ", T 0x%08lx", (unsigned long)ima->method_trace);
4751 0 0         if (ima->hidearg) sv_catpvf(trace_msg, ", H %u", (unsigned)ima->hidearg);
4752             }
4753 26220 50         if ( (svp=DBD_ATTRIB_GET_SVP(attribs, "U",1)) != NULL) {
    50          
    50          
    100          
4754 18688           AV *av = (AV*)SvRV(*svp);
4755 18688 50         ima->minargs = (U8)SvIV(*av_fetch(av, 0, 1));
4756 18688 50         ima->maxargs = (U8)SvIV(*av_fetch(av, 1, 1));
4757 18688           svp = av_fetch(av, 2, 0);
4758 18688 100         ima->usage_msg = (svp) ? savepv_using_sv(SvPV_nolen(*svp)) : "";
    50          
4759 18688           ima->flags |= IMA_HAS_USAGE;
4760 18688 50         if (trace_msg && DBIS_TRACE_LEVEL >= 11)
    0          
4761 0           sv_catpvf(trace_msg, ",\n usage: min %d, max %d, '%s'",
4762 0           ima->minargs, ima->maxargs, ima->usage_msg);
4763             }
4764             }
4765 27972 50         if (trace_msg)
4766 0 0         PerlIO_printf(DBILOGFP,"%s\n", SvPV_nolen(trace_msg));
4767 27972           file = savepv(file);
4768 27972           cv = newXS(meth_name, XS_DBI_dispatch, file);
4769 27972           SvPVX((SV *)cv) = file;
4770 27972           SvLEN((SV *)cv) = 1;
4771 27972           CvXSUBANY(cv).any_ptr = ima;
4772 27972           ima->meth_type = get_meth_type(GvNAME(CvGV(cv)));
4773              
4774             /* Attach magic to handle duping and freeing of the dbi_ima_t struct.
4775             * Due to the poor interface of the mg dup function, sneak a pointer
4776             * to the original CV in the mg_ptr field (we get called with a
4777             * pointer to the mg, but not the SV) */
4778 27972           mg = sv_magicext((SV*)cv, NULL, DBI_MAGIC, &dbi_ima_vtbl,
4779             (char *)cv, 0);
4780             #ifdef BROKEN_DUP_ANY_PTR
4781             ima->my_perl = my_perl; /* who owns this struct */
4782             #else
4783 27972           mg->mg_flags |= MGf_DUP;
4784             #endif
4785 27972           ST(0) = &PL_sv_yes;
4786             }
4787              
4788              
4789             int
4790             trace(class, level_sv=&PL_sv_undef, file=Nullsv)
4791             SV * class
4792             SV * level_sv
4793             SV * file
4794             ALIAS:
4795             _debug_dispatch = 1
4796             CODE:
4797             {
4798             dMY_CXT;
4799             IV level;
4800 24 50         if (!DBIS) {
4801             PERL_UNUSED_VAR(ix);
4802 0           croak("DBI not initialised");
4803             }
4804             /* Return old/current value. No change if new value not given. */
4805 24 50         RETVAL = (DBIS) ? DBIS->debug : 0;
4806 24           level = parse_trace_flags(class, level_sv, RETVAL);
4807 24 100         if (level) /* call before or after altering DBI trace level */
4808 6           set_trace_file(file);
4809 24 100         if (level != RETVAL) {
4810 12 100         if ((level & DBIc_TRACE_LEVEL_MASK) > 0) {
4811 12           PerlIO_printf(DBILOGFP," DBI %s%s default trace level set to 0x%lx/%ld (pid %d pi %p) at %s\n",
4812             XS_VERSION, dbi_build_opt,
4813             (long)(level & DBIc_TRACE_FLAGS_MASK),
4814             (long)(level & DBIc_TRACE_LEVEL_MASK),
4815 6           (int)PerlProc_getpid(),
4816             #ifdef MULTIPLICITY
4817             (void *)my_perl,
4818             #else
4819             (void*)NULL,
4820             #endif
4821             log_where(Nullsv, 0, "", "", 1, 1, 0)
4822             );
4823 6 50         if (!PL_dowarn)
4824 0           PerlIO_printf(DBILOGFP," Note: perl is running without the recommended perl -w option\n");
4825 6           PerlIO_flush(DBILOGFP);
4826             }
4827 12           DBIS->debug = level;
4828 12           sv_setiv(get_sv("DBI::dbi_debug",0x5), level);
4829             }
4830 24 100         if (!level) /* call before or after altering DBI trace level */
4831 18           set_trace_file(file);
4832             }
4833             OUTPUT:
4834             RETVAL
4835              
4836              
4837              
4838             void
4839             dump_handle(sv, msg="DBI::dump_handle", level=0)
4840             SV * sv
4841             const char *msg
4842             int level
4843             CODE:
4844             (void)cv;
4845 4           dbih_dumphandle(aTHX_ sv, msg, level);
4846              
4847              
4848              
4849             void
4850             _svdump(sv)
4851             SV * sv
4852             CODE:
4853             {
4854             dMY_CXT;
4855             (void)cv;
4856 0           PerlIO_printf(DBILOGFP, "DBI::_svdump(%s)", neatsvpv(sv,0));
4857             #ifdef DEBUGGING
4858             sv_dump(sv);
4859             #endif
4860             }
4861              
4862              
4863             NV
4864             dbi_time()
4865              
4866              
4867             void
4868             dbi_profile(h, statement, method, t1, t2)
4869             SV *h
4870             SV *statement
4871             SV *method
4872             NV t1
4873             NV t2
4874             CODE:
4875 6           SV *leaf = &PL_sv_undef;
4876             PERL_UNUSED_VAR(cv);
4877 6 50         if (SvROK(method))
4878 0           method = SvRV(method);
4879 6 100         if (dbih_inner(aTHX_ h, NULL)) { /* is a DBI handle */
4880 4           D_imp_xxh(h);
4881 4           leaf = dbi_profile(h, imp_xxh, statement, method, t1, t2);
4882             }
4883 4 50         else if (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV) {
    50          
4884             /* iterate over values %$h */
4885 2           HV *hv = (HV*)SvRV(h);
4886             SV *tmp;
4887             char *key;
4888 2           I32 keylen = 0;
4889 2           hv_iterinit(hv);
4890 6 100         while ( (tmp = hv_iternextsv(hv, &key, &keylen)) != NULL ) {
4891 4 100         if (SvOK(tmp)) {
    50          
    50          
4892 2           D_imp_xxh(tmp);
4893 2           leaf = dbi_profile(tmp, imp_xxh, statement, method, t1, t2);
4894             }
4895             };
4896             }
4897             else {
4898 0           croak("dbi_profile(%s,...) invalid handle argument", neatsvpv(h,0));
4899             }
4900 6 50         if (GIMME_V == G_VOID)
    100          
4901 4           ST(0) = &PL_sv_undef; /* skip sv_mortalcopy if not needed */
4902             else
4903 2           ST(0) = sv_mortalcopy(leaf);
4904              
4905              
4906              
4907             SV *
4908             dbi_profile_merge_nodes(dest, ...)
4909             SV * dest
4910             ALIAS:
4911             dbi_profile_merge = 1
4912             CODE:
4913             {
4914 254 50         if (!SvROK(dest) || SvTYPE(SvRV(dest)) != SVt_PVAV)
    50          
4915 0           croak("dbi_profile_merge_nodes(%s,...) destination is not an array reference", neatsvpv(dest,0));
4916 254 50         if (items <= 1) {
4917             PERL_UNUSED_VAR(cv);
4918             PERL_UNUSED_VAR(ix);
4919 0           RETVAL = 0;
4920             }
4921             else {
4922             /* items==2 for dest + 1 arg, ST(0) is dest, ST(1) is first arg */
4923 622 100         while (--items >= 1) {
4924 368           SV *thingy = ST(items);
4925 368           dbi_profile_merge_nodes(dest, thingy);
4926             }
4927 254           RETVAL = newSVsv(*av_fetch((AV*)SvRV(dest), DBIprof_TOTAL_TIME, 1));
4928             }
4929             }
4930             OUTPUT:
4931             RETVAL
4932              
4933              
4934             SV *
4935             _concat_hash_sorted(hash_sv, kv_sep_sv, pair_sep_sv, use_neat_sv, num_sort_sv)
4936             SV *hash_sv
4937             SV *kv_sep_sv
4938             SV *pair_sep_sv
4939             SV *use_neat_sv
4940             SV *num_sort_sv
4941             PREINIT:
4942             char *kv_sep, *pair_sep;
4943             STRLEN kv_sep_len, pair_sep_len;
4944             CODE:
4945 3330 100         if (!SvOK(hash_sv))
    50          
    50          
4946 19           XSRETURN_UNDEF;
4947 3311 50         if (!SvROK(hash_sv) || SvTYPE(SvRV(hash_sv))!=SVt_PVHV)
    100          
4948 2           croak("hash is not a hash reference");
4949              
4950 3309 100         kv_sep = SvPV(kv_sep_sv, kv_sep_len);
4951 3309 100         pair_sep = SvPV(pair_sep_sv, pair_sep_len);
4952              
4953 3357 100         RETVAL = _join_hash_sorted( (HV*)SvRV(hash_sv),
    50          
    100          
    50          
4954             kv_sep, kv_sep_len,
4955             pair_sep, pair_sep_len,
4956             /* use_neat should be undef, 0 or 1, may allow sprintf format strings later */
4957 6 50         (SvOK(use_neat_sv)) ? SvIV(use_neat_sv) : 0,
    50          
4958 42 50         (SvOK(num_sort_sv)) ? SvIV(num_sort_sv) : -1
    50          
4959             );
4960             OUTPUT:
4961             RETVAL
4962              
4963              
4964             int
4965             sql_type_cast(sv, sql_type, flags=0)
4966             SV * sv
4967             int sql_type
4968             U32 flags
4969             CODE:
4970 40           RETVAL = sql_type_cast_svpv(aTHX_ sv, sql_type, flags, 0);
4971             OUTPUT:
4972             RETVAL
4973              
4974              
4975              
4976             MODULE = DBI PACKAGE = DBI::var
4977              
4978             void
4979             FETCH(sv)
4980             SV * sv
4981             CODE:
4982             dMY_CXT;
4983             /* Note that we do not come through the dispatcher to get here. */
4984 19497 50         char *meth = SvPV_nolen(SvRV(sv)); /* what should this tie do ? */
4985 19497           char type = *meth++; /* is this a $ or & style */
4986 19497 50         imp_xxh_t *imp_xxh = (DBI_LAST_HANDLE_OK) ? DBIh_COM(DBI_LAST_HANDLE) : NULL;
4987 19497 50         int trace_level = (imp_xxh ? DBIc_TRACE_LEVEL(imp_xxh) : DBIS_TRACE_LEVEL);
4988 19497           NV profile_t1 = 0.0;
4989              
4990 19497 50         if (imp_xxh && DBIc_has(imp_xxh,DBIcf_Profile))
    100          
4991 12           profile_t1 = dbi_time();
4992              
4993 19497 100         if (trace_level >= 2) {
4994 12 50         PerlIO_printf(DBILOGFP," -> $DBI::%s (%c) FETCH from lasth=%s\n", meth, type,
4995 12           (imp_xxh) ? neatsvpv(DBI_LAST_HANDLE,0): "none");
4996             }
4997              
4998 19497 50         if (type == '!') { /* special case for $DBI::lasth */
4999             /* Currently we can only return the INNER handle. */
5000             /* This handle should only be used for true/false tests */
5001 0 0         ST(0) = (imp_xxh) ? sv_2mortal(newRV_inc(DBI_LAST_HANDLE)) : &PL_sv_undef;
5002             }
5003 19497 50         else if ( !imp_xxh ) {
5004 0 0         if (trace_level)
5005 0           warn("Can't read $DBI::%s, last handle unknown or destroyed", meth);
5006 0           ST(0) = &PL_sv_undef;
5007             }
5008 19497 100         else if (type == '*') { /* special case for $DBI::err, see also err method */
5009 6647           SV *errsv = DBIc_ERR(imp_xxh);
5010 6647           ST(0) = sv_mortalcopy(errsv);
5011             }
5012 12850 100         else if (type == '"') { /* special case for $DBI::state */
5013 6220           SV *state = DBIc_STATE(imp_xxh);
5014 6220 100         ST(0) = DBIc_STATE_adjust(imp_xxh, state);
    50          
    50          
    50          
    100          
    50          
    50          
    0          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
5015             }
5016 6630 50         else if (type == '$') { /* lookup scalar variable in implementors stash */
5017 0           const char *vname = mkvname(aTHX_ DBIc_IMP_STASH(imp_xxh), meth, 0);
5018 0           SV *vsv = get_sv(vname, 1);
5019 0           ST(0) = sv_mortalcopy(vsv);
5020             }
5021             else {
5022             /* default to method call via stash of implementor of DBI_LAST_HANDLE */
5023             GV *imp_gv;
5024 6630           HV *imp_stash = DBIc_IMP_STASH(imp_xxh);
5025             #ifdef DBI_save_hv_fetch_ent
5026             HE save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */
5027             #endif
5028 6630           profile_t1 = 0.0; /* profile this via dispatch only (else we'll double count) */
5029 6630 100         if (trace_level >= 3)
5030 4 50         PerlIO_printf(DBILOGFP," >> %s::%s\n", HvNAME(imp_stash), meth);
    50          
    50          
    0          
    50          
    50          
5031 6630           ST(0) = sv_2mortal(newRV_inc(DBI_LAST_HANDLE));
5032 6630 50         if ((imp_gv = gv_fetchmethod(imp_stash,meth)) == NULL) {
5033 0 0         croak("Can't locate $DBI::%s object method \"%s\" via package \"%s\"",
    0          
5034 0 0         meth, meth, HvNAME(imp_stash));
    0          
    0          
    0          
5035             }
5036 6630 50         PUSHMARK(mark); /* reset mark (implies one arg as we were called with one arg?) */
5037 6630 50         call_sv((SV*)GvCV(imp_gv), GIMME);
    50          
5038 6630           SPAGAIN;
5039             #ifdef DBI_save_hv_fetch_ent
5040             PL_hv_fetch_ent_mh = save_mh;
5041             #endif
5042             }
5043 19497 100         if (trace_level)
5044 15           PerlIO_printf(DBILOGFP," <- $DBI::%s= %s\n", meth, neatsvpv(ST(0),0));
5045 19497 100         if (profile_t1) {
5046 8           SV *h = sv_2mortal(newRV_inc(DBI_LAST_HANDLE));
5047 8           dbi_profile(h, imp_xxh, &PL_sv_undef, (SV*)cv, profile_t1, dbi_time());
5048             }
5049              
5050              
5051             MODULE = DBI PACKAGE = DBD::_::dr
5052              
5053             void
5054             dbixs_revision(h)
5055             SV * h
5056             CODE:
5057             PERL_UNUSED_VAR(h);
5058 4           ST(0) = sv_2mortal(newSViv(DBIXS_REVISION));
5059              
5060              
5061             MODULE = DBI PACKAGE = DBD::_::db
5062              
5063             void
5064             connected(...)
5065             CODE:
5066             /* defined here just to avoid AUTOLOAD */
5067             (void)cv;
5068             (void)items;
5069 5938           ST(0) = &PL_sv_undef;
5070              
5071              
5072             SV *
5073             preparse(dbh, statement, ps_accept, ps_return, foo=Nullch)
5074             SV * dbh
5075             char * statement
5076             IV ps_accept
5077             IV ps_return
5078             void *foo
5079              
5080              
5081             void
5082             take_imp_data(h)
5083             SV * h
5084             PREINIT:
5085             /* take_imp_data currently in DBD::_::db not DBD::_::common, so for dbh's only */
5086 1           D_imp_xxh(h);
5087             MAGIC *mg;
5088             SV *imp_xxh_sv;
5089             SV **tmp_svp;
5090             CODE:
5091             PERL_UNUSED_VAR(cv);
5092             /*
5093             * Remove and return the imp_xxh_t structure that's attached to the inner
5094             * hash of the handle. Effectively this removes the 'brain' of the handle
5095             * leaving it as an empty shell - brain dead. All method calls on it fail.
5096             *
5097             * The imp_xxh_t structure that's removed and returned is a plain scalar
5098             * (containing binary data). It can be passed to a new DBI->connect call
5099             * in order to have the new $dbh use the same 'connection' as the original
5100             * handle. In this way a multi-threaded connection pool can be implemented.
5101             *
5102             * If the drivers imp_xxh_t structure contains SV*'s, or other interpreter
5103             * specific items, they should be freed by the drivers own take_imp_data()
5104             * method before it then calls SUPER::take_imp_data() to finalize removal
5105             * of the imp_xxh_t structure.
5106             *
5107             * The driver needs to view the take_imp_data method as being nearly the
5108             * same as disconnect+DESTROY only not actually calling the database API to
5109             * disconnect. All that needs to remain valid in the imp_xxh_t structure
5110             * is the underlying database API connection data. Everything else should
5111             * in a 'clean' state such that if the drivers own DESTROY method was
5112             * called it would be able to properly handle the contents of the
5113             * structure. This is important in case a new handle created using this
5114             * imp_data, possibly in a new thread, might end up being DESTROY'd before
5115             * the driver has had a chance to 're-setup' the data. See dbih_setup_handle()
5116             *
5117             * All the above relates to the 'typical use case' for a compiled driver.
5118             * For a pure-perl driver using a socket pair, for example, the drivers
5119             * take_imp_data method might just return a string containing the fileno()
5120             * values of the sockets (without calling this SUPER::take_imp_data() code).
5121             * The key point is that the take_imp_data() method returns an opaque buffer
5122             * containing whatever the driver would need to reuse the same underlying
5123             * 'connection to the database' in a new handle.
5124             *
5125             * In all cases, care should be taken that driver attributes (such as
5126             * AutoCommit) match the state of the underlying connection.
5127             */
5128              
5129 1 50         if (!DBIc_ACTIVE(imp_xxh)) {/* sanity check, may be relaxed later */
5130 0           set_err_char(h, imp_xxh, "1", 1, "Can't take_imp_data from handle that's not Active", 0, "take_imp_data");
5131 0           XSRETURN(0);
5132             }
5133              
5134             /* Ideally there should be no child statement handles existing when
5135             * take_imp_data is called because when those statement handles are
5136             * destroyed they may need to interact with the 'zombie' parent dbh.
5137             * So we do our best to neautralize them (finish & rebless)
5138             */
5139 1 50         if ((tmp_svp = hv_fetch((HV*)SvRV(h), "ChildHandles", 12, FALSE)) && SvROK(*tmp_svp)) {
    50          
5140 1           AV *av = (AV*)SvRV(*tmp_svp);
5141 1           HV *zombie_stash = gv_stashpv("DBI::zombie", GV_ADDWARN);
5142             I32 kidslots;
5143 4 50         for (kidslots = AvFILL(av); kidslots >= 0; --kidslots) {
    100          
5144 3           SV **hp = av_fetch(av, kidslots, FALSE);
5145 3 50         if (hp && SvROK(*hp) && SvMAGICAL(SvRV(*hp))) {
    100          
    50          
5146 2 50         PUSHMARK(sp);
5147 2 50         XPUSHs(*hp);
5148 2           PUTBACK;
5149 2           call_method("finish", G_VOID);
5150 2           SPAGAIN;
5151 2           PUTBACK;
5152 2           sv_unmagic(SvRV(*hp), 'P'); /* untie */
5153 2           sv_bless(*hp, zombie_stash); /* neutralise */
5154             }
5155             }
5156             }
5157             /* The above measures may not be sufficient if weakrefs aren't available
5158             * or something has a reference to the inner-handle of an sth.
5159             * We'll require no Active kids, but just warn about others.
5160             */
5161 1 50         if (DBIc_ACTIVE_KIDS(imp_xxh)) {
5162 0           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");
5163 0           XSRETURN(0);
5164             }
5165 1 50         if (DBIc_KIDS(imp_xxh))
5166 0           warn("take_imp_data from handle while it still has kids");
5167              
5168             /* it may be better here to return a copy and poison the original
5169             * rather than detatching and returning the original
5170             */
5171              
5172             /* --- perform the surgery */
5173 1           dbih_getcom2(aTHX_ h, &mg); /* get the MAGIC so we can change it */
5174 1           imp_xxh_sv = mg->mg_obj; /* take local copy of the imp_data pointer */
5175 1           mg->mg_obj = Nullsv; /* sever the link from handle to imp_xxh */
5176 1           mg->mg_ptr = NULL; /* and sever the shortcut too */
5177 1 50         if (DBIc_TRACE_LEVEL(imp_xxh) >= 9)
5178 0           sv_dump(imp_xxh_sv);
5179             /* --- housekeeping */
5180 1 50         DBIc_ACTIVE_off(imp_xxh); /* silence warning from dbih_clearcom */
    50          
    50          
    50          
    50          
5181 1           DBIc_IMPSET_off(imp_xxh); /* silence warning from dbih_clearcom */
5182 1           dbih_clearcom(imp_xxh); /* free SVs like DBD::_mem::common::DESTROY */
5183 1           SvOBJECT_off(imp_xxh_sv); /* no longer needs DESTROY via dbih_clearcom */
5184             /* restore flags to mark fact imp data holds active connection */
5185             /* (don't use magical DBIc_ACTIVE_on here) */
5186 1           DBIc_FLAGS(imp_xxh) |= DBIcf_IMPSET | DBIcf_ACTIVE;
5187             /* --- tidy up the raw PV for life as a more normal string */
5188 1           SvPOK_on(imp_xxh_sv); /* SvCUR & SvEND were set at creation */
5189             /* --- return the actual imp_xxh_sv on the stack */
5190 1           ST(0) = imp_xxh_sv;
5191              
5192              
5193              
5194             MODULE = DBI PACKAGE = DBD::_::st
5195              
5196             void
5197             _get_fbav(sth)
5198             SV * sth
5199             CODE:
5200 6           D_imp_sth(sth);
5201 6           AV *av = dbih_get_fbav(imp_sth);
5202             (void)cv;
5203 6           ST(0) = sv_2mortal(newRV_inc((SV*)av));
5204              
5205             void
5206             _set_fbav(sth, src_rv)
5207             SV * sth
5208             SV * src_rv
5209             CODE:
5210 103856           D_imp_sth(sth);
5211             int i;
5212             AV *src_av;
5213 103856           AV *dst_av = dbih_get_fbav(imp_sth);
5214 103856 50         int dst_fields = AvFILL(dst_av)+1;
5215             int src_fields;
5216             (void)cv;
5217              
5218 103856 50         if (!SvROK(src_rv) || SvTYPE(SvRV(src_rv)) != SVt_PVAV)
    50          
5219 0           croak("_set_fbav(%s): not an array ref", neatsvpv(src_rv,0));
5220 103856           src_av = (AV*)SvRV(src_rv);
5221 103856 50         src_fields = AvFILL(src_av)+1;
5222 103856 50         if (src_fields != dst_fields) {
5223 0           warn("_set_fbav(%s): array has %d elements, the statement handle row buffer has %d (and NUM_OF_FIELDS is %d)",
5224             neatsvpv(src_rv,0), src_fields, dst_fields, DBIc_NUM_FIELDS(imp_sth));
5225 0           SvREADONLY_off(dst_av);
5226 0 0         if (src_fields < dst_fields) {
5227             /* shrink the array - sadly this looses column bindings for the lost columns */
5228 0           av_fill(dst_av, src_fields-1);
5229 0           dst_fields = src_fields;
5230             }
5231             else {
5232 0           av_fill(dst_av, src_fields-1);
5233             /* av_fill pads with immutable undefs which we need to change */
5234 0 0         for(i=dst_fields-1; i < src_fields; ++i) {
5235 0           sv_setsv(AvARRAY(dst_av)[i], newSV(0));
5236             }
5237             }
5238 0           SvREADONLY_on(dst_av);
5239             }
5240 412489 100         for(i=0; i < dst_fields; ++i) { /* copy over the row */
5241             /* If we're given the values, then taint them if required */
5242 308633 100         if (DBIc_is(imp_sth, DBIcf_TaintOut))
5243 3 50         SvTAINT(AvARRAY(src_av)[i]);
    50          
5244 308633           sv_setsv(AvARRAY(dst_av)[i], AvARRAY(src_av)[i]);
5245             }
5246 103856           ST(0) = sv_2mortal(newRV_inc((SV*)dst_av));
5247              
5248              
5249             void
5250             bind_col(sth, col, ref, attribs=Nullsv)
5251             SV * sth
5252             SV * col
5253             SV * ref
5254             SV * attribs
5255             CODE:
5256 162 100         DBD_ATTRIBS_CHECK("bind_col", sth, attribs);
    100          
    50          
    50          
    50          
    50          
    0          
    0          
5257 162 50         ST(0) = boolSV(dbih_sth_bind_col(sth, col, ref, attribs));
5258             (void)cv;
5259              
5260              
5261             void
5262             fetchrow_array(sth)
5263             SV * sth
5264             ALIAS:
5265             fetchrow = 1
5266             PPCODE:
5267             SV *retsv;
5268 7 50         if (CvDEPTH(cv) == 99) {
5269             PERL_UNUSED_VAR(ix);
5270 0           croak("Deep recursion, probably fetchrow-fetch-fetchrow loop");
5271             }
5272 7 50         PUSHMARK(sp);
5273 7 50         XPUSHs(sth);
5274 7           PUTBACK;
5275 7 50         if (call_method("fetch", G_SCALAR) != 1)
5276 0           croak("panic: DBI fetch"); /* should never happen */
5277 7           SPAGAIN;
5278 7           retsv = POPs;
5279 7           PUTBACK;
5280 7 50         if (SvROK(retsv) && SvTYPE(SvRV(retsv)) == SVt_PVAV) {
    50          
5281 7           D_imp_sth(sth);
5282             int num_fields, i;
5283             AV *bound_av;
5284 7           AV *av = (AV*)SvRV(retsv);
5285 7 50         num_fields = AvFILL(av)+1;
5286 7 50         EXTEND(sp, num_fields+1);
    50          
5287              
5288             /* We now check for bind_col() having been called but fetch */
5289             /* not returning the fields_svav array. Probably because the */
5290             /* driver is implemented in perl. XXX This logic may change later. */
5291 7           bound_av = DBIc_FIELDS_AV(imp_sth); /* bind_col() called ? */
5292 7 50         if (bound_av && av != bound_av) {
    50          
5293             /* let dbih_get_fbav know what's going on */
5294 0           bound_av = dbih_get_fbav(imp_sth);
5295 0 0         if (DBIc_TRACE_LEVEL(imp_sth) >= 3) {
5296 0           PerlIO_printf(DBIc_LOGPIO(imp_sth),
5297             "fetchrow: updating fbav 0x%lx from 0x%lx\n",
5298             (long)bound_av, (long)av);
5299             }
5300 0 0         for(i=0; i < num_fields; ++i) { /* copy over the row */
5301 0           sv_setsv(AvARRAY(bound_av)[i], AvARRAY(av)[i]);
5302             }
5303             }
5304 28 100         for(i=0; i < num_fields; ++i) {
5305 21           PUSHs(AvARRAY(av)[i]);
5306             }
5307             }
5308              
5309              
5310             SV *
5311             fetchrow_hashref(sth, keyattrib=Nullch)
5312             SV * sth
5313             const char *keyattrib
5314             PREINIT:
5315             SV *rowavr;
5316             SV *ka_rv;
5317 8855           D_imp_sth(sth);
5318             CODE:
5319             (void)cv;
5320 8855 50         PUSHMARK(sp);
5321 8855 50         XPUSHs(sth);
5322 8855           PUTBACK;
5323 8855 100         if (!keyattrib || !*keyattrib) {
    50          
5324 8851           SV *kn = DBIc_FetchHashKeyName(imp_sth);
5325 8851 50         if (kn && SvOK(kn))
    50          
    0          
    0          
5326 8851           keyattrib = SvPVX(kn);
5327             else
5328 0           keyattrib = "NAME";
5329             }
5330 8855           ka_rv = *hv_fetch((HV*)DBIc_MY_H(imp_sth), keyattrib,strlen(keyattrib), TRUE);
5331             /* we copy to invoke FETCH magic, and we do that before fetch() so if tainting */
5332             /* then the taint triggered by the fetch won't then apply to the fetched name */
5333 8855           ka_rv = newSVsv(ka_rv);
5334 8855 50         if (call_method("fetch", G_SCALAR) != 1)
5335 0           croak("panic: DBI fetch"); /* should never happen */
5336 8855           SPAGAIN;
5337 8855           rowavr = POPs;
5338 8855           PUTBACK;
5339             /* have we got an array ref in rowavr */
5340 17604 100         if (SvROK(rowavr) && SvTYPE(SvRV(rowavr)) == SVt_PVAV) {
    50          
5341             int i;
5342 8751           AV *rowav = (AV*)SvRV(rowavr);
5343 8751 50         const int num_fields = AvFILL(rowav)+1;
5344             HV *hv;
5345             AV *ka_av;
5346 8751 50         if (!(SvROK(ka_rv) && SvTYPE(SvRV(ka_rv))==SVt_PVAV)) {
    100          
5347 2           sv_setiv(DBIc_ERR(imp_sth), 1);
5348 2           sv_setpvf(DBIc_ERRSTR(imp_sth),
5349             "Can't use attribute '%s' because it doesn't contain a reference to an array (%s)",
5350             keyattrib, neatsvpv(ka_rv,0));
5351 2           XSRETURN_UNDEF;
5352             }
5353 8749           ka_av = (AV*)SvRV(ka_rv);
5354 8749           hv = newHV();
5355 34968 100         for (i=0; i < num_fields; ++i) { /* honor the original order as sent by the database */
5356 26219           SV **field_name_svp = av_fetch(ka_av, i, 1);
5357 26219           (void)hv_store_ent(hv, *field_name_svp, newSVsv((SV*)(AvARRAY(rowav)[i])), 0);
5358             }
5359 8749           RETVAL = newRV_inc((SV*)hv);
5360 8749           SvREFCNT_dec(hv); /* since newRV incremented it */
5361             }
5362             else {
5363 104           RETVAL = &PL_sv_undef;
5364             #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 4))
5365             RETVAL = newSV(0); /* mutable undef for 5.004_04 */
5366             #endif
5367             }
5368 8853           SvREFCNT_dec(ka_rv); /* since we created it */
5369             OUTPUT:
5370             RETVAL
5371              
5372              
5373             void
5374             fetch(sth)
5375             SV * sth
5376             ALIAS:
5377             fetchrow_arrayref = 1
5378             CODE:
5379             int num_fields;
5380 0 0         if (CvDEPTH(cv) == 99) {
5381             PERL_UNUSED_VAR(ix);
5382 0           croak("Deep recursion. Probably fetch-fetchrow-fetch loop.");
5383             }
5384 0 0         PUSHMARK(sp);
5385 0 0         XPUSHs(sth);
5386 0           PUTBACK;
5387 0           num_fields = call_method("fetchrow", G_ARRAY); /* XXX change the name later */
5388 0           SPAGAIN;
5389 0 0         if (num_fields == 0) {
5390 0           ST(0) = &PL_sv_undef;
5391             } else {
5392 0           D_imp_sth(sth);
5393 0           AV *av = dbih_get_fbav(imp_sth);
5394 0 0         if (num_fields != AvFILL(av)+1)
    0          
5395 0 0         croak("fetchrow returned %d fields, expected %d",
5396 0           num_fields, (int)AvFILL(av)+1);
5397 0           SPAGAIN;
5398 0 0         while(--num_fields >= 0)
5399 0           sv_setsv(AvARRAY(av)[num_fields], POPs);
5400 0           PUTBACK;
5401 0           ST(0) = sv_2mortal(newRV_inc((SV*)av));
5402             }
5403              
5404              
5405             void
5406             rows(sth)
5407             SV * sth
5408             CODE:
5409 5           D_imp_sth(sth);
5410 5           const IV rows = DBIc_ROW_COUNT(imp_sth);
5411 5           ST(0) = sv_2mortal(newSViv(rows));
5412             (void)cv;
5413              
5414              
5415             void
5416             finish(sth)
5417             SV * sth
5418             CODE:
5419 14391           D_imp_sth(sth);
5420 14391 100         DBIc_ACTIVE_off(imp_sth);
    50          
    50          
    50          
    50          
5421 14391           ST(0) = &PL_sv_yes;
5422             (void)cv;
5423              
5424              
5425             void
5426             DESTROY(sth)
5427             SV * sth
5428             PPCODE:
5429             /* keep in sync with DESTROY in Driver.xst */
5430 25318           D_imp_sth(sth);
5431 25318           ST(0) = &PL_sv_yes;
5432             /* we don't test IMPSET here because this code applies to pure-perl drivers */
5433 25318 50         if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */
5434 0 0         DBIc_ACTIVE_off(imp_sth);
    0          
    0          
    0          
    0          
5435 0 0         if (DBIc_TRACE_LEVEL(imp_sth))
5436 0 0         PerlIO_printf(DBIc_LOGPIO(imp_sth), " DESTROY %s skipped due to InactiveDestroy\n", SvPV_nolen(sth));
5437             }
5438 25318 100         if (DBIc_ACTIVE(imp_sth)) {
5439 5           D_imp_dbh_from_sth;
5440 10 50         if (!PL_dirty && DBIc_ACTIVE(imp_dbh)) {
    50          
5441 5           dSP;
5442 5 50         PUSHMARK(sp);
5443 5 50         XPUSHs(sth);
5444 5           PUTBACK;
5445 5           call_method("finish", G_SCALAR);
5446 5           SPAGAIN;
5447 5           PUTBACK;
5448             }
5449             else {
5450 0 0         DBIc_ACTIVE_off(imp_sth);
    0          
    0          
    0          
    0          
5451             }
5452             }
5453              
5454              
5455             MODULE = DBI PACKAGE = DBI::st
5456              
5457             void
5458             TIEHASH(class, inner_ref)
5459             SV * class
5460             SV * inner_ref
5461             CODE:
5462 0           HV *stash = gv_stashsv(class, GV_ADDWARN); /* a new hash is supplied to us, we just need to bless and apply tie magic */
5463 0           sv_bless(inner_ref, stash);
5464 0           ST(0) = inner_ref;
5465              
5466             MODULE = DBI PACKAGE = DBD::_::common
5467              
5468              
5469             void
5470             DESTROY(h)
5471             SV * h
5472             CODE:
5473             /* DESTROY defined here just to avoid AUTOLOAD */
5474             (void)cv;
5475             (void)h;
5476 543           ST(0) = &PL_sv_undef;
5477              
5478              
5479             void
5480             STORE(h, keysv, valuesv)
5481             SV * h
5482             SV * keysv
5483             SV * valuesv
5484             CODE:
5485 79050           ST(0) = &PL_sv_yes;
5486 79050 100         if (!dbih_set_attr_k(h, keysv, 0, valuesv))
5487 46           ST(0) = &PL_sv_no;
5488             (void)cv;
5489              
5490              
5491             void
5492             FETCH(h, keysv)
5493             SV * h
5494             SV * keysv
5495             CODE:
5496 44688           ST(0) = dbih_get_attr_k(h, keysv, 0);
5497             (void)cv;
5498              
5499             void
5500             DELETE(h, keysv)
5501             SV * h
5502             SV * keysv
5503             CODE:
5504             /* only private_* keys can be deleted, for others DELETE acts like FETCH */
5505             /* because the DBI internals rely on certain handle attributes existing */
5506 5 50         if (strnEQ(SvPV_nolen(keysv),"private_",8))
    100          
5507 2           ST(0) = hv_delete_ent((HV*)SvRV(h), keysv, 0, 0);
5508             else
5509 3           ST(0) = dbih_get_attr_k(h, keysv, 0);
5510             (void)cv;
5511              
5512              
5513             void
5514             private_data(h)
5515             SV * h
5516             CODE:
5517 0           D_imp_xxh(h);
5518             (void)cv;
5519 0           ST(0) = sv_mortalcopy(DBIc_IMP_DATA(imp_xxh));
5520              
5521              
5522             void
5523             err(h)
5524             SV * h
5525             CODE:
5526 55           D_imp_xxh(h);
5527 55           SV *errsv = DBIc_ERR(imp_xxh);
5528             (void)cv;
5529 55           ST(0) = sv_mortalcopy(errsv);
5530              
5531             void
5532             state(h)
5533             SV * h
5534             CODE:
5535 10           D_imp_xxh(h);
5536 10           SV *state = DBIc_STATE(imp_xxh);
5537             (void)cv;
5538 10 100         ST(0) = DBIc_STATE_adjust(imp_xxh, state);
    50          
    50          
    50          
    50          
    50          
    50          
    0          
    100          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
5539              
5540             void
5541             errstr(h)
5542             SV * h
5543             CODE:
5544 6702           D_imp_xxh(h);
5545 6702           SV *errstr = DBIc_ERRSTR(imp_xxh);
5546             SV *err;
5547             /* If there's no errstr but there is an err then use err */
5548             (void)cv;
5549 6702 50         if (!SvTRUE(errstr) && (err=DBIc_ERR(imp_xxh)) && SvTRUE(err))
    50          
    0          
    100          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
5550 0           errstr = err;
5551 6702           ST(0) = sv_mortalcopy(errstr);
5552              
5553              
5554             void
5555             set_err(h, err, errstr=&PL_sv_no, state=&PL_sv_undef, method=&PL_sv_undef, result=Nullsv)
5556             SV * h
5557             SV * err
5558             SV * errstr
5559             SV * state
5560             SV * method
5561             SV * result
5562             PPCODE:
5563             {
5564 9365           D_imp_xxh(h);
5565             SV **sem_svp;
5566             (void)cv;
5567              
5568 9365 100         if (DBIc_has(imp_xxh, DBIcf_HandleSetErr) && SvREADONLY(method))
    50          
5569 38           method = sv_mortalcopy(method); /* HandleSetErr may want to change it */
5570              
5571 9365 100         if (!set_err_sv(h, imp_xxh, err, errstr, state, method)) {
5572             /* set_err was canceled by HandleSetErr, */
5573             /* don't set "dbi_set_err_method", return an empty list */
5574             }
5575             else {
5576             /* store provided method name so handler code can find it */
5577 9363           sem_svp = hv_fetch((HV*)SvRV(h), "dbi_set_err_method", 18, 1);
5578 9363 100         if (SvOK(method)) {
    50          
    50          
5579 6 50         sv_setpv(*sem_svp, SvPV_nolen(method));
5580             }
5581             else
5582 9357 50         (void)SvOK_off(*sem_svp);
5583 9363 50         EXTEND(SP, 1);
5584 9363 100         PUSHs( result ? result : &PL_sv_undef );
5585             }
5586             /* We don't check RaiseError and call die here because that must be */
5587             /* done by returning through dispatch and letting the DBI handle it */
5588             }
5589              
5590              
5591             int
5592             trace(h, level=&PL_sv_undef, file=Nullsv)
5593             SV *h
5594             SV *level
5595             SV *file
5596             ALIAS:
5597             debug = 1
5598             CODE:
5599 68           RETVAL = set_trace(h, level, file);
5600             (void)cv; /* Unused variables */
5601             (void)ix;
5602             OUTPUT:
5603             RETVAL
5604              
5605              
5606             void
5607             trace_msg(sv, msg, this_trace=1)
5608             SV *sv
5609             const char *msg
5610             int this_trace
5611             PREINIT:
5612             int current_trace;
5613             PerlIO *pio;
5614             CODE:
5615             {
5616             dMY_CXT;
5617             (void)cv;
5618 27309 100         if (SvROK(sv)) {
5619 5460           D_imp_xxh(sv);
5620 5460           current_trace = DBIc_TRACE_LEVEL(imp_xxh);
5621 5460           pio = DBIc_LOGPIO(imp_xxh);
5622             }
5623             else { /* called as a static method */
5624 21849           current_trace = DBIS_TRACE_FLAGS;
5625 21849           pio = DBILOGFP;
5626             }
5627 27309 100         if (DBIc_TRACE_MATCHES(this_trace, current_trace)) {
    50          
5628 98           PerlIO_puts(pio, msg);
5629 98           ST(0) = &PL_sv_yes;
5630             }
5631             else {
5632 27211           ST(0) = &PL_sv_no;
5633             }
5634             }
5635              
5636              
5637             void
5638             rows(h)
5639             SV * h
5640             CODE:
5641             /* fallback esp for $DBI::rows after $drh was last used */
5642 0           ST(0) = sv_2mortal(newSViv(-1));
5643             (void)h;
5644             (void)cv;
5645              
5646              
5647             void
5648             swap_inner_handle(rh1, rh2, allow_reparent=0)
5649             SV * rh1
5650             SV * rh2
5651             IV allow_reparent
5652             CODE:
5653             {
5654 14           D_impdata(imp_xxh1, imp_xxh_t, rh1);
5655 14           D_impdata(imp_xxh2, imp_xxh_t, rh2);
5656 14           SV *h1i = dbih_inner(aTHX_ rh1, "swap_inner_handle");
5657 14           SV *h2i = dbih_inner(aTHX_ rh2, "swap_inner_handle");
5658 14 50         SV *h1 = (rh1 == h1i) ? (SV*)DBIc_MY_H(imp_xxh1) : SvRV(rh1);
5659 14 50         SV *h2 = (rh2 == h2i) ? (SV*)DBIc_MY_H(imp_xxh2) : SvRV(rh2);
5660             (void)cv;
5661              
5662 14 100         if (DBIc_TYPE(imp_xxh1) != DBIc_TYPE(imp_xxh2)) {
5663             char buf[99];
5664 2           sprintf(buf, "Can't swap_inner_handle between %sh and %sh",
5665 4           dbih_htype_name(DBIc_TYPE(imp_xxh1)), dbih_htype_name(DBIc_TYPE(imp_xxh2)));
5666 2           DBIh_SET_ERR_CHAR(rh1, imp_xxh1, "1", 1, buf, Nullch, Nullch);
5667 2           XSRETURN_NO;
5668             }
5669 12 100         if (!allow_reparent && DBIc_PARENT_COM(imp_xxh1) != DBIc_PARENT_COM(imp_xxh2)) {
    100          
5670 2           DBIh_SET_ERR_CHAR(rh1, imp_xxh1, "1", 1,
5671             "Can't swap_inner_handle with handle from different parent",
5672             Nullch, Nullch);
5673 2           XSRETURN_NO;
5674             }
5675              
5676 10           (void)SvREFCNT_inc(h1i);
5677 10           (void)SvREFCNT_inc(h2i);
5678              
5679 10           sv_unmagic(h1, 'P'); /* untie(%$h1) */
5680 10           sv_unmagic(h2, 'P'); /* untie(%$h2) */
5681              
5682 10           sv_magic(h1, h2i, 'P', Nullch, 0); /* tie %$h1, $h2i */
5683 10           DBIc_MY_H(imp_xxh2) = (HV*)h1;
5684              
5685 10           sv_magic(h2, h1i, 'P', Nullch, 0); /* tie %$h2, $h1i */
5686 10           DBIc_MY_H(imp_xxh1) = (HV*)h2;
5687              
5688 10           SvREFCNT_dec(h1i);
5689 10           SvREFCNT_dec(h2i);
5690              
5691 10           ST(0) = &PL_sv_yes;
5692             }
5693              
5694              
5695             MODULE = DBI PACKAGE = DBD::_mem::common
5696              
5697             void
5698             DESTROY(imp_xxh_rv)
5699             SV * imp_xxh_rv
5700             CODE:
5701             /* ignore 'cast increases required alignment' warning */
5702 29559           imp_xxh_t *imp_xxh = (imp_xxh_t*)SvPVX(SvRV(imp_xxh_rv));
5703 29559           DBIc_DBISTATE(imp_xxh)->clearcom(imp_xxh);
5704             (void)cv;
5705              
5706             # end