From: Vincent Pit Date: Mon, 3 Aug 2015 16:52:20 +0000 (-0300) Subject: Also warn when SUB() and EVAL() cannot find an appropriate target X-Git-Tag: v0.28~15 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=2e30a0f24d9b8f169ec974af21051e098a7d9516;p=perl%2Fmodules%2FScope-Upper.git Also warn when SUB() and EVAL() cannot find an appropriate target --- diff --git a/Upper.xs b/Upper.xs index a002eac..0e36df1 100644 --- a/Upper.xs +++ b/Upper.xs @@ -258,7 +258,8 @@ static U8 su_op_gimme_reverse(U8 gimme) { /* --- Error messages ------------------------------------------------------ */ -static const char su_stack_smash[] = "Cannot target a scope outside of the current stack"; +static const char su_stack_smash[] = "Cannot target a scope outside of the current stack"; +static const char su_no_such_target[] = "No targetable %s scope in the current stack"; /* --- Unique context ID global storage ------------------------------------ */ @@ -2617,6 +2618,7 @@ PPCODE: XSRETURN(1); } } + warn(su_no_such_target, "subroutine"); XSRETURN_UNDEF; void @@ -2637,6 +2639,7 @@ PPCODE: XSRETURN(1); } } + warn(su_no_such_target, "eval"); XSRETURN_UNDEF; void diff --git a/t/05-words.t b/t/05-words.t index 18aca6c..9fe39ff 100644 --- a/t/05-words.t +++ b/t/05-words.t @@ -5,78 +5,121 @@ use warnings; use Test::More; -plan tests => 1 + 23 * ($^P ? 4 : 5) + ($^P ? 1 : 3) + 7 + (32 + 7); +plan tests => 23 * ($^P ? 4 : 5) + 40 + ($^P ? 1 : 3) + 7 + (32 + 7) + 1; 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 $stray_warnings = 0; +local $SIG{__WARN__} = sub { + ++$stray_warnings; + warn(@_); +}; + +our @warns; 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+\.$/; + my $what; + if ($_[0] =~ /^Cannot target a scope outside of the current stack at /) { + $what = 'smash'; + } elsif ($_[0] =~ /^No targetable (subroutine|eval) scope in the current stack at /) { + $what = $1; + } + if (defined $what) { + push @warns, $what; + } else { + warn(@_); + } return; }; my $old_sig_warn; my $top = HERE; -is $top, 0, 'main : here' unless $^P; -is TOP, $top, 'main : top'; +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__}, @warns) = $warn_catcher; +is UP, $top, 'main : up'; +is "@warns", 'smash', 'main : up warns'; +local @warns; +is SUB, undef, 'main : sub'; +is "@warns", 'subroutine', 'main : sub warns'; +local @warns; +is EVAL, undef, 'main : eval'; +is "@warns", 'eval', 'main : eval warns'; 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 }'; - 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } do { 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; }; 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local $SIG{__WARN__} = $old_sig_warn; + is EVAL, HERE, "$desc : eval"; }; diag $@ if $@; eval q[ 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local $SIG{__WARN__} = $old_sig_warn; + is EVAL, HERE, "$desc : eval"; ]; diag $@ if $@; sub { 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + is SUB, HERE, "$desc : sub"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; }->(); my $true = 1; @@ -84,126 +127,204 @@ 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } for (1) { 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } for (my $i = 0; $i < 1; ++$i) { my $desc = 'for (;;) { 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } my @list = (1); while (my $thing = shift @list) { my $desc = 'while (my $thing = ...) { 2 }'; - 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } do { 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } 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"; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; } 1; my $var = 'a'; -$var =~ s{.}{ +$var =~ s[.][ my $desc = 'subst'; - 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"; -}e; + is HERE, 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $top, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local @warns; + is EVAL, undef, "$desc : eval"; + is "@warns", 'eval', "$desc : eval warns"; + local $SIG{__WARN__} = $old_sig_warn; +]e; $var = 'a'; $var =~ s{.}{UP}e; @@ -218,7 +339,7 @@ $var =~ s{.}{do { my $x; UP }}e; is $var, 1, 'subst : do block preserved' unless $^P; SKIP: { - skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5) + skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5) + 4 if "$]" < 5.010; eval <<'TEST_GIVEN'; @@ -232,11 +353,15 @@ SKIP: { my $desc = 'given'; my $base = HERE; given (1) { - is HERE, $base + 1, "$desc : here" unless $^P; - is TOP, $top, "$desc : top"; - is UP, $base, "$desc : up"; - is SUB, undef, "$desc : sub"; - is EVAL, $base, "$desc : eval"; + is HERE, $base + 1, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $base, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local $SIG{__WARN__} = $old_sig_warn; + is EVAL, $base, "$desc : eval"; } TEST_GIVEN diag $@ if $@; @@ -254,11 +379,15 @@ TEST_GIVEN given (1) { my $given = HERE; when (1) { - is HERE, $base + 3, "$desc : here" unless $^P; - is TOP, $top, "$desc : top"; - is UP, $given, "$desc : up"; - is SUB, undef, "$desc : sub"; - is EVAL, $base, "$desc : eval"; + is HERE, $base + 3, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $given, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local $SIG{__WARN__} = $old_sig_warn; + is EVAL, $base, "$desc : eval"; } } TEST_GIVEN_WHEN @@ -277,11 +406,15 @@ TEST_GIVEN_WHEN given (1) { my $given = HERE; default { - is HERE, $base + 3, "$desc : here" unless $^P; - is TOP, $top, "$desc : top"; - is UP, $given, "$desc : up"; - is SUB, undef, "$desc : sub"; - is EVAL, $base, "$desc : eval"; + is HERE, $base + 3, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $given, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local $SIG{__WARN__} = $old_sig_warn; + is EVAL, $base, "$desc : eval"; } } TEST_GIVEN_DEFAULT @@ -300,11 +433,15 @@ TEST_GIVEN_DEFAULT for (1) { my $loop = HERE; when (1) { - is HERE, $base + 2, "$desc : here" unless $^P; - is TOP, $top, "$desc : top"; - is UP, $loop, "$desc : up"; - is SUB, undef, "$desc : sub"; - is EVAL, $base, "$desc : eval"; + is HERE, $base + 2, "$desc : here" unless $^P; + is TOP, $top, "$desc : top"; + is UP, $loop, "$desc : up"; + $old_sig_warn = $SIG{__WARN__}; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is SUB, undef, "$desc : sub"; + is "@warns", 'subroutine', "$desc : sub warns"; + local $SIG{__WARN__} = $old_sig_warn; + is EVAL, $base, "$desc : eval"; } } TEST_FOR_WHEN @@ -339,67 +476,69 @@ SKIP: { { my $block = HERE; - is SCOPE, $block, 'block : scope'; - is SCOPE(0), $block, 'block : scope 0'; - is SCOPE(1), $top, 'block : scope 1'; + 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__}, @warns) = $warn_catcher; + is SCOPE(2), $top, 'block : scope 2'; + is "@warns", 'smash', 'block : scope 2 warns'; + local @warns; + is CALLER, $top, 'block : caller'; + is "@warns", 'smash', 'block : caller warns'; + local @warns; + is CALLER(0), $top, 'block : caller 0'; + is "@warns", 'smash', 'block : caller 0 warns'; + local @warns; + is CALLER(1), $top, 'block : caller 1'; + is "@warns", 'smash', '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'; + 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__}, @warns) = $warn_catcher; + is CALLER(1), $top, 'block sub : caller 1'; + is "@warns", 'smash', 'block sub : caller 1 warns'; 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'; + 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'; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is CALLER(1), $top, 'block sub for : caller 1'; + is "@warns", 'smash', 'block sub for : caller 1 warns'; 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'; - 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 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'; + 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 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'; + local ($SIG{__WARN__}, @warns) = $warn_catcher; + is CALLER(2), $top, 'block sub for eval : caller 2'; + is "@warns", 'smash', 'block sub for eval : caller 2 warns'; local $SIG{__WARN__} = $old_sig_warn; - is $got_warn, 1, 'block sub for eval : caller 2 warns'; } } }->(); } + +is $stray_warnings, 0, 'no stray warnings';