X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=c5da0e16220581b24d7d688b6db6c4dced614d96;hb=3a43f1ed62c266c8108a25266b461393336016b5;hp=76496ac34e683671fa7192cd49a099e5a7cedee5;hpb=979a80f45ad9c555a698eddbc9114e696817739f;p=perl%2Fmodules%2FScope-Upper.git

diff --git a/Upper.xs b/Upper.xs
index 76496ac..c5da0e1 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -133,6 +133,22 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) {
 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
 #endif
 
+#ifndef OP_GIMME_REVERSE
+STATIC U8 su_op_gimme_reverse(U8 gimme) {
+ switch (gimme) {
+  case G_VOID:
+   return OPf_WANT_VOID;
+  case G_ARRAY:
+   return OPf_WANT_LIST;
+  default:
+   break;
+ }
+
+ return OPf_WANT_SCALAR;
+}
+#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G)
+#endif
+
 #ifndef PERL_MAGIC_tied
 # define PERL_MAGIC_tied 'P'
 #endif
@@ -979,19 +995,6 @@ STATIC I32 su_init(pTHX_ void *ud, I32 cxix, I32 size) {
  for (i = cxstack_ix; i > cxix; --i) {
   PERL_CONTEXT *cx = cxstack + i;
   switch (CxTYPE(cx)) {
-#if SU_HAS_PERL(5, 10, 0)
-   case CXt_BLOCK:
-    SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is block\n", ud, i));
-    /* Given and when blocks are actually followed by a simple block, so skip
-     * it if needed. */
-    if (cxix > 0) { /* Implies i > 0 */
-     PERL_CONTEXT *next = cx - 1;
-     if (CxTYPE(next) == CXt_GIVEN || CxTYPE(next) == CXt_WHEN)
-      --cxix;
-    }
-    depth++;
-    break;
-#endif
 #if SU_HAS_PERL(5, 11, 0)
    case CXt_LOOP_FOR:
    case CXt_LOOP_PLAIN:
@@ -1100,22 +1103,6 @@ STATIC void su_unwind(pTHX_ void *ud_) {
 
 /* --- Uplevel ------------------------------------------------------------- */
 
-#ifndef OP_GIMME_REVERSE
-STATIC U8 su_op_gimme_reverse(U8 gimme) {
- switch (gimme) {
-  case G_VOID:
-   return OPf_WANT_VOID;
-  case G_ARRAY:
-   return OPf_WANT_LIST;
-  default:
-   break;
- }
-
- return OPf_WANT_SCALAR;
-}
-#define OP_GIMME_REVERSE(G) su_op_gimme_reverse(G)
-#endif
-
 #define SU_UPLEVEL_SAVE(f, t) STMT_START { sud->old_##f = PL_##f; PL_##f = (t); } STMT_END
 #define SU_UPLEVEL_RESTORE(f) STMT_START { PL_##f = sud->old_##f; } STMT_END
 
@@ -1798,6 +1785,84 @@ STATIC int su_uid_validate(pTHX_ SV *uid) {
  return su_uid_storage_check(depth, seq);
 }
 
+/* --- Context operations -------------------------------------------------- */
+
+#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 skipped = 0;    \
+  PERL_CONTEXT *base = cxstack;      \
+  PERL_CONTEXT *cx   = base + (C);   \
+  while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \
+   --cx, ++skipped;                  \
+  if (cx >= base && (C) > skipped) { \
+   switch (CxTYPE(cx)) {  \
+    case CXt_SUB:         \
+     if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \
+      (C) -= skipped + 1; \
+      break;              \
+    default:              \
+     break;               \
+   }                      \
+  }                       \
+ } STMT_END
+
+STATIC I32 su_context_up(pTHX_ I32 cxix) {
+#define su_context_up(C) su_context_up(aTHX_ (C))
+ PERL_CONTEXT *cx;
+
+ if (cxix <= 0)
+  return 0;
+
+ cx = cxstack + cxix;
+ if (CxTYPE(cx) == CXt_BLOCK) {
+  PERL_CONTEXT *prev = cx - 1;
+
+  switch (CxTYPE(prev)) {
+#if SU_HAS_PERL(5, 10, 0)
+   case CXt_GIVEN:
+   case CXt_WHEN:
+#endif
+#if SU_HAS_PERL(5, 11, 0)
+   /* That's the only subcategory that can cause an extra BLOCK context */
+   case CXt_LOOP_PLAIN:
+#else
+   case CXt_LOOP:
+#endif
+    if (cx->blk_oldcop == prev->blk_oldcop)
+     cxix -= 2;
+    else
+     --cxix;
+    break;
+   case CXt_SUBST:
+    if (cx->blk_oldcop && cx->blk_oldcop->op_sibling
+                       && cx->blk_oldcop->op_sibling->op_type == OP_SUBST)
+     cxix -= 2;
+    else
+     --cxix;
+    break;
+   default:
+    --cxix;
+    break;
+  }
+ } else {
+  --cxix;
+ }
+
+ if (PL_DBsub)
+  SU_SKIP_DB(cxix);
+
+ return cxix;
+}
+
 /* --- Interpreter setup/teardown ------------------------------------------ */
 
 STATIC void su_teardown(pTHX_ void *param) {
@@ -1856,34 +1921,6 @@ STATIC void su_setup(pTHX) {
 
 /* --- 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 skipped = 0;    \
-  PERL_CONTEXT *base = cxstack;      \
-  PERL_CONTEXT *cx   = base + (C);   \
-  while (cx >= base && (C) > skipped && CxTYPE(cx) == CXt_BLOCK) \
-   --cx, ++skipped;                  \
-  if (cx >= base && (C) > skipped) { \
-   switch (CxTYPE(cx)) {  \
-    case CXt_SUB:         \
-     if (skipped <= SU_SKIP_DB_MAX && cx->blk_sub.cv == GvCV(PL_DBsub)) \
-      (C) -= skipped + 1; \
-      break;              \
-    default:              \
-     break;               \
-   }                      \
-  }                       \
- } STMT_END
-
 #define SU_GET_CONTEXT(A, B)   \
  STMT_START {                  \
   if (items > A) {             \
@@ -2026,10 +2063,7 @@ PREINIT:
  I32 cxix;
 PPCODE:
  SU_GET_CONTEXT(0, 0);
- if (--cxix < 0)
-  cxix = 0;
- if (PL_DBsub)
-  SU_SKIP_DB(cxix);
+ cxix = su_context_up(cxix);
  EXTEND(SP, 1);
  mPUSHi(cxix);
  XSRETURN(1);
@@ -2084,19 +2118,10 @@ PREINIT:
 PPCODE:
  SU_GET_LEVEL(0, 0);
  cxix = cxstack_ix;
- if (PL_DBsub) {
+ 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;
- }
+ while (--level >= 0)
+  cxix = su_context_up(cxix);
  EXTEND(SP, 1);
  mPUSHi(cxix);
  XSRETURN(1);