Introduce want_at()

[perl/modules/Scope-Upper.git] / Upper.xs

diff --git a/Upper.xs b/Upper.xs
index b7088ae0b622c6782e045972268d00b41db559af..6a0b35e77bfb733c038838f378c8001b7e7c88eb 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -515,30 +515,7 @@ done:
  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;
@@ -550,18 +527,18 @@ STATIC void su_unwind(pTHX_ void *ud_) {
  OP fakeop;
  I32 cxix  = ud->cxix;
  I32 items = ud->items - 1;
- I32 gimme, mark = 0;
+ I32 gimme, mark;
 
  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];
 
+ gimme = GIMME_V;
  if (gimme == G_SCALAR) {
   *PL_markstack_ptr = PL_stack_sp - PL_stack_base;
   PL_stack_sp += items;
@@ -569,6 +546,14 @@ STATIC void su_unwind(pTHX_ void *ud_) {
   *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;
 
@@ -580,6 +565,38 @@ STATIC void su_unwind(pTHX_ void *ud_) {
 
 /* --- XS ------------------------------------------------------------------ */
 
+#define SU_GET_LEVEL(A)  \
+ 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;
+
+#define SU_DOPOPTOCX(t)                    \
+ STMT_START {                              \
+  I32 i, cxix = cxstack_ix, level = 0;     \
+  if (items) {                             \
+   SV *lsv = ST(0);                        \
+   if (SvOK(lsv))                          \
+    level = SvIV(lsv);                     \
+   if (level < 0)                          \
+    level = 0;                             \
+   else if (level > cxix)                  \
+    level = cxix;                          \
+  }                                        \
+  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) {
@@ -588,20 +605,20 @@ XS(XS_Scope__Upper_unwind) {
 #else
  dXSARGS;
 #endif
- I32 cxix;
+ I32 level = 0, cxix = cxstack_ix;
  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;
+ if (items) {
+  SV *lsv = ST(items - 1);
+  if (SvOK(lsv))
+   level = SvIV(lsv);
+  if (level < 0)
+   level = 0;
+  else if (level > cxix)
+   level = cxix;
+ }
+ cxix -= level;
  do {
   PERL_CONTEXT *cx = cxstack + cxix;
   switch (CxTYPE(cx)) {
@@ -683,6 +700,69 @@ PROTOTYPE: ;$
 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:
+ if (items) {
+  SV *lsv = ST(0);
+  if (SvOK(lsv))
+   level = SvIV(lsv);
+  if (level < 0)
+   level = 0;
+  else if (level > cxix)
+   level = cxix;
+ }
+ 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: &;$