Fix and test UP and SCOPE crossing loop/subst/given/when/default blocks

diff --git a/Upper.xs b/Upper.xs
index aea8e105409a012f837d0b131c932f3fdb5d5580..c5da0e16220581b24d7d688b6db6c4dced614d96 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -995,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:
@@ -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);

diff --git a/t/05-words.t b/t/05-words.t
index bcb3ac9bcc806e5b986df0706cef95818c3e5f27..24964604d22ddbd89cc8e549a49d8208a304d7ed 100644 (file)
--- a/t/05-words.t
+++ b/t/05-words.t
@@ -5,113 +5,336 @@ use warnings;
 
 use Test::More;
 
-BEGIN {
- if ($^P) {
-  plan skip_all => 'hardcoded values are wrong under the debugger';
- } else {
-  plan tests    => 29 + 13 * 2;
- }
-}
+plan tests => 23 * ($^P ? 4 : 5) + ($^P ? 1 : 2) + 7 + 15 * 2;
 
 use Scope::Upper qw<:words>;
 
-# This test is for internal use only and doesn't imply any kind of future
-# compatibility on what the words should actually return.
+# Tests with hardcoded values are for internal use only and doesn't imply any
+# kind of future compatibility on what the words should actually return.
+
+my $top = HERE;
 
-is HERE, 0, 'main : here';
-is TOP,  0, 'main : top';
-is UP,   0, 'main : up';
+is $top, 0,     'main : here' unless $^P;
+is TOP,  $top,  'main : top';
+is UP,   $top,  'main : up';
 is SUB,  undef, 'main : sub';
 is EVAL, undef, 'main : eval';
 
 {
- is HERE, 1, '{ 1 } : here';
- is TOP,  0, '{ 1 } : top';
- is UP,   0, '{ 1 } : up';
+ my $desc = '{ 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
 }
 
 do {
- is HERE, 1,     'do { 1 } : here';
- is SUB,  undef, 'do { 1 } : sub';
- is EVAL, undef, 'do { 1 } : eval';
+ my $desc = 'do { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
 };
 
 eval {
- is HERE, 1,     'eval { 1 } : here';
- is SUB,  undef, 'eval { 1 } : sub';
- is EVAL, 1,     'eval { 1 } : eval';
+ my $desc = 'eval { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, HERE,  "$desc : eval";
 };
+diag $@ if $@;
 
 eval q[
- is HERE, 1,     'eval "1" : here';
- is SUB,  undef, 'eval "1" : sub';
- is EVAL, 1,     'eval "1" : eval';
+ my $desc = 'eval "1"';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, HERE,  "$desc : eval";
 ];
-
-do {
- is HERE, 1, 'do { 1 } while (0) : here';
-} while (0);
+diag $@ if $@;
 
 sub {
- is HERE, 1,     'sub { 1 } : here';
- is SUB,  1,     'sub { 1 } : sub';
- is EVAL, undef, 'sub { 1 } : eval';
+ my $desc = 'sub { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  HERE,  "$desc : sub";
+ is EVAL, undef, "$desc : eval";
 }->();
 
+my $true  = 1;
+my $false = !$true;
+
+if ($true) {
+ my $desc = 'if () { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}
+
+unless ($false) {
+ my $desc = 'unless () { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}
+
+if ($false) {
+ fail "false was true : $_" for 1 .. 5;
+} else {
+ my $desc = 'if () { } else { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}
+
 for (1) {
- is HERE, 1, 'for () { 1 } : here';
+ my $desc = 'for (list) { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}
+
+for (1 .. 1) {
+ my $desc = 'for (num range) { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}
+
+for (1 .. 1) {
+ my $desc = 'for (pv range) { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}
+
+for (my $i = 0; $i < 1; ++$i) {
+ my $desc = 'for (;;) { 1 }';
+ is HERE, 2,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}
+
+my $flag = 1;
+while ($flag) {
+ $flag = 0;
+ my $desc = 'while () { 1 }';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}
+
+my @list = (1);
+while (my $thing = shift @list) {
+ my $desc = 'while (my $thing = ...) { 2 }';
+ is HERE, "$]" <= 5.008_008 ? 1 : 2, "$desc : here" unless $^P;
+ is TOP,  $top,                      "$desc : top";
+ is UP,   $top,                      "$desc : up";
+ is SUB,  undef,                     "$desc : sub";
+ is EVAL, undef,                     "$desc : eval";
 }
 
 do {
- eval {
-  do {
-   sub {
-    eval q[
-     {
-      is HERE,           6, 'mixed : here';
-      is TOP,            0, 'mixed : top';
-      is SUB,            4, 'mixed : first sub';
-      is SUB(SUB),       4, 'mixed : still first sub';
-      is EVAL,           5, 'mixed : first eval';
-      is EVAL(EVAL),     5, 'mixed : still first eval';
-      is EVAL(UP(EVAL)), 2, 'mixed : second eval';
-     }
-    ];
-   }->();
-  }
- };
+ my $desc = 'do { 1 } while (0)';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
 } while (0);
 
+map {
+ my $desc = 'map { 1 } 1';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+} 1;
+
+grep {
+ my $desc = 'grep { 1 } 1';
+ is HERE, 1,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+} 1;
+
+my $var = 'a';
+$var =~ s{.}{
+ my $desc = 'subst';
+ is HERE, 2,     "$desc : here" unless $^P;
+ is TOP,  $top,  "$desc : top";
+ is UP,   $top,  "$desc : up";
+ is SUB,  undef, "$desc : sub";
+ is EVAL, undef, "$desc : eval";
+}e;
+
+$var = 'a';
+$var =~ s{.}{UP}e;
+is $var, $top, 'subst : fake block';
+
+$var = 'a';
+$var =~ s{.}{do { UP }}e;
+is $var, 2, 'subst : real block' unless $^P;
+
+SKIP: {
+ skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5)
+                                                                if "$]" < 5.010;
+
+ eval <<'TEST_GIVEN';
+  use feature 'switch';
+  my $desc = 'given';
+  my $base = HERE;
+  given (1) {
+   is HERE, $base + 2, "$desc : here" unless $^P;
+   is TOP,  $top,      "$desc : top";
+   is UP,   $base,     "$desc : up";
+   is SUB,  undef,     "$desc : sub";
+   is EVAL, $base,     "$desc : eval";
+  }
+TEST_GIVEN
+ diag $@ if $@;
+
+ eval <<'TEST_GIVEN_WHEN';
+  use feature 'switch';
+  my $desc = 'when in given';
+  my $base = HERE;
+  given (1) {
+   my $given = HERE;
+   when (1) {
+    is HERE, $base + 4, "$desc : here" unless $^P;
+    is TOP,  $top,      "$desc : top";
+    is UP,   $given,    "$desc : up";
+    is SUB,  undef,     "$desc : sub";
+    is EVAL, $base,     "$desc : eval";
+   }
+  }
+TEST_GIVEN_WHEN
+ diag $@ if $@;
+
+ eval <<'TEST_GIVEN_DEFAULT';
+  use feature 'switch';
+  my $desc = 'default in given';
+  my $base = HERE;
+  given (1) {
+   my $given = HERE;
+   default {
+    is HERE, $base + 4, "$desc : here" unless $^P;
+    is TOP,  $top,      "$desc : top";
+    is UP,   $given,    "$desc : up";
+    is SUB,  undef,     "$desc : sub";
+    is EVAL, $base,     "$desc : eval";
+   }
+  }
+TEST_GIVEN_DEFAULT
+ diag $@ if $@;
+
+ eval <<'TEST_FOR_WHEN';
+  use feature 'switch';
+  my $desc = 'when in for';
+  my $base = HERE;
+  for (1) {
+   my $loop = HERE;
+   when (1) {
+    is HERE, $base + 3, "$desc : here" unless $^P;
+    is TOP,  $top,      "$desc : top";
+    is UP,   $loop,     "$desc : up";
+    is SUB,  undef,     "$desc : sub";
+    is EVAL, $base,     "$desc : eval";
+   }
+  }
+TEST_FOR_WHEN
+ diag $@ if $@;
+}
+
+SKIP: {
+ skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
+
+ my $base = HERE;
+
+ do {
+  eval {
+   do {
+    sub {
+     eval q[
+      {
+       is HERE,           $base + 6, 'mixed : here';
+       is TOP,            $top,      'mixed : top';
+       is SUB,            $base + 4, 'mixed : first sub';
+       is SUB(SUB),       $base + 4, 'mixed : still first sub';
+       is EVAL,           $base + 5, 'mixed : first eval';
+       is EVAL(EVAL),     $base + 5, 'mixed : still first eval';
+       is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
+      }
+     ];
+    }->();
+   }
+  };
+ } while (0);
+}
+
 {
- is SCOPE,    1, 'block : scope';
- is SCOPE(0), 1, 'block : scope 0';
- is SCOPE(1), 0, 'block : scope 1';
- is CALLER,    0, 'block: caller';
- is CALLER(0), 0, 'block : caller 0';
- is CALLER(1), 0, 'block : caller 1';
+ my $block = HERE;
+ is SCOPE,     $block, 'block : scope';
+ is SCOPE(0),  $block, 'block : scope 0';
+ is SCOPE(1),  $top,   'block : scope 1';
+ is CALLER,    $top,   'block : caller';
+ is CALLER(0), $top,   'block : caller 0';
+ is CALLER(1), $top,   'block : caller 1';
  sub {
-  is SCOPE,    2, 'block sub : scope';
-  is SCOPE(0), 2, 'block sub : scope 0';
-  is SCOPE(1), 1, 'block sub : scope 1';
-  is CALLER,    2, 'block sub : caller';
-  is CALLER(0), 2, 'block sub : caller 0';
-  is CALLER(1), 0, 'block sub : caller 1';
+  my $sub = HERE;
+  is SCOPE,     $sub,   'block sub : scope';
+  is SCOPE(0),  $sub,   'block sub : scope 0';
+  is SCOPE(1),  $block, 'block sub : scope 1';
+  is CALLER,    $sub,   'block sub : caller';
+  is CALLER(0), $sub,   'block sub : caller 0';
+  is CALLER(1), $top,   'block sub : caller 1';
   for (1) {
-   is SCOPE,    3, 'block sub for : scope';
-   is SCOPE(0), 3, 'block sub for : scope 0';
-   is SCOPE(1), 2, 'block sub for : scope 1';
-   is CALLER,    2, 'block sub for : caller';
-   is CALLER(0), 2, 'block sub for : caller 0';
-   is CALLER(1), 0, 'block sub for : caller 1';
+   my $loop = HERE;
+   is SCOPE,     $loop,  'block sub for : scope';
+   is SCOPE(0),  $loop,  'block sub for : scope 0';
+   is SCOPE(1),  $sub,   'block sub for : scope 1';
+   is SCOPE(2),  $block, 'block sub for : scope 2';
+   is CALLER,    $sub,   'block sub for : caller';
+   is CALLER(0), $sub,   'block sub for : caller 0';
+   is CALLER(1), $top,   'block sub for : caller 1';
+   is CALLER(2), $top,   'block sub for : caller 2';
    eval {
-    is SCOPE,    4, 'block sub for eval : scope';
-    is SCOPE(0), 4, 'block sub for eval : scope 0';
-    is SCOPE(1), 3, 'block sub for eval : scope 1';
-    is SCOPE(2), 2, 'block sub for eval : scope 2';
-    is CALLER,    4, 'block sub for eval : caller';
-    is CALLER(0), 4, 'block sub for eval : caller 0';
-    is CALLER(1), 2, 'block sub for eval : caller 1';
-    is CALLER(2), 0, 'block sub for eval : caller 2';
+    my $eval = HERE;
+    is SCOPE,     $eval,  'block sub for eval : scope';
+    is SCOPE(0),  $eval,  'block sub for eval : scope 0';
+    is SCOPE(1),  $loop,  'block sub for eval : scope 1';
+    is SCOPE(2),  $sub,   'block sub for eval : scope 2';
+    is SCOPE(3),  $block, 'block sub for eval : scope 3';
+    is CALLER,    $eval,  'block sub for eval : caller';
+    is CALLER(0), $eval,  'block sub for eval : caller 0';
+    is CALLER(1), $sub,   'block sub for eval : caller 1';
+    is CALLER(2), $top,   'block sub for eval : caller 2';
+    is CALLER(3), $top,   'block sub for eval : caller 3';
    }
   }
  }->();