STATIC CV * _curcv( pTHX ) { PERL_SI *st = PL_curstackinfo; I32 ix = st->si_cxix; /* It's unclear whether we really need all this given that we call * _curcv on the first OP after subroutine entry - so presumably not * much can have happened by then. */ for ( ;; ) { const PERL_CONTEXT *const cx = &st->si_cxstack[ix]; if ( CxTYPE( cx ) == CXt_SUB || CxTYPE( cx ) == CXt_FORMAT ) return cx->blk_sub.cv; else if ( CxTYPE( cx ) == CXt_EVAL && !CxTRYBLOCK( cx ) ) return PL_compcv; else if ( ix == 0 ) { if ( st->si_type == PERLSI_MAIN ) return PL_main_cv; if ( st = st->si_prev, NULL == st ) break; ix = st->si_cxix + 1; /* add one because we always decrement */ } ix--; } return NULL; }
void Perl_deb_stack_all(pTHX) { #ifdef DEBUGGING dVAR; I32 si_ix; const PERL_SI *si; /* rewind to start of chain */ si = PL_curstackinfo; while (si->si_prev) si = si->si_prev; si_ix=0; for (;;) { const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */ const char * const si_name = (si_name_ix >= sizeof(si_names)) ? "????" : si_names[si_name_ix]; I32 ix; PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n", (IV)si_ix, si_name); for (ix=0; ix<=si->si_cxix; ix++) { const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); PerlIO_printf(Perl_debug_log, " CX %"IVdf": %-6s => ", (IV)ix, PL_block_type[CxTYPE(cx)] ); /* substitution contexts don't save stack pointers etc) */ if (CxTYPE(cx) == CXt_SUBST) PerlIO_printf(Perl_debug_log, "\n"); else { /* Find the current context's stack range by searching * forward for any higher contexts using this stack; failing * that, it will be equal to the size of the stack for old * stacks, or PL_stack_sp for the current stack */ I32 i, stack_min, stack_max, mark_min, mark_max; const PERL_CONTEXT *cx_n = NULL; const PERL_SI *si_n; /* there's a separate stack per SI, so only search * this one */ for (i=ix+1; i<=si->si_cxix; i++) { if (CxTYPE(cx) == CXt_SUBST) continue; cx_n = &(si->si_cxstack[i]); break; } stack_min = cx->blk_oldsp; if (cx_n) { stack_max = cx_n->blk_oldsp; } else if (si == PL_curstackinfo) { stack_max = PL_stack_sp - AvARRAY(si->si_stack); } else { stack_max = AvFILLp(si->si_stack); } /* for the other stack types, there's only one stack * shared between all SIs */ si_n = si; i = ix; cx_n = NULL; for (;;) { i++; if (i > si_n->si_cxix) { if (si_n == PL_curstackinfo) break; else { si_n = si_n->si_next; i = 0; } } if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) continue; cx_n = &(si_n->si_cxstack[i]); break; } mark_min = cx->blk_oldmarksp; if (cx_n) { mark_max = cx_n->blk_oldmarksp; } else { mark_max = PL_markstack_ptr - PL_markstack; } deb_stack_n(AvARRAY(si->si_stack), stack_min, stack_max, mark_min, mark_max); if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { const OP * const retop = cx->blk_sub.retop; PerlIO_printf(Perl_debug_log, " retop=%s\n", retop ? OP_NAME(retop) : "(null)" ); } } } /* next context */ if (si == PL_curstackinfo) break; si = si->si_next; si_ix++; if (!si) break; /* shouldn't happen, but just in case.. */ } /* next stackinfo */ PerlIO_printf(Perl_debug_log, "\n"); #else PERL_UNUSED_CONTEXT; #endif /* DEBUGGING */ }