################################################################################

##

##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.

##  Version 2.x, Copyright (C) 2001, Paul Marquess.

##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.

##

##  This program is free software; you can redistribute it and/or

##  modify it under the same terms as Perl itself.

##

################################################################################

=provides

caller_cx

__UNDEFINED__

=implementation

#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 */

=xsinit

#define NEED_caller_cx

=xsubs

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 */

=tests plan => 28

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[$_]);

    }

}