caller_cx __UNDEFINED__

#ifdef USE_ITHREADS

__UNDEFINED__ CopFILE(c) ((c)->cop_file) __UNDEFINED__ CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) __UNDEFINED__ CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) __UNDEFINED__ CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) __UNDEFINED__ CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) __UNDEFINED__ CopSTASHPV(c) ((c)->cop_stashpv) __UNDEFINED__ CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) __UNDEFINED__ CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) __UNDEFINED__ CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) __UNDEFINED__ CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv)))))

#else

__UNDEFINED__ CopFILEGV(c) ((c)->cop_filegv) __UNDEFINED__ CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) __UNDEFINED__ CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) __UNDEFINED__ CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) __UNDEFINED__ CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) __UNDEFINED__ CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) __UNDEFINED__ CopSTASH(c) ((c)->cop_stash) __UNDEFINED__ CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) __UNDEFINED__ CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) __UNDEFINED__ CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) __UNDEFINED__ CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))

#endif /* USE_ITHREADS */

#if { VERSION >= 5.6.0 } #ifndef caller_cx

# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) static I32 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { I32 i;

    for (i = startingblock; i >= 0; i--) {
        register const PERL_CONTEXT * const cx = &cxstk[i];
        switch (CxTYPE(cx)) {
        default:
            continue;
        case CXt_EVAL:
        case CXt_SUB:
        case CXt_FORMAT:
            return i;
        }
    }
    return i;
}
# endif

# if { NEED caller_cx }

const PERL_CONTEXT * caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) { register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); register const PERL_CONTEXT *cx; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo;

    for (;;) {
        /* we may be in a higher stacklevel, so dig down deeper */
        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
            top_si = top_si->si_prev;
            ccstack = top_si->si_cxstack;
            cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
        }
        if (cxix < 0)
            return NULL;
        /* caller() should not report the automatic calls to &DB::sub */
        if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
                ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
            count++;
        if (!count--)
            break;
        cxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
    }

    cx = &ccstack[cxix];
    if (dbcxp) *dbcxp = cx;

    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
        const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
        /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
           field below is defined for any cx. */
        /* caller() should not report the automatic calls to &DB::sub */
        if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
            cx = &ccstack[dbcxix];
    }

    return cx;
}

# endif #endif /* caller_cx */ #endif /* 5.6.0 */

#define NEED_caller_cx

char * CopSTASHPV() CODE: RETVAL = CopSTASHPV(PL_curcop); OUTPUT: RETVAL

char * CopFILE() CODE: RETVAL = CopFILE(PL_curcop); OUTPUT: RETVAL

#if { VERSION >= 5.6.0 }

void caller_cx(level) I32 level PREINIT: const PERL_CONTEXT *cx, *dbcx; const char *pv; const GV *gv; PPCODE: cx = caller_cx(level, &dbcx); if (!cx) XSRETURN_EMPTY;

        EXTEND(SP, 4);

        pv = CopSTASHPV(cx->blk_oldcop);
        ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
        gv = CvGV(cx->blk_sub.cv);
        ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;

        pv = CopSTASHPV(dbcx->blk_oldcop);
        ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
        gv = CvGV(dbcx->blk_sub.cv);
        ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;

        XSRETURN(4);

#endif /* 5.6.0 */

my $package; { package MyPackage; $package = &Devel::PPPort::CopSTASHPV(); } print "# $package\n"; ok($package, "MyPackage");

my $file = &Devel::PPPort::CopFILE(); print "# $file\n"; ok($file =~ /cop/i);

BEGIN { if ("$]" < 5.006000) { # Skip for (1..28) { ok(1, 1); } exit; } }

BEGIN { package DB; no strict "refs"; local $^P = 1; sub sub { &$DB::sub } }

{ package One; sub one { Devel::PPPort::caller_cx($_[0]) } } { package Two; sub two { One::one(@_) } sub dbtwo { BEGIN { $^P = 1 } One::one(@_); BEGIN { $^P = 0 } } }

for ( # This is rather confusing. The package is the package the call is # made *from*, the sub name is the sub the call is made *to*. When # DB::sub is involved the first call is to DB::sub from the calling # package, the second is to the real sub from package DB. [\&One::one, 0, qw/main one main one/], [\&One::one, 2, ], [\&Two::two, 0, qw/Two one Two one/], [\&Two::two, 1, qw/main two main two/], [\&Two::dbtwo, 0, qw/Two sub DB one/], [\&Two::dbtwo, 1, qw/main dbtwo main dbtwo/], ) { my ($sub, $arg, @want) = @$_; my @got = $sub->($arg); ok(@got, @want); for (0..$#want) { ok($got[$_], $want[$_]); } }