Introduce SCOPE()

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

diff --git a/Upper.xs b/Upper.xs
index 9c510f99ba5f20b6d5811966233d9c291ee4085d..cd093dea83fdb52c8771d94f461f5da65598ff53 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -612,6 +612,31 @@ STATIC void su_unwind(pTHX_ void *ud_) {
 
 /* --- XS ------------------------------------------------------------------ */
 
+#if SU_HAS_PERL(5, 8, 9)
+# define SU_SKIP_DB_MAX 2
+#else
+# define SU_SKIP_DB_MAX 3
+#endif
+
+/* Skip context sequences of 1 to SU_SKIP_DB_MAX (included) block contexts
+ * followed by a DB sub */
+
+#define SU_SKIP_DB(C) \
+ STMT_START {         \
+  I32 i = 1;          \
+  PERL_CONTEXT *cx = cxstack + (C); \
+  do {                              \
+   if (CxTYPE(cx) == CXt_BLOCK && (C) >= i) { \
+    --cx;                                     \
+    if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.cv == GvCV(PL_DBsub)) { \
+     (C) -= i + 1;                \
+     break;                       \
+    }                             \
+   } else                         \
+    break;                        \
+  } while (++i <= SU_SKIP_DB_MAX); \
+ } STMT_END
+
 #define SU_GET_CONTEXT(A, B)   \
  STMT_START {                  \
   if (items > A) {             \
@@ -622,21 +647,23 @@ STATIC void su_unwind(pTHX_ void *ud_) {
     cxix = 0;                  \
    else if (cxix > cxstack_ix) \
     cxix = cxstack_ix;         \
-  } else                       \
+  } else {                     \
    cxix = cxstack_ix;          \
+   if (PL_DBsub)               \
+    SU_SKIP_DB(cxix);          \
+  }                            \
  } STMT_END
 
-#define SU_DOPOPTOCX(t)                \
- STMT_START {                          \
-  I32 cxix;                            \
-  SU_GET_CONTEXT(0, 0);                \
-  for (; cxix >= 0; --cxix) {          \
-   if (CxTYPE(cxstack + cxix) == t) {  \
-    ST(0) = sv_2mortal(newSViv(cxix)); \
-    XSRETURN(1);                       \
-   }                                   \
-  }                                    \
-  XSRETURN_UNDEF;                      \
+#define SU_GET_LEVEL(A, B) \
+ STMT_START {              \
+  if (items > 0) {         \
+   SV *lsv = ST(B);        \
+   if (SvOK(lsv))          \
+    level = SvIV(lsv);     \
+   if (level < 0)          \
+    level = 0;             \
+  } else                   \
+   level = 0;              \
  } STMT_END
 
 XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
@@ -658,6 +685,8 @@ XS(XS_Scope__Upper_unwind) {
   PERL_CONTEXT *cx = cxstack + cxix;
   switch (CxTYPE(cx)) {
    case CXt_SUB:
+    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
+     continue;
    case CXt_EVAL:
    case CXt_FORMAT:
     MY_CXT.cxix  = cxix;
@@ -704,8 +733,12 @@ CODE:
 SV *
 HERE()
 PROTOTYPE:
+PREINIT:
+ I32 cxix = cxstack_ix;
 CODE:
- RETVAL = newSViv(cxstack_ix);
+ if (PL_DBsub)
+  SU_SKIP_DB(cxix);
+ RETVAL = newSViv(cxix);
 OUTPUT:
  RETVAL
 
@@ -718,61 +751,95 @@ CODE:
  SU_GET_CONTEXT(0, 0);
  if (--cxix < 0)
   cxix = 0;
+ if (PL_DBsub)
+  SU_SKIP_DB(cxix);
  RETVAL = newSViv(cxix);
 OUTPUT:
  RETVAL
 
-SV *
-DOWN(...)
+void
+SUB(...)
 PROTOTYPE: ;$
 PREINIT:
  I32 cxix;
-CODE:
+PPCODE:
  SU_GET_CONTEXT(0, 0);
- if (++cxix > cxstack_ix)
-  cxix = cxstack_ix;
- RETVAL = newSViv(cxix);
-OUTPUT:
- RETVAL
+ for (; cxix >= 0; --cxix) {
+  PERL_CONTEXT *cx = cxstack + cxix;
+  switch (CxTYPE(cx)) {
+   default:
+    continue;
+   case CXt_SUB:
+    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
+     continue;
+    ST(0) = sv_2mortal(newSViv(cxix));
+    XSRETURN(1);
+  }
+ }
+ XSRETURN_UNDEF;
 
 void
-SUB(...)
+EVAL(...)
 PROTOTYPE: ;$
+PREINIT:
+ I32 cxix;
 PPCODE:
- SU_DOPOPTOCX(CXt_SUB);
+ SU_GET_CONTEXT(0, 0);
+ for (; cxix >= 0; --cxix) {
+  PERL_CONTEXT *cx = cxstack + cxix;
+  switch (CxTYPE(cx)) {
+   default:
+    continue;
+   case CXt_EVAL:
+    ST(0) = sv_2mortal(newSViv(cxix));
+    XSRETURN(1);
+  }
+ }
+ XSRETURN_UNDEF;
 
 void
-EVAL(...)
+SCOPE(...)
 PROTOTYPE: ;$
+PREINIT:
+ I32 cxix, level;
 PPCODE:
- SU_DOPOPTOCX(CXt_EVAL);
+ SU_GET_LEVEL(0, 0);
+ cxix = cxstack_ix;
+ if (PL_DBsub) {
+  SU_SKIP_DB(cxix);
+  while (cxix > 0) {
+   if (--level < 0)
+    break;
+   --cxix;
+   SU_SKIP_DB(cxix);
+  }
+ } else {
+  cxix -= level;
+  if (cxix < 0)
+   cxix = 0;
+ }
+ ST(0) = sv_2mortal(newSViv(cxix));
+ XSRETURN(1);
 
 void
 CALLER(...)
 PROTOTYPE: ;$
 PREINIT:
- I32 cxix, caller = 0;
+ I32 cxix, level;
 PPCODE:
- if (items) {
-  SV *csv = ST(0);
-  if (SvOK(csv))
-   caller = SvIV(csv);
-  if (caller < 0)
-   caller = 0;
- }
- cxix = cxstack_ix;
- while (cxix > 0) {
+ SU_GET_LEVEL(0, 0);
+ for (cxix = cxstack_ix; cxix > 0; --cxix) {
   PERL_CONTEXT *cx = cxstack + cxix;
   switch (CxTYPE(cx)) {
    case CXt_SUB:
+    if (PL_DBsub && cx->blk_sub.cv == GvCV(PL_DBsub))
+     continue;
    case CXt_EVAL:
    case CXt_FORMAT:
-    --caller;
-    if (caller < 0)
+    if (--level < 0)
      goto done;
     break;
   }
-  --cxix;
  }
 done:
  ST(0) = sv_2mortal(newSViv(cxix));