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