Fix handling of given/when

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

diff --git a/Upper.xs b/Upper.xs
index 95a22ed74520b2f521fc871b075b60b7ba4489e5..436a5b5f6c8ca35493384f9d17a1f933b36031b4 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -48,6 +48,14 @@
 # define HvNAME_get(H) HvNAME(H)
 #endif
 
+#ifndef ENTER_with_name
+# define ENTER_with_name(N) ENTER
+#endif
+
+#ifndef LEAVE_with_name
+# define LEAVE_with_name(N) LEAVE
+#endif
+
 #ifndef gv_fetchpvn_flags
 # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
 #endif
@@ -277,7 +285,7 @@ typedef struct {
 
 STATIC void su_call(pTHX_ void *ud_) {
  su_ud_reap *ud = (su_ud_reap *) ud_;
-#if SU_HAS_PERL(5, 10, 0)
+#if SU_HAS_PERL(5, 9, 5)
  PERL_CONTEXT saved_cx;
  I32 dieing = PL_op->op_type == OP_DIE;
  I32 cxix;
@@ -293,10 +301,10 @@ STATIC void su_call(pTHX_ void *ud_) {
  PUSHMARK(SP);
  PUTBACK;
 
- /* If cxstack_ix isn't incremented there, the eval context will be overwritten
-  * when the new sub scope will be created in call_sv. */
+ /* If the recently popped context isn't saved there, it will be overwritten by
+  * the sub scope from call_sv, although it's still needed in our caller. */
 
-#if SU_HAS_PERL(5, 10, 0)
+#if SU_HAS_PERL(5, 9, 5)
  if (dieing) {
   if (cxstack_ix < cxstack_max)
    cxix = cxstack_ix + 1;
@@ -308,7 +316,7 @@ STATIC void su_call(pTHX_ void *ud_) {
 
  call_sv(ud->cb, G_VOID);
 
-#if SU_HAS_PERL(5, 10, 0)
+#if SU_HAS_PERL(5, 9, 5)
  if (dieing)
   cxstack[cxix] = saved_cx;
 #endif
@@ -482,6 +490,10 @@ STATIC void su_pop(pTHX_ void *ud) {
                                       ud, PL_savestack_ix, depth));
  } else {
   SU_UD_HANDLER(ud)(aTHX_ ud);
+#if SU_DEBUG
+  if (PL_scopestack[PL_scopestack_ix] != PL_savestack_ix)
+   PerlIO_printf(Perl_debug_log, "%p: expected: %2d got: %2d\n", ud, PL_scopestack_ix, PL_savestack_ix);
+#endif /* SU_DEBUG */
  }
 }
 
@@ -491,7 +503,7 @@ STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) {
 #define su_init(L, U, S) su_init(aTHX_ (L), (U), (S))
  I32 i, depth = 0, *origin;
 
- LEAVE;
+ LEAVE_with_name("sub");
 
  if (cxix >= cxstack_ix) {
   SU_UD_HANDLER(ud)(aTHX_ ud);
@@ -503,6 +515,19 @@ STATIC I32 su_init(pTHX_ I32 cxix, void *ud, 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:
@@ -515,7 +540,7 @@ STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) {
     depth += 2;
     break;
    default:
-    SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is normal\n", ud, i));
+    SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is other\n", ud, i));
     depth++;
     break;
   }
@@ -551,7 +576,7 @@ STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) {
  SAVEDESTRUCTOR_X(su_pop, ud);
 
 done:
- ENTER;
+ ENTER_with_name("sub");
 
  return depth;
 }