From: Vincent Pit Date: Mon, 3 Aug 2015 16:00:08 +0000 (-0300) Subject: Warn when the words target a context outside of the current stack X-Git-Tag: rt104751^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=6e6aa503ec0f8dc6f7c01ac956f57d34eb1f7eda 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 928fdfd..a002eac 100644 --- 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 6971da6..18aca6c 100644 --- 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 12df3f0..540acda 100644 --- 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; @@ -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 b32dba7..5dbfa45 100644 --- 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; @@ -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 }