X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2F05-words.t;h=18aca6c56700638306e18a6d1f10a8310f25ccc3;hb=6e6aa503ec0f8dc6f7c01ac956f57d34eb1f7eda;hp=b1d1467161c5db82c906353a8a45bd11e01c69da;hpb=da0237ee151a65dff50933a7af535ea0541c2ac2;p=perl%2Fmodules%2FScope-Upper.git diff --git a/t/05-words.t b/t/05-words.t index b1d1467..18aca6c 100644 --- a/t/05-words.t +++ b/t/05-words.t @@ -3,91 +3,402 @@ use strict; use warnings; -use Test::More tests => 42; +use Test::More; -use Scope::Upper qw/:words/; +plan tests => 1 + 23 * ($^P ? 4 : 5) + ($^P ? 1 : 3) + 7 + (32 + 7); -is HERE, 0, 'main : here'; -is TOP, 0, 'main : top'; -is UP, 0, 'main : up'; -is SUB, undef, 'main : sub'; -is EVAL, undef, 'main : eval'; +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'; +$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'; { - 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, 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 $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, 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 { - 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, 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; + +$var = 'a'; +$var =~ s{.}{UP}e; +is $var, $top, 'subst : fake block'; + +$var = 'a'; +$var =~ s{.}{do { UP }}e; +is $var, 1, 'subst : do block optimized away' unless $^P; + +$var = 'a'; +$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) + if "$]" < 5.010; + + eval <<'TEST_GIVEN'; + BEGIN { + if ("$]" >= 5.017_011) { + require warnings; + warnings->unimport('experimental::smartmatch'); + } + } + use feature 'switch'; + 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"; + } +TEST_GIVEN + diag $@ if $@; + + eval <<'TEST_GIVEN_WHEN'; + BEGIN { + if ("$]" >= 5.017_011) { + require warnings; + warnings->unimport('experimental::smartmatch'); + } + } + use feature 'switch'; + my $desc = 'when in given'; + my $base = HERE; + 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"; + } + } +TEST_GIVEN_WHEN + diag $@ if $@; + + eval <<'TEST_GIVEN_DEFAULT'; + BEGIN { + if ("$]" >= 5.017_011) { + require warnings; + warnings->unimport('experimental::smartmatch'); + } + } + use feature 'switch'; + my $desc = 'default in given'; + my $base = HERE; + 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"; + } + } +TEST_GIVEN_DEFAULT + diag $@ if $@; + + eval <<'TEST_FOR_WHEN'; + BEGIN { + if ("$]" >= 5.017_011) { + require warnings; + warnings->unimport('experimental::smartmatch'); + } + } + use feature 'switch'; + my $desc = 'when in for'; + my $base = HERE; + 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"; + } + } +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 CALLER, 0, '{ } : caller'; - is CALLER(0), 0, '{ } : caller 0'; - is CALLER(1), 0, '{ } : caller 1'; + my $block = HERE; + 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 { - is CALLER, 2, '{ sub { } } : caller'; - is CALLER(0), 2, '{ sub { } } : caller 0'; - is CALLER(1), 0, '{ 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 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) { - is CALLER, 2, '{ sub { for { } } } : caller'; - is CALLER(0), 2, '{ sub { for { } } } : caller 0'; - is CALLER(1), 0, '{ 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 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__} = $old_sig_warn; + is $got_warn, 1, 'block sub for : caller 1 warns'; eval { - is CALLER, 4, '{ sub { for { eval { } } } } : caller'; - is CALLER(0), 4, '{ sub { for { eval { } } } } : caller 0'; - is CALLER(1), 2, '{ sub { for { eval { } } } } : caller 1'; - is CALLER(2), 0, '{ 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 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__} = $old_sig_warn; + is $got_warn, 1, 'block sub for eval : caller 2 warns'; } } }->();