return depth;
}
-#define SU_GET_LEVEL(A) \
- if (items > A) { \
- SV *lsv = ST(A); \
- if (SvOK(lsv)) \
- level = SvUV(lsv); \
- if (level < 0) \
- XSRETURN(0); \
- } \
- if (level > cxstack_ix) \
- level = cxstack_ix;
-
-#define SU_DOPOPTOCX(t) \
- STMT_START { \
- I32 i, cxix = cxstack_ix, from = 0; \
- if (items) \
- from = SvIV(ST(0)); \
- for (i = cxix - from; i >= 0; --i) { \
- if (CxTYPE(&cxstack[i]) == t) { \
- ST(0) = sv_2mortal(newSViv(cxix - i)); \
- XSRETURN(1); \
- } \
- } \
- XSRETURN_UNDEF; \
- } STMT_END
+/* --- Unwind stack -------------------------------------------------------- */
typedef struct {
I32 cxix;
OP fakeop;
I32 cxix = ud->cxix;
I32 items = ud->items - 1;
- I32 gimme, mark = 0;
+ I32 gimme, mark;
+
+ gimme = GIMME_V;
if (cxstack_ix > cxix)
dounwind(cxix);
/* Hide the level */
- PL_stack_sp--;
+ if (items >= 0)
+ PL_stack_sp--;
- gimme = GIMME_V;
- if (cxix > 0)
- mark = cxstack[cxix - 1].blk_oldsp;
+ mark = PL_markstack[cxstack[cxix].blk_oldmarksp];
if (gimme == G_SCALAR) {
*PL_markstack_ptr = PL_stack_sp - PL_stack_base;
*PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
}
+ SU_D({
+ PerlIO_printf(Perl_debug_log,
+ "%p: cx=%d gimme=%s items=%d sp=%d oldmark=%d mark=%d\n",
+ ud, cxix,
+ gimme == G_VOID ? "void" : gimme == G_ARRAY ? "list" : "scalar",
+ items, PL_stack_sp - PL_stack_base, *PL_markstack_ptr, mark);
+ });
+
PL_op = PL_ppaddr[OP_RETURN](aTHX);
*PL_markstack_ptr = mark;
/* --- XS ------------------------------------------------------------------ */
+#define SU_GET_LEVEL(A) \
+ STMT_START { \
+ if (items > A) { \
+ SV *lsv = ST(A); \
+ if (SvOK(lsv)) \
+ level = SvIV(lsv); \
+ if (level < 0) \
+ XSRETURN(0); \
+ } \
+ if (level > cxstack_ix) \
+ level = cxstack_ix; \
+ } STMT_END
+
+#define SU_GET_CONTEXT(A, B) \
+ STMT_START { \
+ if (items > A) { \
+ SV *lsv = ST(B); \
+ if (SvOK(lsv)) \
+ level = SvIV(lsv); \
+ if (level < 0) \
+ level = 0; \
+ else if (level > cxix) \
+ level = cxix; \
+ } \
+ } STMT_END
+
+#define SU_DOPOPTOCX(t) \
+ STMT_START { \
+ I32 i, cxix = cxstack_ix, level = 0; \
+ SU_GET_CONTEXT(0, 0); \
+ for (i = cxix - level; i >= 0; --i) { \
+ if (CxTYPE(&cxstack[i]) == t) { \
+ ST(0) = sv_2mortal(newSViv(cxix - i)); \
+ XSRETURN(1); \
+ } \
+ } \
+ XSRETURN_UNDEF; \
+ } STMT_END
+
XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
XS(XS_Scope__Upper_unwind) {
#else
dXSARGS;
#endif
- I32 cxix;
+ I32 cxix = cxstack_ix, level = 0;
su_ud_unwind *ud;
- SV *level;
- if (!items)
- Perl_croak(aTHX_ "Usage: Scope::Upper::unwind(..., level)");
+
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
- level = ST(items - 1);
- cxix = SvOK(level) ? SvIV(level) : 0;
- if (cxix < 0)
- cxix = 0;
- else if (cxix > cxstack_ix)
- cxix = cxstack_ix;
- cxix = cxstack_ix - cxix;
+
+ SU_GET_CONTEXT(0, items - 1);
+ cxix -= level;
do {
PERL_CONTEXT *cx = cxstack + cxix;
switch (CxTYPE(cx)) {
PPCODE:
SU_DOPOPTOCX(CXt_EVAL);
+void
+CALLER(...)
+PROTOTYPE: ;$
+PREINIT:
+ I32 cxix = cxstack_ix, caller = 0, level = 0;
+PPCODE:
+ if (items) {
+ SV *csv = ST(0);
+ if (SvOK(csv))
+ caller = SvIV(csv);
+ }
+ cxix = cxstack_ix;
+ while (cxix > 0) {
+ PERL_CONTEXT *cx = cxstack + cxix--;
+ switch (CxTYPE(cx)) {
+ case CXt_SUB:
+ case CXt_EVAL:
+ case CXt_FORMAT:
+ --caller;
+ if (caller < 0)
+ goto done;
+ break;
+ }
+ ++level;
+ }
+done:
+ ST(0) = sv_2mortal(newSViv(level));
+ XSRETURN(1);
+
+void
+want_at(...)
+PROTOTYPE: ;$
+PREINIT:
+ I32 cxix = cxstack_ix, level = 0;
+PPCODE:
+ SU_GET_CONTEXT(0, 0);
+ cxix -= level;
+ while (cxix > 0) {
+ PERL_CONTEXT *cx = cxstack + cxix--;
+ switch (CxTYPE(cx)) {
+ case CXt_SUB:
+ case CXt_EVAL:
+ case CXt_FORMAT: {
+ I32 gimme = cx->blk_gimme;
+ switch (gimme) {
+ case G_VOID: XSRETURN_UNDEF; break;
+ case G_SCALAR: XSRETURN_NO; break;
+ case G_ARRAY: XSRETURN_YES; break;
+ }
+ break;
+ }
+ }
+ }
+ XSRETURN_UNDEF;
+
void
reap(SV *hook, ...)
PROTOTYPE: &;$