view release on metacpan or  search on metacpan

parts/inc/cop  view on Meta::CPAN

	}
	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))
	    level++;
	if (!level--)
	    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 => 8

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

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

BEGIN {
  if (ivers($]) < ivers('5.006000')) {
    skip("Perl version too early", 8);
    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