view release on metacpan or  search on metacpan

DBI.xs  view on Meta::CPAN

        nima->stash = NULL;
        nima->gv    = NULL;
        nima->my_perl = my_perl;
        ima = nima;
    }
#endif

    ima_flags  = ima->flags;
    meth_type = ima->meth_type;
    if (trace_level >= 9) {
        PerlIO *logfp = DBILOGFP;
        PerlIO_printf(logfp,"%c   >> %-11s DISPATCH (%s rc%ld/%ld @%ld g%x ima%lx pid#%ld)",
            (PL_dirty?'!':' '), meth_name, neatsvpv(h,0),
            (long)SvREFCNT(h), (SvROK(h) ? (long)SvREFCNT(SvRV(h)) : (long)-1),
            (long)items, (int)gimme, (long)ima_flags, (long)PerlProc_getpid());
        PerlIO_puts(logfp, log_where(0, 0, " at ","\n", 1, (trace_level >= 3), (trace_level >= 4)));
        PerlIO_flush(logfp);
    }

    if ( ( (is_DESTROY=(meth_type == methtype_DESTROY))) ) {
        /* note that croak()'s won't propagate, only append to $@ */
        keep_error = TRUE;
    }

    /* If h is a tied hash ref, switch to the inner ref 'behind' the tie.
       This means *all* DBI methods work with the inner (non-tied) ref.
       This makes it much easier for methods to access the real hash
       data (without having to go through FETCH and STORE methods) and
       for tie and non-tie methods to call each other.
    */
    if (SvROK(h)
        && SvRMAGICAL(SvRV(h))
        && (
               ((mg=SvMAGIC(SvRV(h)))->mg_type == 'P')
            || ((mg=mg_find(SvRV(h),'P')) != NULL)
           )
    ) {
        if (mg->mg_obj==NULL || !SvOK(mg->mg_obj) || SvRV(mg->mg_obj)==NULL) {  /* maybe global destruction */
            if (trace_level >= 3)
                PerlIO_printf(DBILOGFP,
                    "%c   <> %s for %s ignored (inner handle gone)\n",
                    (PL_dirty?'!':' '), meth_name, neatsvpv(h,0));
            XSRETURN(0);
        }
        /* Distinguish DESTROY of tie (outer) from DESTROY of inner ref */
        /* This may one day be used to manually destroy extra internal  */
        /* refs if the application ceases to use the handle.            */
        if (is_DESTROY) {
            imp_xxh = DBIh_COM(mg->mg_obj);
#ifdef DBI_USE_THREADS
            if (imp_xxh && DBIc_THR_USER(imp_xxh) != my_perl) {
                goto is_DESTROY_wrong_thread;
            }
#endif
            if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB)
                clear_cached_kids(aTHX_ mg->mg_obj, imp_xxh, meth_name, trace_level);
            /* XXX might be better to move this down to after call_depth has been
             * incremented and then also SvREFCNT_dec(mg->mg_obj) to force an immediate
             * DESTROY of the inner handle if there are no other refs to it.
             * That way the inner DESTROY is properly flagged as a nested call,
             * and the outer DESTROY gets profiled more accurately, and callbacks work.
             */
            if (trace_level >= 3) {
                PerlIO_printf(DBILOGFP,
                    "%c   <> DESTROY(%s) ignored for outer handle (inner %s has ref cnt %ld)\n",
                    (PL_dirty?'!':' '), neatsvpv(h,0), neatsvpv(mg->mg_obj,0),
                    (long)SvREFCNT(SvRV(mg->mg_obj))
                );
            }
            /* for now we ignore it since it'll be followed soon by     */
            /* a destroy of the inner hash and that'll do the real work */

            /* However, we must at least modify DBIc_MY_H() as that is  */
            /* pointing (without a refcnt inc) to the scalar that is    */
            /* being destroyed, so it'll contain random values later.   */
            if (imp_xxh)
                DBIc_MY_H(imp_xxh) = (HV*)SvRV(mg->mg_obj); /* inner (untied) HV */

            XSRETURN(0);
        }
        h = mg->mg_obj; /* switch h to inner ref                        */
        ST(0) = h;      /* switch handle on stack to inner ref          */
    }

    imp_xxh = dbih_getcom2(aTHX_ h, 0); /* get common Internal Handle Attributes        */
    if (!imp_xxh) {
        if (meth_type == methtype_can) {  /* ref($h)->can("foo")        */
            const char *can_meth = SvPV_nolen(st1);
            SV *rv = &PL_sv_undef;
            GV *gv = gv_fetchmethod_autoload(gv_stashsv(orig_h,FALSE), can_meth, FALSE);
            if (gv && isGV(gv))
                rv = sv_2mortal(newRV_inc((SV*)GvCV(gv)));
            if (trace_level >= 1) {
                PerlIO_printf(DBILOGFP,"    <- %s(%s) = %p\n", meth_name, can_meth, neatsvpv(rv,0));
            }
            ST(0) = rv;
            XSRETURN(1);
        }
        if (trace_level)
            PerlIO_printf(DBILOGFP, "%c   <> %s for %s ignored (no imp_data)\n",
                (PL_dirty?'!':' '), meth_name, neatsvpv(h,0));
        if (!is_DESTROY)
            warn("Can't call %s method on handle %s%s", meth_name, neatsvpv(h,0),
                SvROK(h) ? " after take_imp_data()" : " (not a reference)");
        XSRETURN(0);
    }

    if (DBIc_has(imp_xxh,DBIcf_Profile)) {
        profile_t1 = dbi_time(); /* just get start time here */
    }

#ifdef DBI_USE_THREADS
{
    PerlInterpreter * h_perl;
    is_DESTROY_wrong_thread:
    h_perl = DBIc_THR_USER(imp_xxh) ;
    if (h_perl != my_perl) {
        /* XXX could call a 'handle clone' method here?, for dbh's at least */
        if (is_DESTROY) {
            if (trace_level >= 3) {
                PerlIO_printf(DBILOGFP,"    DESTROY ignored because DBI %sh handle (%s) is owned by thread %p not current thread %p\n",