Fix handling of given/when

diff --git a/Upper.xs b/Upper.xs
index 9c28d1720059cf4d7b7a1173af352210233e8d6f..436a5b5f6c8ca35493384f9d17a1f933b36031b4 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -490,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 */
  }
 }
 
@@ -511,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:
@@ -523,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;
   }

diff --git a/t/lib/Scope/Upper/TestGenerator.pm b/t/lib/Scope/Upper/TestGenerator.pm
index af267870189e2a2f629a12d89c42266b8e6f3839..99764d5618f3fad75c3198f9206d31d0c065b36c 100644 (file)
--- a/t/lib/Scope/Upper/TestGenerator.pm
+++ b/t/lib/Scope/Upper/TestGenerator.pm
@@ -25,6 +25,14 @@ my @blocks = (
  [ 'eval q[',   '];' ],
 );
 
+sub import {
+ if ($] >= 5.010001) {
+  push @blocks, [ 'given (1) { my $_;', '}' ];
+  require feature;
+  feature->import('switch');
+ }
+}
+
 @blocks = map [ map "$_\n", @$_ ], @blocks;
 
 sub _block {