Warn when the words target a context outside of the current stack

Note that the check is done when the target context is defined and not
when the helpers use it.

This fixes RT #104751.

diff --git a/Upper.xs b/Upper.xs
index 928fdfd28295a098bdf1fc69cbcf065d787d70df..a002eac9a3c976727316ee64f6b8c7f344020bb2 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -256,6 +256,10 @@ static U8 su_op_gimme_reverse(U8 gimme) {
 # define MY_CXT_CLONE NOOP
 #endif
 
+/* --- Error messages ------------------------------------------------------ */
+
+static const char su_stack_smash[] = "Cannot target a scope outside of the current stack";
+
 /* --- Unique context ID global storage ------------------------------------ */
 
 /* ... Sequence ID counter ................................................. */
@@ -2586,6 +2590,8 @@ PPCODE:
   --cxix;
   cxix = su_context_skip_db(cxix);
   cxix = su_context_normalize_up(cxix);
+ } else {
+  warn(su_stack_smash);
  }
  EXTEND(SP, 1);
  mPUSHi(cxix);
@@ -2642,8 +2648,10 @@ PPCODE:
  SU_GET_LEVEL(0, 0);
  cxix = su_context_here();
  while (--level >= 0) {
-  if (cxix <= 0)
+  if (cxix <= 0) {
+   warn(su_stack_smash);
    break;
+  }
   --cxix;
   cxix = su_context_skip_db(cxix);
   cxix = su_context_normalize_up(cxix);
@@ -2673,6 +2681,8 @@ PPCODE:
   }
  }
 done:
+ if (level >= 0)
+  warn(su_stack_smash);
  EXTEND(SP, 1);
  mPUSHi(cxix);
  XSRETURN(1);

diff --git a/t/05-words.t b/t/05-words.t
index 6971da61f9a1130a507f3302a1c880b76cd97ee3..18aca6c56700638306e18a6d1f10a8310f25ccc3 100644 (file)
--- a/t/05-words.t
+++ b/t/05-words.t
@@ -5,20 +5,32 @@ use warnings;
 
 use Test::More;
 
-plan tests => 23 * ($^P ? 4 : 5) + ($^P ? 1 : 3) + 7 + 15 * 2;
+plan tests => 1 + 23 * ($^P ? 4 : 5) + ($^P ? 1 : 3) + 7 + (32 + 7);
 
 use Scope::Upper qw<:words>;
 
 # 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.
 
+our $got_warn;
+my $warn_catcher = sub {
+ my $file = __FILE__;
+ ++$got_warn if $_[0] =~ /^Cannot target a scope outside of the current stack at \Q$file\E line \d+\.$/;
+ return;
+};
+my $old_sig_warn;
+
 my $top = HERE;
 
-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 $top, 0,      'main : here' unless $^P;
+is TOP,  $top,   'main : top';
+$old_sig_warn = $SIG{__WARN__};
+local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
+is UP,  $top,    'main : up';
+local $SIG{__WARN__} = $old_sig_warn;
+is $got_warn, 1, 'main : up warns';
+is SUB,  undef,  'main : sub';
+is EVAL, undef,  'main : eval';
 
 {
  my $desc = '{ 1 }';
@@ -330,27 +342,47 @@ SKIP: {
  is SCOPE,     $block, 'block : scope';
  is SCOPE(0),  $block, 'block : scope 0';
  is SCOPE(1),  $top,   'block : scope 1';
+ $old_sig_warn = $SIG{__WARN__};
+ local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
+ is SCOPE(2),  $top,   'block : scope 2';
+ is $got_warn, 1,      'block : scope 2 warns';
+ local $got_warn;
  is CALLER,    $top,   'block : caller';
+ is $got_warn, 1,      'block : caller warns';
+ local $got_warn;
  is CALLER(0), $top,   'block : caller 0';
+ is $got_warn, 1,      'block : caller 0 warns';
+ local $got_warn;
  is CALLER(1), $top,   'block : caller 1';
+ is $got_warn, 1,      'block : caller 1 warns';
+ local $SIG{__WARN__} = $old_sig_warn;
  sub {
   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 SCOPE(2),  $top,   'block sub : scope 2';
   is CALLER,    $sub,   'block sub : caller';
   is CALLER(0), $sub,   'block sub : caller 0';
+  $old_sig_warn = $SIG{__WARN__};
+  local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
   is CALLER(1), $top,   'block sub : caller 1';
+  local $SIG{__WARN__} = $old_sig_warn;
+  is $got_warn, 1,      'block sub : caller 1 warns';
   for (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 SCOPE(3),  $top,   'block sub for : scope 3';
    is CALLER,    $sub,   'block sub for : caller';
    is CALLER(0), $sub,   'block sub for : caller 0';
+   $old_sig_warn = $SIG{__WARN__};
+   local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
    is CALLER(1), $top,   'block sub for : caller 1';
-   is CALLER(2), $top,   'block sub for : caller 2';
+   local $SIG{__WARN__} = $old_sig_warn;
+   is $got_warn, 1,      'block sub for : caller 1 warns';
    eval {
     my $eval = HERE;
     is SCOPE,     $eval,  'block sub for eval : scope';
@@ -358,11 +390,15 @@ SKIP: {
     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 SCOPE(4),  $top,   'block sub for eval : scope 4';
     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';
+    $old_sig_warn = $SIG{__WARN__};
+    local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
     is CALLER(2), $top,   'block sub for eval : caller 2';
-    is CALLER(3), $top,   'block sub for eval : caller 3';
+    local $SIG{__WARN__} = $old_sig_warn;
+    is $got_warn, 1,      'block sub for eval : caller 2 warns';
    }
   }
  }->();

diff --git a/t/06-want_at.t b/t/06-want_at.t
index 12df3f0d7ded69f826c4a89a7214ee5493ae6f77..540acda988492e21f86d13931a9dd0b1748d103f 100644 (file)
--- a/t/06-want_at.t
+++ b/t/06-want_at.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 19;
+use Test::More tests => 18;
 
 use Scope::Upper qw<want_at UP HERE>;
 
@@ -26,7 +26,6 @@ my $w;
 
 check want_at,       undef, 'main : want_at';
 check want_at(HERE), undef, 'main : want_at HERE';
-check want_at(UP),   undef, 'main : want_at UP';
 check want_at(-1),   undef, 'main : want_at -1';
 
 my @a = sub {

diff --git a/t/07-context_info.t b/t/07-context_info.t
index b32dba7670e39b963cad919597136f3fafa77b6c..5dbfa45bdfb01f72b3280f81592217b8106cab48 100644 (file)
--- a/t/07-context_info.t
+++ b/t/07-context_info.t
@@ -12,7 +12,7 @@ use Config qw<%Config>;
 # change ; and that doesn't fit well with how we're testing things.
 
 use lib 't/lib';
-use Test::Leaner tests => 19 + 6;
+use Test::Leaner tests => 18 + 6;
 
 use Scope::Upper qw<context_info UP HERE CALLER>;
 
@@ -80,7 +80,6 @@ sub setup () {
 
 is_deeply [ context_info       ], $exp0, 'main : context_info';
 is_deeply [ context_info(HERE) ], $exp0, 'main : context_info HERE';
-is_deeply [ context_info(UP)   ], $exp0, 'main : context_info UP';
 is_deeply [ context_info(-1)   ], $exp0, 'main : context_info -1';
 
 package Scope::Upper::TestPkg::A; BEGIN { ::setup }