From e150f77d7d47f85e37d9512e2695dafc13548453 Mon Sep 17 00:00:00 2001 From: James E Keenan Date: Tue, 5 Mar 2013 22:37:48 -0500 Subject: Moved t/cmd/lexsub.t, t/cmd/while.t to t/op; split t/cmd/for.t to two pieces, one in t/op/for.t. Update and sort MANIFEST. From work done at NY Perl Hackathon by Charlie Gonzalez and Taqqai Karim. For: RT #116615 --- AUTHORS | 2 + MANIFEST | 5 +- t/cmd/for.t | 575 +---------------------------------------------- t/cmd/lexsub.t | 690 --------------------------------------------------------- t/cmd/while.t | 215 ------------------ t/op/for.t | 565 ++++++++++++++++++++++++++++++++++++++++++++++ t/op/lexsub.t | 677 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ t/op/while.t | 215 ++++++++++++++++++ 8 files changed, 1463 insertions(+), 1481 deletions(-) delete mode 100644 t/cmd/lexsub.t delete mode 100644 t/cmd/while.t create mode 100644 t/op/for.t create mode 100644 t/op/lexsub.t create mode 100644 t/op/while.t diff --git a/AUTHORS b/AUTHORS index 9a33f7a1aa..851e4df3de 100644 --- a/AUTHORS +++ b/AUTHORS @@ -193,6 +193,7 @@ Charles F. Randall Charles Lane Charles Randall Charles Wilson +Charlie Gonzalez Chas. Owens Chaskiel M Grundman Chia-liang Kao @@ -808,6 +809,7 @@ Milosz Tanski Milton L. Hankins Moritz Lenz Moshe Kaminsky +Mottaqui Karim taqqui.karim@gmail.com Mr. Nobody Murray Nesbitt Nathan Kurz diff --git a/MANIFEST b/MANIFEST index fe37f65a94..45fe093b07 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5050,11 +5050,9 @@ t/bigmem/read.t Check read() handles large offsets t/bigmem/vec.t Check vec() handles large offsets t/cmd/elsif.t See if else-if works t/cmd/for.t See if for loops work -t/cmd/lexsub.t See if lexical subroutines work t/cmd/mod.t See if statement modifiers work t/cmd/subval.t See if subroutine values work t/cmd/switch.t See if switch optimizations work -t/cmd/while.t See if while loops work t/comp/bproto.t See if builtins conform to their prototypes t/comp/cmdopt.t See if command optimization works t/comp/colon.t See if colons are parsed correctly @@ -5336,6 +5334,7 @@ t/op/filetest.t See if file tests work t/op/filetest_t.t See if -t file test works t/op/flip.t See if range operator works t/op/fork.t See if fork works +t/op/for.t See if for loops work t/op/fresh_perl_utf8.t UTF8 tests for pads and gvs t/op/getpid.t See if $$ and getppid work with threads t/op/getppid.t See if getppid works @@ -5365,6 +5364,7 @@ t/op/lc.t See if lc, uc, lcfirst, ucfirst, quotemeta work t/op/leaky-magic.t See whether vars' magic leaks into packages t/op/length.t See if length works t/op/lex_assign.t See if ops involving lexicals or pad temps work +t/op/lexsub.t See if lexical subroutines work t/op/lex.t Tests too complex for t/base/lex.t t/op/lfs.t See if large files work for perlio t/op/list.t See if array lists work @@ -5465,6 +5465,7 @@ t/op/vec.t See if vectors work t/op/ver.t See if v-strings and the %v format flag work t/op/wantarray.t See if wantarray works t/op/warn.t See if warn works +t/op/while.t See if while loops work t/op/write.t See if write works (formats work) t/op/yadayada.t See if ... works t/perl.supp Perl valgrind suppressions diff --git a/t/cmd/for.t b/t/cmd/for.t index 184d024fbc..27fb5a2517 100644 --- a/t/cmd/for.t +++ b/t/cmd/for.t @@ -1,6 +1,6 @@ #!./perl -print "1..118\n"; +print "1..14\n"; for ($i = 0; $i <= 10; $i++) { $x[$i] = $i; @@ -95,576 +95,3 @@ print $@ =~ /Use of freed value in iteration/ ? "ok" : "not ok", " 13\n"; print $x == 1 ? "ok" : "not ok", " 14 - double destroy, x=$x\n"; } -# A lot of tests to check that reversed for works. -my $test = 14; -sub is { - my ($got, $expected, $name) = @_; - ++$test; - if ($got eq $expected) { - print "ok $test # $name\n"; - return 1; - } - print "not ok $test # $name\n"; - print "# got '$got', expected '$expected'\n"; - return 0; -} - -@array = ('A', 'B', 'C'); -for (@array) { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for array'); -$r = ''; -for (1,2,3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list'); -$r = ''; -for (map {$_} @array) { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for array via map'); -$r = ''; -for (map {$_} 1,2,3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list via map'); -$r = ''; -for (1 .. 3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list via ..'); -$r = ''; -for ('A' .. 'C') { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for list via ..'); - -$r = ''; -for (reverse @array) { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for array'); -$r = ''; -for (reverse 1,2,3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list'); -$r = ''; -for (reverse map {$_} @array) { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for array via map'); -$r = ''; -for (reverse map {$_} 1,2,3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list via map'); -$r = ''; -for (reverse 1 .. 3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list via ..'); -$r = ''; -for (reverse 'A' .. 'C') { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for list via ..'); - -$r = ''; -for my $i (@array) { - $r .= $i; -} -is ($r, 'ABC', 'Forwards for array with var'); -$r = ''; -for my $i (1,2,3) { - $r .= $i; -} -is ($r, '123', 'Forwards for list with var'); -$r = ''; -for my $i (map {$_} @array) { - $r .= $i; -} -is ($r, 'ABC', 'Forwards for array via map with var'); -$r = ''; -for my $i (map {$_} 1,2,3) { - $r .= $i; -} -is ($r, '123', 'Forwards for list via map with var'); -$r = ''; -for my $i (1 .. 3) { - $r .= $i; -} -is ($r, '123', 'Forwards for list via .. with var'); -$r = ''; -for my $i ('A' .. 'C') { - $r .= $i; -} -is ($r, 'ABC', 'Forwards for list via .. with var'); - -$r = ''; -for my $i (reverse @array) { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for array with var'); -$r = ''; -for my $i (reverse 1,2,3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list with var'); -$r = ''; -for my $i (reverse map {$_} @array) { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for array via map with var'); -$r = ''; -for my $i (reverse map {$_} 1,2,3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list via map with var'); -$r = ''; -for my $i (reverse 1 .. 3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list via .. with var'); -$r = ''; -for my $i (reverse 'A' .. 'C') { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for list via .. with var'); - -# For some reason the generate optree is different when $_ is implicit. -$r = ''; -for $_ (@array) { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for array with explicit $_'); -$r = ''; -for $_ (1,2,3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list with explicit $_'); -$r = ''; -for $_ (map {$_} @array) { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for array via map with explicit $_'); -$r = ''; -for $_ (map {$_} 1,2,3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list via map with explicit $_'); -$r = ''; -for $_ (1 .. 3) { - $r .= $_; -} -is ($r, '123', 'Forwards for list via .. with var with explicit $_'); -$r = ''; -for $_ ('A' .. 'C') { - $r .= $_; -} -is ($r, 'ABC', 'Forwards for list via .. with var with explicit $_'); - -$r = ''; -for $_ (reverse @array) { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for array with explicit $_'); -$r = ''; -for $_ (reverse 1,2,3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list with explicit $_'); -$r = ''; -for $_ (reverse map {$_} @array) { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for array via map with explicit $_'); -$r = ''; -for $_ (reverse map {$_} 1,2,3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list via map with explicit $_'); -$r = ''; -for $_ (reverse 1 .. 3) { - $r .= $_; -} -is ($r, '321', 'Reverse for list via .. with var with explicit $_'); -$r = ''; -for $_ (reverse 'A' .. 'C') { - $r .= $_; -} -is ($r, 'CBA', 'Reverse for list via .. with var with explicit $_'); - -# I don't think that my is that different from our in the optree. But test a -# few: -$r = ''; -for our $i (reverse @array) { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for array with our var'); -$r = ''; -for our $i (reverse 1,2,3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list with our var'); -$r = ''; -for our $i (reverse map {$_} @array) { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for array via map with our var'); -$r = ''; -for our $i (reverse map {$_} 1,2,3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list via map with our var'); -$r = ''; -for our $i (reverse 1 .. 3) { - $r .= $i; -} -is ($r, '321', 'Reverse for list via .. with our var'); -$r = ''; -for our $i (reverse 'A' .. 'C') { - $r .= $i; -} -is ($r, 'CBA', 'Reverse for list via .. with our var'); - - -$r = ''; -for (1, reverse @array) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array with leading value'); -$r = ''; -for ('A', reverse 1,2,3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list with leading value'); -$r = ''; -for (1, reverse map {$_} @array) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array via map with leading value'); -$r = ''; -for ('A', reverse map {$_} 1,2,3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list via map with leading value'); -$r = ''; -for ('A', reverse 1 .. 3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list via .. with leading value'); -$r = ''; -for (1, reverse 'A' .. 'C') { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for list via .. with leading value'); - -$r = ''; -for (reverse (@array), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for array with trailing value'); -$r = ''; -for (reverse (1,2,3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list with trailing value'); -$r = ''; -for (reverse (map {$_} @array), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for array via map with trailing value'); -$r = ''; -for (reverse (map {$_} 1,2,3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list via map with trailing value'); -$r = ''; -for (reverse (1 .. 3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list via .. with trailing value'); -$r = ''; -for (reverse ('A' .. 'C'), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for list via .. with trailing value'); - - -$r = ''; -for $_ (1, reverse @array) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array with leading value with explicit $_'); -$r = ''; -for $_ ('A', reverse 1,2,3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list with leading value with explicit $_'); -$r = ''; -for $_ (1, reverse map {$_} @array) { - $r .= $_; -} -is ($r, '1CBA', - 'Reverse for array via map with leading value with explicit $_'); -$r = ''; -for $_ ('A', reverse map {$_} 1,2,3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list via map with leading value with explicit $_'); -$r = ''; -for $_ ('A', reverse 1 .. 3) { - $r .= $_; -} -is ($r, 'A321', 'Reverse for list via .. with leading value with explicit $_'); -$r = ''; -for $_ (1, reverse 'A' .. 'C') { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for list via .. with leading value with explicit $_'); - -$r = ''; -for $_ (reverse (@array), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for array with trailing value with explicit $_'); -$r = ''; -for $_ (reverse (1,2,3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list with trailing value with explicit $_'); -$r = ''; -for $_ (reverse (map {$_} @array), 1) { - $r .= $_; -} -is ($r, 'CBA1', - 'Reverse for array via map with trailing value with explicit $_'); -$r = ''; -for $_ (reverse (map {$_} 1,2,3), 'A') { - $r .= $_; -} -is ($r, '321A', - 'Reverse for list via map with trailing value with explicit $_'); -$r = ''; -for $_ (reverse (1 .. 3), 'A') { - $r .= $_; -} -is ($r, '321A', 'Reverse for list via .. with trailing value with explicit $_'); -$r = ''; -for $_ (reverse ('A' .. 'C'), 1) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for list via .. with trailing value with explicit $_'); - -$r = ''; -for my $i (1, reverse @array) { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for array with leading value and var'); -$r = ''; -for my $i ('A', reverse 1,2,3) { - $r .= $i; -} -is ($r, 'A321', 'Reverse for list with leading value and var'); -$r = ''; -for my $i (1, reverse map {$_} @array) { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for array via map with leading value and var'); -$r = ''; -for my $i ('A', reverse map {$_} 1,2,3) { - $r .= $i; -} -is ($r, 'A321', 'Reverse for list via map with leading value and var'); -$r = ''; -for my $i ('A', reverse 1 .. 3) { - $r .= $i; -} -is ($r, 'A321', 'Reverse for list via .. with leading value and var'); -$r = ''; -for my $i (1, reverse 'A' .. 'C') { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for list via .. with leading value and var'); - -$r = ''; -for my $i (reverse (@array), 1) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for array with trailing value and var'); -$r = ''; -for my $i (reverse (1,2,3), 'A') { - $r .= $i; -} -is ($r, '321A', 'Reverse for list with trailing value and var'); -$r = ''; -for my $i (reverse (map {$_} @array), 1) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for array via map with trailing value and var'); -$r = ''; -for my $i (reverse (map {$_} 1,2,3), 'A') { - $r .= $i; -} -is ($r, '321A', 'Reverse for list via map with trailing value and var'); -$r = ''; -for my $i (reverse (1 .. 3), 'A') { - $r .= $i; -} -is ($r, '321A', 'Reverse for list via .. with trailing value and var'); -$r = ''; -for my $i (reverse ('A' .. 'C'), 1) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for list via .. with trailing value and var'); - - -$r = ''; -for (reverse 1, @array) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for value and array'); -$r = ''; -for (reverse map {$_} 1, @array) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for value and array via map'); -$r = ''; -for (reverse 1 .. 3, @array) { - $r .= $_; -} -is ($r, 'CBA321', 'Reverse for .. and array'); -$r = ''; -for (reverse 'X' .. 'Z', @array) { - $r .= $_; -} -is ($r, 'CBAZYX', 'Reverse for .. and array'); -$r = ''; -for (reverse map {$_} 1 .. 3, @array) { - $r .= $_; -} -is ($r, 'CBA321', 'Reverse for .. and array via map'); -$r = ''; -for (reverse map {$_} 'X' .. 'Z', @array) { - $r .= $_; -} -is ($r, 'CBAZYX', 'Reverse for .. and array via map'); - -$r = ''; -for (reverse (@array, 1)) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array and value'); -$r = ''; -for (reverse (map {$_} @array, 1)) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array and value via map'); - -$r = ''; -for $_ (reverse 1, @array) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for value and array with explicit $_'); -$r = ''; -for $_ (reverse map {$_} 1, @array) { - $r .= $_; -} -is ($r, 'CBA1', 'Reverse for value and array via map with explicit $_'); -$r = ''; -for $_ (reverse 1 .. 3, @array) { - $r .= $_; -} -is ($r, 'CBA321', 'Reverse for .. and array with explicit $_'); -$r = ''; -for $_ (reverse 'X' .. 'Z', @array) { - $r .= $_; -} -is ($r, 'CBAZYX', 'Reverse for .. and array with explicit $_'); -$r = ''; -for $_ (reverse map {$_} 1 .. 3, @array) { - $r .= $_; -} -is ($r, 'CBA321', 'Reverse for .. and array via map with explicit $_'); -$r = ''; -for $_ (reverse map {$_} 'X' .. 'Z', @array) { - $r .= $_; -} -is ($r, 'CBAZYX', 'Reverse for .. and array via map with explicit $_'); - -$r = ''; -for $_ (reverse (@array, 1)) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array and value with explicit $_'); -$r = ''; -for $_ (reverse (map {$_} @array, 1)) { - $r .= $_; -} -is ($r, '1CBA', 'Reverse for array and value via map with explicit $_'); - - -$r = ''; -for my $i (reverse 1, @array) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for value and array with var'); -$r = ''; -for my $i (reverse map {$_} 1, @array) { - $r .= $i; -} -is ($r, 'CBA1', 'Reverse for value and array via map with var'); -$r = ''; -for my $i (reverse 1 .. 3, @array) { - $r .= $i; -} -is ($r, 'CBA321', 'Reverse for .. and array with var'); -$r = ''; -for my $i (reverse 'X' .. 'Z', @array) { - $r .= $i; -} -is ($r, 'CBAZYX', 'Reverse for .. and array with var'); -$r = ''; -for my $i (reverse map {$_} 1 .. 3, @array) { - $r .= $i; -} -is ($r, 'CBA321', 'Reverse for .. and array via map with var'); -$r = ''; -for my $i (reverse map {$_} 'X' .. 'Z', @array) { - $r .= $i; -} -is ($r, 'CBAZYX', 'Reverse for .. and array via map with var'); - -$r = ''; -for my $i (reverse (@array, 1)) { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for array and value with var'); -$r = ''; -for my $i (reverse (map {$_} @array, 1)) { - $r .= $i; -} -is ($r, '1CBA', 'Reverse for array and value via map with var'); - -TODO: { - $test++; - local $TODO = "RT #1085: what should be output of perl -we 'print do { foreach (1, 2) { 1; } }'"; - if (do {17; foreach (1, 2) { 1; } } != 17) { - print "not "; - } - print "ok $test # TODO $TODO\n"; -} - -TODO: { - $test++; - no warnings 'reserved'; - local $TODO = "RT #2166: foreach spuriously autovivifies"; - my %h; - foreach (@h{a, b}) {} - if(keys(%h)) { - print "not "; - } - print "ok $test # TODO $TODO\n"; -} diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t deleted file mode 100644 index 46bab038fd..0000000000 --- a/t/cmd/lexsub.t +++ /dev/null @@ -1,690 +0,0 @@ -#!perl - -BEGIN { - chdir 't'; - @INC = '../lib'; - require './test.pl'; - *bar::is = *is; - *bar::like = *like; -} -no warnings 'deprecated'; -BEGIN{plan 133;} - -# -------------------- Errors with feature disabled -------------------- # - -eval "#line 8 foo\nmy sub foo"; -is $@, qq 'Experimental "my" subs not enabled at foo line 8.\n', - 'my sub unexperimental error'; -eval "#line 8 foo\nCORE::state sub foo"; -is $@, qq 'Experimental "state" subs not enabled at foo line 8.\n', - 'state sub unexperimental error'; -eval "#line 8 foo\nour sub foo"; -is $@, qq 'Experimental "our" subs not enabled at foo line 8.\n', - 'our sub unexperimental error'; - -# -------------------- our -------------------- # - -no warnings "experimental::lexical_subs"; -use feature 'lexical_subs'; -{ - our sub foo { 42 } - is foo, 42, 'calling our sub from same package'; - is &foo, 42, 'calling our sub from same package (amper)'; - is do foo(), 42, 'calling our sub from same package (do)'; - package bar; - sub bar::foo { 43 } - is foo, 42, 'calling our sub from another package'; - is &foo, 42, 'calling our sub from another package (amper)'; - is do foo(), 42, 'calling our sub from another package (do)'; -} -package bar; -is foo, 43, 'our sub falling out of scope'; -is &foo, 43, 'our sub falling out of scope (called via amper)'; -is do foo(), 43, 'our sub falling out of scope (called via amper)'; -package main; -{ - sub bar::a { 43 } - our sub a { - if (shift) { - package bar; - is a, 43, 'our sub invisible inside itself'; - is &a, 43, 'our sub invisible inside itself (called via amper)'; - is do a(), 43, 'our sub invisible inside itself (called via do)'; - } - 42 - } - a(1); - sub bar::b { 43 } - our sub b; - our sub b { - if (shift) { - package bar; - is b, 42, 'our sub visible inside itself after decl'; - is &b, 42, 'our sub visible inside itself after decl (amper)'; - is do b(), 42, 'our sub visible inside itself after decl (do)'; - } - 42 - } - b(1) -} -sub c { 42 } -sub bar::c { 43 } -{ - our sub c; - package bar; - is c, 42, 'our sub foo; makes lex alias for existing sub'; - is &c, 42, 'our sub foo; makes lex alias for existing sub (amper)'; - is do c(), 42, 'our sub foo; makes lex alias for existing sub (do)'; -} -{ - our sub d; - sub bar::d { 'd43' } - package bar; - sub d { 'd42' } - is eval ::d, 'd42', 'our sub foo; applies to subsequent sub foo {}'; -} -{ - our sub e ($); - is prototype "::e", '$', 'our sub with proto'; -} -{ - our sub if() { 42 } - my $x = if if if; - is $x, 42, 'lexical subs (even our) override all keywords'; - package bar; - my $y = if if if; - is $y, 42, 'our subs from other packages override all keywords'; -} -# Make sure errors don't pollute the stash (see RT 116981) -{ - eval "our sub ln99{!} ln99(1)"; - eval "ln99(1)"; - like $@, "Undefined subroutine &main::ln99 called", "Bad definitions do not pollute the stash"; - isnt $::{ln99}, -1, "No placeholder was entered"; - our sub ln103; - is $::{ln103}, -1, "Placeholder was entered"; - eval "our sub ln103{!} ln103(1)"; - eval "ln103(1)"; - like $@, "Undefined subroutine &main::ln103 called", "Bad definitions do not pollute the stash"; - isnt $::{ln103}, -1, "Placeholder was removed"; -} - -# -------------------- state -------------------- # - -use feature 'state'; # state -{ - state sub foo { 44 } - isnt \&::foo, \&foo, 'state sub is not stored in the package'; - is eval foo, 44, 'calling state sub from same package'; - is eval &foo, 44, 'calling state sub from same package (amper)'; - is eval do foo(), 44, 'calling state sub from same package (do)'; - package bar; - is eval foo, 44, 'calling state sub from another package'; - is eval &foo, 44, 'calling state sub from another package (amper)'; - is eval do foo(), 44, 'calling state sub from another package (do)'; -} -package bar; -is foo, 43, 'state sub falling out of scope'; -is &foo, 43, 'state sub falling out of scope (called via amper)'; -is do foo(), 43, 'state sub falling out of scope (called via amper)'; -{ - sub sa { 43 } - state sub sa { - if (shift) { - is sa, 43, 'state sub invisible inside itself'; - is &sa, 43, 'state sub invisible inside itself (called via amper)'; - is do sa(), 43, 'state sub invisible inside itself (called via do)'; - } - 44 - } - sa(1); - sub sb { 43 } - state sub sb; - state sub sb { - if (shift) { - # ‘state sub foo{}’ creates a new pad entry, not reusing the forward - # declaration. Being invisible inside itself, it sees the stub. - eval{sb}; - like $@, qr/^Undefined subroutine &sb called at /, - 'state sub foo {} after forward declaration'; - eval{&sb}; - like $@, qr/^Undefined subroutine &sb called at /, - 'state sub foo {} after forward declaration (amper)'; - eval{do sb()}; - like $@, qr/^Undefined subroutine &sb called at /, - 'state sub foo {} after forward declaration (do)'; - } - 44 - } - sb(1); - sub sb2 { 43 } - state sub sb2; - sub sb2 { - if (shift) { - package bar; - is sb2, 44, 'state sub visible inside itself after decl'; - is &sb2, 44, 'state sub visible inside itself after decl (amper)'; - is do sb2(), 44, 'state sub visible inside itself after decl (do)'; - } - 44 - } - sb2(1); - state sub sb3; - { - state sub sb3 { # new pad entry - # The sub containing this comment is invisible inside itself. - # So this one here will assign to the outer pad entry: - sub sb3 { 47 } - } - } - is eval{sb3}, 47, - 'sub foo{} applying to "state sub foo;" even inside state sub foo{}'; - # Same test again, but inside an anonymous sub - sub { - state sub sb4; - { - state sub sb4 { - sub sb4 { 47 } - } - } - is sb4, 47, - 'sub foo{} applying to "state sub foo;" even inside state sub foo{}'; - }->(); -} -sub sc { 43 } -{ - state sub sc; - eval{sc}; - like $@, qr/^Undefined subroutine &sc called at /, - 'state sub foo; makes no lex alias for existing sub'; - eval{&sc}; - like $@, qr/^Undefined subroutine &sc called at /, - 'state sub foo; makes no lex alias for existing sub (amper)'; - eval{do sc()}; - like $@, qr/^Undefined subroutine &sc called at /, - 'state sub foo; makes no lex alias for existing sub (do)'; -} -package main; -{ - state sub se ($); - is prototype eval{\&se}, '$', 'state sub with proto'; - is prototype "se", undef, 'prototype "..." ignores state subs'; -} -{ - state sub if() { 44 } - my $x = if if if; - is $x, 44, 'state subs override all keywords'; - package bar; - my $y = if if if; - is $y, 44, 'state subs from other packages override all keywords'; -} -{ - use warnings; no warnings "experimental::lexical_subs"; - state $w ; - local $SIG{__WARN__} = sub { $w .= shift }; - eval '#line 87 squidges - state sub foo; - state sub foo {}; - '; - is $w, - '"state" subroutine &foo masks earlier declaration in same scope at ' - . "squidges line 88.\n", - 'warning for state sub masking earlier declaration'; -} -# Since state vars inside anonymous subs are cloned at the same time as the -# anonymous subs containing them, the same should happen for state subs. -sub make_closure { - my $x = shift; - sub { - state sub foo { $x } - foo - } -} -$sub1 = make_closure 48; -$sub2 = make_closure 49; -is &$sub1, 48, 'state sub in closure (1)'; -is &$sub2, 49, 'state sub in closure (2)'; -# But we need to test that state subs actually do persist from one invoca- -# tion of a named sub to another (i.e., that they are not my subs). -{ - use warnings; no warnings "experimental::lexical_subs"; - state $w; - local $SIG{__WARN__} = sub { $w .= shift }; - eval '#line 65 teetet - sub foom { - my $x = shift; - state sub poom { $x } - eval{\&poom} - } - '; - is $w, "Variable \"\$x\" will not stay shared at teetet line 67.\n", - 'state subs get "Variable will not stay shared" messages'; - my $poom = foom(27); - my $poom2 = foom(678); - is eval{$poom->()}, eval {$poom2->()}, - 'state subs close over the first outer my var, like pkg subs'; - my $x = 43; - for $x (765) { - state sub etetetet { $x } - is eval{etetetet}, 43, 'state sub ignores for() localisation'; - } -} -# And we also need to test that multiple state subs can close over each -# other’s entries in the parent subs pad, and that cv_clone is not con- -# fused by that. -sub make_anon_with_state_sub{ - sub { - state sub s1; - state sub s2 { \&s1 } - sub s1 { \&s2 } - if (@_) { return \&s1 } - is s1,\&s2, 'state sub in anon closure closing over sibling state sub'; - is s2,\&s1, 'state sub in anon closure closing over sibling state sub'; - } -} -{ - my $s = make_anon_with_state_sub; - &$s; - - # And make sure the state subs were actually cloned. - isnt make_anon_with_state_sub->(0), &$s(0), - 'state subs in anon subs are cloned'; - is &$s(0), &$s(0), 'but only when the anon sub is cloned'; -} -{ - state sub BEGIN { exit }; - pass 'state subs are never special blocks'; - state sub END { shift } - is eval{END('jkqeudth')}, jkqeudth, - 'state sub END {shift} implies @_, not @ARGV'; -} -{ - state sub redef {} - use warnings; no warnings "experimental::lexical_subs"; - state $w; - local $SIG{__WARN__} = sub { $w .= shift }; - eval "#line 56 pygpyf\nsub redef {}"; - is $w, "Subroutine redef redefined at pygpyf line 56.\n", - "sub redefinition warnings from state subs"; -} -{ - state sub p (\@) { - is ref $_[0], 'ARRAY', 'state sub with proto'; - } - p(my @a); -} -{ - state sub x; - eval 'sub x {3}'; - is x, 3, 'state sub defined inside eval'; - - sub r { - state sub foo { 3 }; - if (@_) { # outer call - r(); - is foo(), 42, - 'state sub run-time redefinition applies to all recursion levels'; - } - else { # inner call - eval 'sub foo { 42 }'; - } - } - r(1); -} - -# -------------------- my -------------------- # - -{ - my sub foo { 44 } - isnt \&::foo, \&foo, 'my sub is not stored in the package'; - is foo, 44, 'calling my sub from same package'; - is &foo, 44, 'calling my sub from same package (amper)'; - is do foo(), 44, 'calling my sub from same package (do)'; - package bar; - is foo, 44, 'calling my sub from another package'; - is &foo, 44, 'calling my sub from another package (amper)'; - is do foo(), 44, 'calling my sub from another package (do)'; -} -package bar; -is foo, 43, 'my sub falling out of scope'; -is &foo, 43, 'my sub falling out of scope (called via amper)'; -is do foo(), 43, 'my sub falling out of scope (called via amper)'; -{ - sub ma { 43 } - my sub ma { - if (shift) { - is ma, 43, 'my sub invisible inside itself'; - is &ma, 43, 'my sub invisible inside itself (called via amper)'; - is do ma(), 43, 'my sub invisible inside itself (called via do)'; - } - 44 - } - ma(1); - sub mb { 43 } - my sub mb; - my sub mb { - if (shift) { - # ‘my sub foo{}’ creates a new pad entry, not reusing the forward - # declaration. Being invisible inside itself, it sees the stub. - eval{mb}; - like $@, qr/^Undefined subroutine &mb called at /, - 'my sub foo {} after forward declaration'; - eval{&mb}; - like $@, qr/^Undefined subroutine &mb called at /, - 'my sub foo {} after forward declaration (amper)'; - eval{do mb()}; - like $@, qr/^Undefined subroutine &mb called at /, - 'my sub foo {} after forward declaration (do)'; - } - 44 - } - mb(1); - sub mb2 { 43 } - my sub sb2; - sub mb2 { - if (shift) { - package bar; - is mb2, 44, 'my sub visible inside itself after decl'; - is &mb2, 44, 'my sub visible inside itself after decl (amper)'; - is do mb2(), 44, 'my sub visible inside itself after decl (do)'; - } - 44 - } - mb2(1); - my sub mb3; - { - my sub mb3 { # new pad entry - # The sub containing this comment is invisible inside itself. - # So this one here will assign to the outer pad entry: - sub mb3 { 47 } - } - } - is eval{mb3}, 47, - 'sub foo{} applying to "my sub foo;" even inside my sub foo{}'; - # Same test again, but inside an anonymous sub - sub { - my sub mb4; - { - my sub mb4 { - sub mb4 { 47 } - } - } - is mb4, 47, - 'sub foo{} applying to "my sub foo;" even inside my sub foo{}'; - }->(); -} -sub mc { 43 } -{ - my sub mc; - eval{mc}; - like $@, qr/^Undefined subroutine &mc called at /, - 'my sub foo; makes no lex alias for existing sub'; - eval{&mc}; - like $@, qr/^Undefined subroutine &mc called at /, - 'my sub foo; makes no lex alias for existing sub (amper)'; - eval{do mc()}; - like $@, qr/^Undefined subroutine &mc called at /, - 'my sub foo; makes no lex alias for existing sub (do)'; -} -package main; -{ - my sub me ($); - is prototype eval{\&me}, '$', 'my sub with proto'; - is prototype "me", undef, 'prototype "..." ignores my subs'; -} -{ - my sub if() { 44 } - my $x = if if if; - is $x, 44, 'my subs override all keywords'; - package bar; - my $y = if if if; - is $y, 44, 'my subs from other packages override all keywords'; -} -{ - use warnings; no warnings "experimental::lexical_subs"; - my $w ; - local $SIG{__WARN__} = sub { $w .= shift }; - eval '#line 87 squidges - my sub foo; - my sub foo {}; - '; - is $w, - '"my" subroutine &foo masks earlier declaration in same scope at ' - . "squidges line 88.\n", - 'warning for my sub masking earlier declaration'; -} -# Test that my subs are cloned inside anonymous subs. -sub mmake_closure { - my $x = shift; - sub { - my sub foo { $x } - foo - } -} -$sub1 = mmake_closure 48; -$sub2 = mmake_closure 49; -is &$sub1, 48, 'my sub in closure (1)'; -is &$sub2, 49, 'my sub in closure (2)'; -# Test that they are cloned in named subs. -{ - use warnings; no warnings "experimental::lexical_subs"; - my $w; - local $SIG{__WARN__} = sub { $w .= shift }; - eval '#line 65 teetet - sub mfoom { - my $x = shift; - my sub poom { $x } - \&poom - } - '; - is $w, undef, 'my subs get no "Variable will not stay shared" messages'; - my $poom = mfoom(27); - my $poom2 = mfoom(678); - is $poom->(), 27, 'my subs closing over outer my var (1)'; - is $poom2->(), 678, 'my subs closing over outer my var (2)'; - my $x = 43; - my sub aoeu; - for $x (765) { - my sub etetetet { $x } - sub aoeu { $x } - is etetetet, 765, 'my sub respects for() localisation'; - is aoeu, 43, 'unless it is declared outside the for loop'; - } -} -# And we also need to test that multiple my subs can close over each -# other’s entries in the parent subs pad, and that cv_clone is not con- -# fused by that. -sub make_anon_with_my_sub{ - sub { - my sub s1; - my sub s2 { \&s1 } - sub s1 { \&s2 } - if (@_) { return eval { \&s1 } } - is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub'; - is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub'; - } -} - -# Test my subs inside predeclared my subs -{ - my sub s2; - sub s2 { - my $x = 3; - my sub s3 { eval '$x' } - s3; - } - is s2, 3, 'my sub inside predeclared my sub'; -} - -{ - my $s = make_anon_with_my_sub; - &$s; - - # And make sure the my subs were actually cloned. - isnt make_anon_with_my_sub->(0), &$s(0), - 'my subs in anon subs are cloned'; - isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub'; -} -{ - my sub BEGIN { exit }; - pass 'my subs are never special blocks'; - my sub END { shift } - is END('jkqeudth'), jkqeudth, - 'my sub END {shift} implies @_, not @ARGV'; -} -{ - my sub redef {} - use warnings; no warnings "experimental::lexical_subs"; - my $w; - local $SIG{__WARN__} = sub { $w .= shift }; - eval "#line 56 pygpyf\nsub redef {}"; - is $w, "Subroutine redef redefined at pygpyf line 56.\n", - "sub redefinition warnings from my subs"; - - undef $w; - sub { - my sub x {}; - sub { eval "#line 87 khaki\n\\&x" } - }->()(); - is $w, "Subroutine \"&x\" is not available at khaki line 87.\n", - "unavailability warning during compilation of eval in closure"; - - undef $w; - no warnings 'void'; - eval <<'->()();'; -#line 87 khaki - sub { - my sub x{} - sub not_lexical8 { - \&x - } - } -->()(); - is $w, "Subroutine \"&x\" is not available at khaki line 90.\n", - "unavailability warning during compilation of named sub in anon"; - - undef $w; - sub not_lexical9 { - my sub x {}; - format = -@ -&x -. - } - eval { write }; - my($f,$l) = (__FILE__,__LINE__ - 1); - is $w, "Subroutine \"&x\" is not available at $f line $l.\n", - 'unavailability warning during cloning'; - $l -= 3; - is $@, "Undefined subroutine &x called at $f line $l.\n", - 'Vivified sub is correctly named'; -} -sub not_lexical10 { - my sub foo; - foo(); - sub not_lexical11 { - my sub bar { - my $x = 'khaki car keys for the khaki car'; - not_lexical10(); - sub foo { - is $x, 'khaki car keys for the khaki car', - 'mysubs in inner clonables use the running clone of their CvOUTSIDE' - } - } - bar() - } -} -not_lexical11(); -{ - my sub p (\@) { - is ref $_[0], 'ARRAY', 'my sub with proto'; - } - p(my @a); -} -{ - my sub x; - my $count; - sub x { x() if $count++ < 10 } - x(); - is $count, 11, 'my recursive subs'; -} -{ - my sub x; - eval 'sub x {3}'; - is x, 3, 'my sub defined inside eval'; -} - -{ - state $w; - local $SIG{__WARN__} = sub { $w .= shift }; - eval q{ my sub george () { 2 } }; - is $w, undef, 'no double free from constant my subs'; -} - -# -------------------- Interactions (and misc tests) -------------------- # - -is sub { - my sub s1; - my sub s2 { 3 }; - sub s1 { state sub foo { \&s2 } foo } - s1 - }->()(), 3, 'state sub inside my sub closing over my sub uncle'; - -{ - my sub s2 { 3 }; - sub not_lexical { state sub foo { \&s2 } foo } - is not_lexical->(), 3, 'state subs that reference my sub from outside'; -} - -# Test my subs inside predeclared package subs -# This test also checks that CvOUTSIDE pointers are not mangled when the -# inner sub’s CvOUTSIDE points to another sub. -sub not_lexical2; -sub not_lexical2 { - my $x = 23; - my sub bar; - sub not_lexical3 { - not_lexical2(); - sub bar { $x } - }; - bar -} -is not_lexical3, 23, 'my subs inside predeclared package subs'; - -# Test my subs inside predeclared package sub, where the lexical sub is -# declared outside the package sub. -# This checks that CvOUTSIDE pointers are fixed up even when the sub is -# not declared inside the sub that its CvOUTSIDE points to. -sub not_lexical5 { - my sub foo; - sub not_lexical4; - sub not_lexical4 { - my $x = 234; - not_lexical5(); - sub foo { $x } - } - foo -} -is not_lexical4, 234, - 'my sub defined in predeclared pkg sub but declared outside'; - -undef *not_lexical6; -{ - my sub foo; - sub not_lexical6 { sub foo { } } - pass 'no crash when cloning a mysub declared inside an undef pack sub'; -} - -undef ¬_lexical7; -eval 'sub not_lexical7 { my @x }'; -{ - my sub foo; - foo(); - sub not_lexical7 { - state $x; - sub foo { - is ref \$x, 'SCALAR', - "redeffing a mysub's outside does not make it use the wrong pad" - } - } -} diff --git a/t/cmd/while.t b/t/cmd/while.t deleted file mode 100644 index 5d2af711a5..0000000000 --- a/t/cmd/while.t +++ /dev/null @@ -1,215 +0,0 @@ -#!./perl - -BEGIN { - chdir 't'; - require "test.pl"; -} - -plan(25); - -my $tmpfile = tempfile(); -open (tmp,'>', $tmpfile) || die "Can't create Cmd_while.tmp."; -print tmp "tvi925\n"; -print tmp "tvi920\n"; -print tmp "vt100\n"; -print tmp "Amiga\n"; -print tmp "paper\n"; -close tmp or die "Could not close: $!"; - -# test "last" command - -open(fh, $tmpfile) || die "Can't open Cmd_while.tmp."; -while () { - last if /vt100/; -} -ok(!eof && /vt100/); - -# test "next" command - -$bad = ''; -open(fh, $tmpfile) || die "Can't open Cmd_while.tmp."; -while () { - next if /vt100/; - $bad = 1 if /vt100/; -} -ok(eof && !/vt100/ && !$bad); - -# test "redo" command - -$bad = ''; -open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; -while () { - if (s/vt100/VT100/g) { - s/VT100/Vt100/g; - redo; - } - $bad = 1 if /vt100/; - $bad = 1 if /VT100/; -} -ok(eof && !$bad); - -# now do the same with a label and a continue block - -# test "last" command - -$badcont = ''; -open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; -line: while () { - if (/vt100/) {last line;} -} continue { - $badcont = 1 if /vt100/; -} -ok(!eof && /vt100/); -ok(!$badcont); - -# test "next" command - -$bad = ''; -$badcont = 1; -open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; -entry: while () { - next entry if /vt100/; - $bad = 1 if /vt100/; -} continue { - $badcont = '' if /vt100/; -} -ok(eof && !/vt100/ && !$bad); -ok(!$badcont); - -# test "redo" command - -$bad = ''; -$badcont = ''; -open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; -loop: while () { - if (s/vt100/VT100/g) { - s/VT100/Vt100/g; - redo loop; - } - $bad = 1 if /vt100/; - $bad = 1 if /VT100/; -} continue { - $badcont = 1 if /vt100/; -} -ok(eof && !$bad); -ok(!$badcont); - -close(fh) || die "Can't close Cmd_while.tmp."; - -$i = 9; -{ - $i++; -} -is($i, 10); - -# Check curpm is reset when jumping out of a scope -$i = 0; -'abc' =~ /b/; -WHILE: -while (1) { - $i++; - is($` . $& . $', "abc"); - { # Localize changes to $` and friends - 'end' =~ /end/; - redo WHILE if $i == 1; - next WHILE if $i == 2; - # 3 do a normal loop - last WHILE if $i == 4; - } -} -is($` . $& . $', "abc"); - -# check that scope cleanup happens right when there's a continue block -{ - my $var = 16; - my (@got_var, @got_i); - while (my $i = ++$var) { - next if $i == 17; - last if $i > 17; - my $i = 0; - } - continue { - ($got_var, $got_i) = ($var, $i); - } - is($got_var, 17); - is($got_i, 17); -} - -{ - my $got_l; - local $l = 18; - { - local $l = 0 - } - continue { - $got_l = $l; - } - is($got_l, 18); -} - -{ - my $got_l; - local $l = 19; - my $x = 0; - while (!$x++) { - local $l = 0 - } - continue { - $got_l = $l; - } - is($got_l, $l); -} - -{ - my $ok = 1; - $i = 20; - while (1) { - my $x; - $ok = 0 if defined $x; - if ($i == 21) { - next; - } - last; - } - continue { - ++$i; - } - ok($ok); -} - -sub save_context { $_[0] = wantarray; $_[1] } - -{ - my $context = -1; - my $p = sub { - my $x = 1; - while ($x--) { - save_context($context, "foo"); - } - }; - is(scalar($p->()), 0); - is($context, undef, "last statement in while block has 'void' context"); -} - -{ - my $context = -1; - my $p = sub { - my $x = 1; - { - save_context($context, "foo"); - } - }; - is(scalar($p->()), "foo"); - is($context, "", "last statement in block has 'scalar' context"); -} - -{ - # test scope is cleaned - my $i = 0; - my @a; - while ($i++ < 2) { - my $x; - push @a, \$x; - } - ok($a[0] ne $a[1]); -} diff --git a/t/op/for.t b/t/op/for.t new file mode 100644 index 0000000000..93fe05e396 --- /dev/null +++ b/t/op/for.t @@ -0,0 +1,565 @@ +#!./perl + +BEGIN { + require "test.pl"; +} + +plan(104); + +# A lot of tests to check that reversed for works. +# my $test = 0; + +@array = ('A', 'B', 'C'); +for (@array) { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for array'); +$r = ''; +for (1,2,3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list'); +$r = ''; +for (map {$_} @array) { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for array via map'); +$r = ''; +for (map {$_} 1,2,3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list via map'); +$r = ''; +for (1 .. 3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list via ..'); +$r = ''; +for ('A' .. 'C') { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for list via ..'); + +$r = ''; +for (reverse @array) { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for array'); +$r = ''; +for (reverse 1,2,3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list'); +$r = ''; +for (reverse map {$_} @array) { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for array via map'); +$r = ''; +for (reverse map {$_} 1,2,3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list via map'); +$r = ''; +for (reverse 1 .. 3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list via ..'); +$r = ''; +for (reverse 'A' .. 'C') { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for list via ..'); + +$r = ''; +for my $i (@array) { + $r .= $i; +} +is ($r, 'ABC', 'Forwards for array with var'); +$r = ''; +for my $i (1,2,3) { + $r .= $i; +} +is ($r, '123', 'Forwards for list with var'); +$r = ''; +for my $i (map {$_} @array) { + $r .= $i; +} +is ($r, 'ABC', 'Forwards for array via map with var'); +$r = ''; +for my $i (map {$_} 1,2,3) { + $r .= $i; +} +is ($r, '123', 'Forwards for list via map with var'); +$r = ''; +for my $i (1 .. 3) { + $r .= $i; +} +is ($r, '123', 'Forwards for list via .. with var'); +$r = ''; +for my $i ('A' .. 'C') { + $r .= $i; +} +is ($r, 'ABC', 'Forwards for list via .. with var'); + +$r = ''; +for my $i (reverse @array) { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for array with var'); +$r = ''; +for my $i (reverse 1,2,3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list with var'); +$r = ''; +for my $i (reverse map {$_} @array) { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for array via map with var'); +$r = ''; +for my $i (reverse map {$_} 1,2,3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list via map with var'); +$r = ''; +for my $i (reverse 1 .. 3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list via .. with var'); +$r = ''; +for my $i (reverse 'A' .. 'C') { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for list via .. with var'); + +# For some reason the generate optree is different when $_ is implicit. +$r = ''; +for $_ (@array) { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for array with explicit $_'); +$r = ''; +for $_ (1,2,3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list with explicit $_'); +$r = ''; +for $_ (map {$_} @array) { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for array via map with explicit $_'); +$r = ''; +for $_ (map {$_} 1,2,3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list via map with explicit $_'); +$r = ''; +for $_ (1 .. 3) { + $r .= $_; +} +is ($r, '123', 'Forwards for list via .. with var with explicit $_'); +$r = ''; +for $_ ('A' .. 'C') { + $r .= $_; +} +is ($r, 'ABC', 'Forwards for list via .. with var with explicit $_'); + +$r = ''; +for $_ (reverse @array) { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for array with explicit $_'); +$r = ''; +for $_ (reverse 1,2,3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list with explicit $_'); +$r = ''; +for $_ (reverse map {$_} @array) { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for array via map with explicit $_'); +$r = ''; +for $_ (reverse map {$_} 1,2,3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list via map with explicit $_'); +$r = ''; +for $_ (reverse 1 .. 3) { + $r .= $_; +} +is ($r, '321', 'Reverse for list via .. with var with explicit $_'); +$r = ''; +for $_ (reverse 'A' .. 'C') { + $r .= $_; +} +is ($r, 'CBA', 'Reverse for list via .. with var with explicit $_'); + +# I don't think that my is that different from our in the optree. But test a +# few: +$r = ''; +for our $i (reverse @array) { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for array with our var'); +$r = ''; +for our $i (reverse 1,2,3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list with our var'); +$r = ''; +for our $i (reverse map {$_} @array) { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for array via map with our var'); +$r = ''; +for our $i (reverse map {$_} 1,2,3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list via map with our var'); +$r = ''; +for our $i (reverse 1 .. 3) { + $r .= $i; +} +is ($r, '321', 'Reverse for list via .. with our var'); +$r = ''; +for our $i (reverse 'A' .. 'C') { + $r .= $i; +} +is ($r, 'CBA', 'Reverse for list via .. with our var'); + + +$r = ''; +for (1, reverse @array) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array with leading value'); +$r = ''; +for ('A', reverse 1,2,3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list with leading value'); +$r = ''; +for (1, reverse map {$_} @array) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array via map with leading value'); +$r = ''; +for ('A', reverse map {$_} 1,2,3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list via map with leading value'); +$r = ''; +for ('A', reverse 1 .. 3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list via .. with leading value'); +$r = ''; +for (1, reverse 'A' .. 'C') { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for list via .. with leading value'); + +$r = ''; +for (reverse (@array), 1) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for array with trailing value'); +$r = ''; +for (reverse (1,2,3), 'A') { + $r .= $_; +} +is ($r, '321A', 'Reverse for list with trailing value'); +$r = ''; +for (reverse (map {$_} @array), 1) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for array via map with trailing value'); +$r = ''; +for (reverse (map {$_} 1,2,3), 'A') { + $r .= $_; +} +is ($r, '321A', 'Reverse for list via map with trailing value'); +$r = ''; +for (reverse (1 .. 3), 'A') { + $r .= $_; +} +is ($r, '321A', 'Reverse for list via .. with trailing value'); +$r = ''; +for (reverse ('A' .. 'C'), 1) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for list via .. with trailing value'); + + +$r = ''; +for $_ (1, reverse @array) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array with leading value with explicit $_'); +$r = ''; +for $_ ('A', reverse 1,2,3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list with leading value with explicit $_'); +$r = ''; +for $_ (1, reverse map {$_} @array) { + $r .= $_; +} +is ($r, '1CBA', + 'Reverse for array via map with leading value with explicit $_'); +$r = ''; +for $_ ('A', reverse map {$_} 1,2,3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list via map with leading value with explicit $_'); +$r = ''; +for $_ ('A', reverse 1 .. 3) { + $r .= $_; +} +is ($r, 'A321', 'Reverse for list via .. with leading value with explicit $_'); +$r = ''; +for $_ (1, reverse 'A' .. 'C') { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for list via .. with leading value with explicit $_'); + +$r = ''; +for $_ (reverse (@array), 1) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for array with trailing value with explicit $_'); +$r = ''; +for $_ (reverse (1,2,3), 'A') { + $r .= $_; +} +is ($r, '321A', 'Reverse for list with trailing value with explicit $_'); +$r = ''; +for $_ (reverse (map {$_} @array), 1) { + $r .= $_; +} +is ($r, 'CBA1', + 'Reverse for array via map with trailing value with explicit $_'); +$r = ''; +for $_ (reverse (map {$_} 1,2,3), 'A') { + $r .= $_; +} +is ($r, '321A', + 'Reverse for list via map with trailing value with explicit $_'); +$r = ''; +for $_ (reverse (1 .. 3), 'A') { + $r .= $_; +} +is ($r, '321A', 'Reverse for list via .. with trailing value with explicit $_'); +$r = ''; +for $_ (reverse ('A' .. 'C'), 1) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for list via .. with trailing value with explicit $_'); + +$r = ''; +for my $i (1, reverse @array) { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for array with leading value and var'); +$r = ''; +for my $i ('A', reverse 1,2,3) { + $r .= $i; +} +is ($r, 'A321', 'Reverse for list with leading value and var'); +$r = ''; +for my $i (1, reverse map {$_} @array) { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for array via map with leading value and var'); +$r = ''; +for my $i ('A', reverse map {$_} 1,2,3) { + $r .= $i; +} +is ($r, 'A321', 'Reverse for list via map with leading value and var'); +$r = ''; +for my $i ('A', reverse 1 .. 3) { + $r .= $i; +} +is ($r, 'A321', 'Reverse for list via .. with leading value and var'); +$r = ''; +for my $i (1, reverse 'A' .. 'C') { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for list via .. with leading value and var'); + +$r = ''; +for my $i (reverse (@array), 1) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for array with trailing value and var'); +$r = ''; +for my $i (reverse (1,2,3), 'A') { + $r .= $i; +} +is ($r, '321A', 'Reverse for list with trailing value and var'); +$r = ''; +for my $i (reverse (map {$_} @array), 1) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for array via map with trailing value and var'); +$r = ''; +for my $i (reverse (map {$_} 1,2,3), 'A') { + $r .= $i; +} +is ($r, '321A', 'Reverse for list via map with trailing value and var'); +$r = ''; +for my $i (reverse (1 .. 3), 'A') { + $r .= $i; +} +is ($r, '321A', 'Reverse for list via .. with trailing value and var'); +$r = ''; +for my $i (reverse ('A' .. 'C'), 1) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for list via .. with trailing value and var'); + + +$r = ''; +for (reverse 1, @array) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for value and array'); +$r = ''; +for (reverse map {$_} 1, @array) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for value and array via map'); +$r = ''; +for (reverse 1 .. 3, @array) { + $r .= $_; +} +is ($r, 'CBA321', 'Reverse for .. and array'); +$r = ''; +for (reverse 'X' .. 'Z', @array) { + $r .= $_; +} +is ($r, 'CBAZYX', 'Reverse for .. and array'); +$r = ''; +for (reverse map {$_} 1 .. 3, @array) { + $r .= $_; +} +is ($r, 'CBA321', 'Reverse for .. and array via map'); +$r = ''; +for (reverse map {$_} 'X' .. 'Z', @array) { + $r .= $_; +} +is ($r, 'CBAZYX', 'Reverse for .. and array via map'); + +$r = ''; +for (reverse (@array, 1)) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array and value'); +$r = ''; +for (reverse (map {$_} @array, 1)) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array and value via map'); + +$r = ''; +for $_ (reverse 1, @array) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for value and array with explicit $_'); +$r = ''; +for $_ (reverse map {$_} 1, @array) { + $r .= $_; +} +is ($r, 'CBA1', 'Reverse for value and array via map with explicit $_'); +$r = ''; +for $_ (reverse 1 .. 3, @array) { + $r .= $_; +} +is ($r, 'CBA321', 'Reverse for .. and array with explicit $_'); +$r = ''; +for $_ (reverse 'X' .. 'Z', @array) { + $r .= $_; +} +is ($r, 'CBAZYX', 'Reverse for .. and array with explicit $_'); +$r = ''; +for $_ (reverse map {$_} 1 .. 3, @array) { + $r .= $_; +} +is ($r, 'CBA321', 'Reverse for .. and array via map with explicit $_'); +$r = ''; +for $_ (reverse map {$_} 'X' .. 'Z', @array) { + $r .= $_; +} +is ($r, 'CBAZYX', 'Reverse for .. and array via map with explicit $_'); + +$r = ''; +for $_ (reverse (@array, 1)) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array and value with explicit $_'); +$r = ''; +for $_ (reverse (map {$_} @array, 1)) { + $r .= $_; +} +is ($r, '1CBA', 'Reverse for array and value via map with explicit $_'); + + +$r = ''; +for my $i (reverse 1, @array) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for value and array with var'); +$r = ''; +for my $i (reverse map {$_} 1, @array) { + $r .= $i; +} +is ($r, 'CBA1', 'Reverse for value and array via map with var'); +$r = ''; +for my $i (reverse 1 .. 3, @array) { + $r .= $i; +} +is ($r, 'CBA321', 'Reverse for .. and array with var'); +$r = ''; +for my $i (reverse 'X' .. 'Z', @array) { + $r .= $i; +} +is ($r, 'CBAZYX', 'Reverse for .. and array with var'); +$r = ''; +for my $i (reverse map {$_} 1 .. 3, @array) { + $r .= $i; +} +is ($r, 'CBA321', 'Reverse for .. and array via map with var'); +$r = ''; +for my $i (reverse map {$_} 'X' .. 'Z', @array) { + $r .= $i; +} +is ($r, 'CBAZYX', 'Reverse for .. and array via map with var'); + +$r = ''; +for my $i (reverse (@array, 1)) { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for array and value with var'); +$r = ''; +for my $i (reverse (map {$_} @array, 1)) { + $r .= $i; +} +is ($r, '1CBA', 'Reverse for array and value via map with var'); + +TODO: { + if (do {17; foreach (1, 2) { 1; } } != 17) { + #print "not "; + todo_skip("RT #1085: what should be output of perl -we 'print do { foreach (1, 2) { 1; } }'"); + } +} + +TODO: { + local $TODO = "RT #2166: foreach spuriously autovivifies"; + my %h; + foreach (@h{a, b}) {} + if(keys(%h)) { + todo_skip("RT #2166: foreach spuriously autovivifies"); + } +} diff --git a/t/op/lexsub.t b/t/op/lexsub.t new file mode 100644 index 0000000000..86c7e26a14 --- /dev/null +++ b/t/op/lexsub.t @@ -0,0 +1,677 @@ +#!perl + +BEGIN { + chdir 't'; + @INC = '../lib'; + require './test.pl'; + *bar::is = *is; + *bar::like = *like; +} +no warnings 'deprecated'; +plan 128; + +# -------------------- Errors with feature disabled -------------------- # + +eval "#line 8 foo\nmy sub foo"; +is $@, qq 'Experimental "my" subs not enabled at foo line 8.\n', + 'my sub unexperimental error'; +eval "#line 8 foo\nCORE::state sub foo"; +is $@, qq 'Experimental "state" subs not enabled at foo line 8.\n', + 'state sub unexperimental error'; +eval "#line 8 foo\nour sub foo"; +is $@, qq 'Experimental "our" subs not enabled at foo line 8.\n', + 'our sub unexperimental error'; + +# -------------------- our -------------------- # + +no warnings "experimental::lexical_subs"; +use feature 'lexical_subs'; +{ + our sub foo { 42 } + is foo, 42, 'calling our sub from same package'; + is &foo, 42, 'calling our sub from same package (amper)'; + is do foo(), 42, 'calling our sub from same package (do)'; + package bar; + sub bar::foo { 43 } + is foo, 42, 'calling our sub from another package'; + is &foo, 42, 'calling our sub from another package (amper)'; + is do foo(), 42, 'calling our sub from another package (do)'; +} +package bar; +is foo, 43, 'our sub falling out of scope'; +is &foo, 43, 'our sub falling out of scope (called via amper)'; +is do foo(), 43, 'our sub falling out of scope (called via amper)'; +package main; +{ + sub bar::a { 43 } + our sub a { + if (shift) { + package bar; + is a, 43, 'our sub invisible inside itself'; + is &a, 43, 'our sub invisible inside itself (called via amper)'; + is do a(), 43, 'our sub invisible inside itself (called via do)'; + } + 42 + } + a(1); + sub bar::b { 43 } + our sub b; + our sub b { + if (shift) { + package bar; + is b, 42, 'our sub visible inside itself after decl'; + is &b, 42, 'our sub visible inside itself after decl (amper)'; + is do b(), 42, 'our sub visible inside itself after decl (do)'; + } + 42 + } + b(1) +} +sub c { 42 } +sub bar::c { 43 } +{ + our sub c; + package bar; + is c, 42, 'our sub foo; makes lex alias for existing sub'; + is &c, 42, 'our sub foo; makes lex alias for existing sub (amper)'; + is do c(), 42, 'our sub foo; makes lex alias for existing sub (do)'; +} +{ + our sub d; + sub bar::d { 'd43' } + package bar; + sub d { 'd42' } + is eval ::d, 'd42', 'our sub foo; applies to subsequent sub foo {}'; +} +{ + our sub e ($); + is prototype "::e", '$', 'our sub with proto'; +} +{ + our sub if() { 42 } + my $x = if if if; + is $x, 42, 'lexical subs (even our) override all keywords'; + package bar; + my $y = if if if; + is $y, 42, 'our subs from other packages override all keywords'; +} + +# -------------------- state -------------------- # + +use feature 'state'; # state +{ + state sub foo { 44 } + isnt \&::foo, \&foo, 'state sub is not stored in the package'; + is eval foo, 44, 'calling state sub from same package'; + is eval &foo, 44, 'calling state sub from same package (amper)'; + is eval do foo(), 44, 'calling state sub from same package (do)'; + package bar; + is eval foo, 44, 'calling state sub from another package'; + is eval &foo, 44, 'calling state sub from another package (amper)'; + is eval do foo(), 44, 'calling state sub from another package (do)'; +} +package bar; +is foo, 43, 'state sub falling out of scope'; +is &foo, 43, 'state sub falling out of scope (called via amper)'; +is do foo(), 43, 'state sub falling out of scope (called via amper)'; +{ + sub sa { 43 } + state sub sa { + if (shift) { + is sa, 43, 'state sub invisible inside itself'; + is &sa, 43, 'state sub invisible inside itself (called via amper)'; + is do sa(), 43, 'state sub invisible inside itself (called via do)'; + } + 44 + } + sa(1); + sub sb { 43 } + state sub sb; + state sub sb { + if (shift) { + # ‘state sub foo{}’ creates a new pad entry, not reusing the forward + # declaration. Being invisible inside itself, it sees the stub. + eval{sb}; + like $@, qr/^Undefined subroutine &sb called at /, + 'state sub foo {} after forward declaration'; + eval{&sb}; + like $@, qr/^Undefined subroutine &sb called at /, + 'state sub foo {} after forward declaration (amper)'; + eval{do sb()}; + like $@, qr/^Undefined subroutine &sb called at /, + 'state sub foo {} after forward declaration (do)'; + } + 44 + } + sb(1); + sub sb2 { 43 } + state sub sb2; + sub sb2 { + if (shift) { + package bar; + is sb2, 44, 'state sub visible inside itself after decl'; + is &sb2, 44, 'state sub visible inside itself after decl (amper)'; + is do sb2(), 44, 'state sub visible inside itself after decl (do)'; + } + 44 + } + sb2(1); + state sub sb3; + { + state sub sb3 { # new pad entry + # The sub containing this comment is invisible inside itself. + # So this one here will assign to the outer pad entry: + sub sb3 { 47 } + } + } + is eval{sb3}, 47, + 'sub foo{} applying to "state sub foo;" even inside state sub foo{}'; + # Same test again, but inside an anonymous sub + sub { + state sub sb4; + { + state sub sb4 { + sub sb4 { 47 } + } + } + is sb4, 47, + 'sub foo{} applying to "state sub foo;" even inside state sub foo{}'; + }->(); +} +sub sc { 43 } +{ + state sub sc; + eval{sc}; + like $@, qr/^Undefined subroutine &sc called at /, + 'state sub foo; makes no lex alias for existing sub'; + eval{&sc}; + like $@, qr/^Undefined subroutine &sc called at /, + 'state sub foo; makes no lex alias for existing sub (amper)'; + eval{do sc()}; + like $@, qr/^Undefined subroutine &sc called at /, + 'state sub foo; makes no lex alias for existing sub (do)'; +} +package main; +{ + state sub se ($); + is prototype eval{\&se}, '$', 'state sub with proto'; + is prototype "se", undef, 'prototype "..." ignores state subs'; +} +{ + state sub if() { 44 } + my $x = if if if; + is $x, 44, 'state subs override all keywords'; + package bar; + my $y = if if if; + is $y, 44, 'state subs from other packages override all keywords'; +} +{ + use warnings; no warnings "experimental::lexical_subs"; + state $w ; + local $SIG{__WARN__} = sub { $w .= shift }; + eval '#line 87 squidges + state sub foo; + state sub foo {}; + '; + is $w, + '"state" subroutine &foo masks earlier declaration in same scope at ' + . "squidges line 88.\n", + 'warning for state sub masking earlier declaration'; +} +# Since state vars inside anonymous subs are cloned at the same time as the +# anonymous subs containing them, the same should happen for state subs. +sub make_closure { + my $x = shift; + sub { + state sub foo { $x } + foo + } +} +$sub1 = make_closure 48; +$sub2 = make_closure 49; +is &$sub1, 48, 'state sub in closure (1)'; +is &$sub2, 49, 'state sub in closure (2)'; +# But we need to test that state subs actually do persist from one invoca- +# tion of a named sub to another (i.e., that they are not my subs). +{ + use warnings; no warnings "experimental::lexical_subs"; + state $w; + local $SIG{__WARN__} = sub { $w .= shift }; + eval '#line 65 teetet + sub foom { + my $x = shift; + state sub poom { $x } + eval{\&poom} + } + '; + is $w, "Variable \"\$x\" will not stay shared at teetet line 67.\n", + 'state subs get "Variable will not stay shared" messages'; + my $poom = foom(27); + my $poom2 = foom(678); + is eval{$poom->()}, eval {$poom2->()}, + 'state subs close over the first outer my var, like pkg subs'; + my $x = 43; + for $x (765) { + state sub etetetet { $x } + is eval{etetetet}, 43, 'state sub ignores for() localisation'; + } +} +# And we also need to test that multiple state subs can close over each +# other’s entries in the parent subs pad, and that cv_clone is not con- +# fused by that. +sub make_anon_with_state_sub{ + sub { + state sub s1; + state sub s2 { \&s1 } + sub s1 { \&s2 } + if (@_) { return \&s1 } + is s1,\&s2, 'state sub in anon closure closing over sibling state sub'; + is s2,\&s1, 'state sub in anon closure closing over sibling state sub'; + } +} +{ + my $s = make_anon_with_state_sub; + &$s; + + # And make sure the state subs were actually cloned. + isnt make_anon_with_state_sub->(0), &$s(0), + 'state subs in anon subs are cloned'; + is &$s(0), &$s(0), 'but only when the anon sub is cloned'; +} +{ + state sub BEGIN { exit }; + pass 'state subs are never special blocks'; + state sub END { shift } + is eval{END('jkqeudth')}, jkqeudth, + 'state sub END {shift} implies @_, not @ARGV'; +} +{ + state sub redef {} + use warnings; no warnings "experimental::lexical_subs"; + state $w; + local $SIG{__WARN__} = sub { $w .= shift }; + eval "#line 56 pygpyf\nsub redef {}"; + is $w, "Subroutine redef redefined at pygpyf line 56.\n", + "sub redefinition warnings from state subs"; +} +{ + state sub p (\@) { + is ref $_[0], 'ARRAY', 'state sub with proto'; + } + p(my @a); +} +{ + state sub x; + eval 'sub x {3}'; + is x, 3, 'state sub defined inside eval'; + + sub r { + state sub foo { 3 }; + if (@_) { # outer call + r(); + is foo(), 42, + 'state sub run-time redefinition applies to all recursion levels'; + } + else { # inner call + eval 'sub foo { 42 }'; + } + } + r(1); +} + +# -------------------- my -------------------- # + +{ + my sub foo { 44 } + isnt \&::foo, \&foo, 'my sub is not stored in the package'; + is foo, 44, 'calling my sub from same package'; + is &foo, 44, 'calling my sub from same package (amper)'; + is do foo(), 44, 'calling my sub from same package (do)'; + package bar; + is foo, 44, 'calling my sub from another package'; + is &foo, 44, 'calling my sub from another package (amper)'; + is do foo(), 44, 'calling my sub from another package (do)'; +} +package bar; +is foo, 43, 'my sub falling out of scope'; +is &foo, 43, 'my sub falling out of scope (called via amper)'; +is do foo(), 43, 'my sub falling out of scope (called via amper)'; +{ + sub ma { 43 } + my sub ma { + if (shift) { + is ma, 43, 'my sub invisible inside itself'; + is &ma, 43, 'my sub invisible inside itself (called via amper)'; + is do ma(), 43, 'my sub invisible inside itself (called via do)'; + } + 44 + } + ma(1); + sub mb { 43 } + my sub mb; + my sub mb { + if (shift) { + # ‘my sub foo{}’ creates a new pad entry, not reusing the forward + # declaration. Being invisible inside itself, it sees the stub. + eval{mb}; + like $@, qr/^Undefined subroutine &mb called at /, + 'my sub foo {} after forward declaration'; + eval{&mb}; + like $@, qr/^Undefined subroutine &mb called at /, + 'my sub foo {} after forward declaration (amper)'; + eval{do mb()}; + like $@, qr/^Undefined subroutine &mb called at /, + 'my sub foo {} after forward declaration (do)'; + } + 44 + } + mb(1); + sub mb2 { 43 } + my sub sb2; + sub mb2 { + if (shift) { + package bar; + is mb2, 44, 'my sub visible inside itself after decl'; + is &mb2, 44, 'my sub visible inside itself after decl (amper)'; + is do mb2(), 44, 'my sub visible inside itself after decl (do)'; + } + 44 + } + mb2(1); + my sub mb3; + { + my sub mb3 { # new pad entry + # The sub containing this comment is invisible inside itself. + # So this one here will assign to the outer pad entry: + sub mb3 { 47 } + } + } + is eval{mb3}, 47, + 'sub foo{} applying to "my sub foo;" even inside my sub foo{}'; + # Same test again, but inside an anonymous sub + sub { + my sub mb4; + { + my sub mb4 { + sub mb4 { 47 } + } + } + is mb4, 47, + 'sub foo{} applying to "my sub foo;" even inside my sub foo{}'; + }->(); +} +sub mc { 43 } +{ + my sub mc; + eval{mc}; + like $@, qr/^Undefined subroutine &mc called at /, + 'my sub foo; makes no lex alias for existing sub'; + eval{&mc}; + like $@, qr/^Undefined subroutine &mc called at /, + 'my sub foo; makes no lex alias for existing sub (amper)'; + eval{do mc()}; + like $@, qr/^Undefined subroutine &mc called at /, + 'my sub foo; makes no lex alias for existing sub (do)'; +} +package main; +{ + my sub me ($); + is prototype eval{\&me}, '$', 'my sub with proto'; + is prototype "me", undef, 'prototype "..." ignores my subs'; +} +{ + my sub if() { 44 } + my $x = if if if; + is $x, 44, 'my subs override all keywords'; + package bar; + my $y = if if if; + is $y, 44, 'my subs from other packages override all keywords'; +} +{ + use warnings; no warnings "experimental::lexical_subs"; + my $w ; + local $SIG{__WARN__} = sub { $w .= shift }; + eval '#line 87 squidges + my sub foo; + my sub foo {}; + '; + is $w, + '"my" subroutine &foo masks earlier declaration in same scope at ' + . "squidges line 88.\n", + 'warning for my sub masking earlier declaration'; +} +# Test that my subs are cloned inside anonymous subs. +sub mmake_closure { + my $x = shift; + sub { + my sub foo { $x } + foo + } +} +$sub1 = mmake_closure 48; +$sub2 = mmake_closure 49; +is &$sub1, 48, 'my sub in closure (1)'; +is &$sub2, 49, 'my sub in closure (2)'; +# Test that they are cloned in named subs. +{ + use warnings; no warnings "experimental::lexical_subs"; + my $w; + local $SIG{__WARN__} = sub { $w .= shift }; + eval '#line 65 teetet + sub mfoom { + my $x = shift; + my sub poom { $x } + \&poom + } + '; + is $w, undef, 'my subs get no "Variable will not stay shared" messages'; + my $poom = mfoom(27); + my $poom2 = mfoom(678); + is $poom->(), 27, 'my subs closing over outer my var (1)'; + is $poom2->(), 678, 'my subs closing over outer my var (2)'; + my $x = 43; + my sub aoeu; + for $x (765) { + my sub etetetet { $x } + sub aoeu { $x } + is etetetet, 765, 'my sub respects for() localisation'; + is aoeu, 43, 'unless it is declared outside the for loop'; + } +} +# And we also need to test that multiple my subs can close over each +# other’s entries in the parent subs pad, and that cv_clone is not con- +# fused by that. +sub make_anon_with_my_sub{ + sub { + my sub s1; + my sub s2 { \&s1 } + sub s1 { \&s2 } + if (@_) { return eval { \&s1 } } + is eval{s1},eval{\&s2}, 'my sub in anon closure closing over sibling my sub'; + is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub'; + } +} + +# Test my subs inside predeclared my subs +{ + my sub s2; + sub s2 { + my $x = 3; + my sub s3 { eval '$x' } + s3; + } + is s2, 3, 'my sub inside predeclared my sub'; +} + +{ + my $s = make_anon_with_my_sub; + &$s; + + # And make sure the my subs were actually cloned. + isnt make_anon_with_my_sub->(0), &$s(0), + 'my subs in anon subs are cloned'; + isnt &$s(0), &$s(0), 'at each invocation of the enclosing sub'; +} +{ + my sub BEGIN { exit }; + pass 'my subs are never special blocks'; + my sub END { shift } + is END('jkqeudth'), jkqeudth, + 'my sub END {shift} implies @_, not @ARGV'; +} +{ + my sub redef {} + use warnings; no warnings "experimental::lexical_subs"; + my $w; + local $SIG{__WARN__} = sub { $w .= shift }; + eval "#line 56 pygpyf\nsub redef {}"; + is $w, "Subroutine redef redefined at pygpyf line 56.\n", + "sub redefinition warnings from my subs"; + + undef $w; + sub { + my sub x {}; + sub { eval "#line 87 khaki\n\\&x" } + }->()(); + is $w, "Subroutine \"&x\" is not available at khaki line 87.\n", + "unavailability warning during compilation of eval in closure"; + + undef $w; + no warnings 'void'; + eval <<'->()();'; +#line 87 khaki + sub { + my sub x{} + sub not_lexical8 { + \&x + } + } +->()(); + is $w, "Subroutine \"&x\" is not available at khaki line 90.\n", + "unavailability warning during compilation of named sub in anon"; + + undef $w; + sub not_lexical9 { + my sub x {}; + format = +@ +&x +. + } + eval { write }; + my($f,$l) = (__FILE__,__LINE__ - 1); + is $w, "Subroutine \"&x\" is not available at $f line $l.\n", + 'unavailability warning during cloning'; + $l -= 3; + is $@, "Undefined subroutine &x called at $f line $l.\n", + 'Vivified sub is correctly named'; +} +sub not_lexical10 { + my sub foo; + foo(); + sub not_lexical11 { + my sub bar { + my $x = 'khaki car keys for the khaki car'; + not_lexical10(); + sub foo { + is $x, 'khaki car keys for the khaki car', + 'mysubs in inner clonables use the running clone of their CvOUTSIDE' + } + } + bar() + } +} +not_lexical11(); +{ + my sub p (\@) { + is ref $_[0], 'ARRAY', 'my sub with proto'; + } + p(my @a); +} +{ + my sub x; + my $count; + sub x { x() if $count++ < 10 } + x(); + is $count, 11, 'my recursive subs'; +} +{ + my sub x; + eval 'sub x {3}'; + is x, 3, 'my sub defined inside eval'; +} + +{ + state $w; + local $SIG{__WARN__} = sub { $w .= shift }; + eval q{ my sub george () { 2 } }; + is $w, undef, 'no double free from constant my subs'; +} + +# -------------------- Interactions (and misc tests) -------------------- # + +is sub { + my sub s1; + my sub s2 { 3 }; + sub s1 { state sub foo { \&s2 } foo } + s1 + }->()(), 3, 'state sub inside my sub closing over my sub uncle'; + +{ + my sub s2 { 3 }; + sub not_lexical { state sub foo { \&s2 } foo } + is not_lexical->(), 3, 'state subs that reference my sub from outside'; +} + +# Test my subs inside predeclared package subs +# This test also checks that CvOUTSIDE pointers are not mangled when the +# inner sub’s CvOUTSIDE points to another sub. +sub not_lexical2; +sub not_lexical2 { + my $x = 23; + my sub bar; + sub not_lexical3 { + not_lexical2(); + sub bar { $x } + }; + bar +} +is not_lexical3, 23, 'my subs inside predeclared package subs'; + +# Test my subs inside predeclared package sub, where the lexical sub is +# declared outside the package sub. +# This checks that CvOUTSIDE pointers are fixed up even when the sub is +# not declared inside the sub that its CvOUTSIDE points to. +sub not_lexical5 { + my sub foo; + sub not_lexical4; + sub not_lexical4 { + my $x = 234; + not_lexical5(); + sub foo { $x } + } + foo +} +is not_lexical4, 234, + 'my sub defined in predeclared pkg sub but declared outside'; + +undef *not_lexical6; +{ + my sub foo; + sub not_lexical6 { sub foo { } } + pass 'no crash when cloning a mysub declared inside an undef pack sub'; +} + +undef ¬_lexical7; +eval 'sub not_lexical7 { my @x }'; +{ + my sub foo; + foo(); + sub not_lexical7 { + state $x; + sub foo { + is ref \$x, 'SCALAR', + "redeffing a mysub's outside does not make it use the wrong pad" + } + } +} diff --git a/t/op/while.t b/t/op/while.t new file mode 100644 index 0000000000..5d2af711a5 --- /dev/null +++ b/t/op/while.t @@ -0,0 +1,215 @@ +#!./perl + +BEGIN { + chdir 't'; + require "test.pl"; +} + +plan(25); + +my $tmpfile = tempfile(); +open (tmp,'>', $tmpfile) || die "Can't create Cmd_while.tmp."; +print tmp "tvi925\n"; +print tmp "tvi920\n"; +print tmp "vt100\n"; +print tmp "Amiga\n"; +print tmp "paper\n"; +close tmp or die "Could not close: $!"; + +# test "last" command + +open(fh, $tmpfile) || die "Can't open Cmd_while.tmp."; +while () { + last if /vt100/; +} +ok(!eof && /vt100/); + +# test "next" command + +$bad = ''; +open(fh, $tmpfile) || die "Can't open Cmd_while.tmp."; +while () { + next if /vt100/; + $bad = 1 if /vt100/; +} +ok(eof && !/vt100/ && !$bad); + +# test "redo" command + +$bad = ''; +open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; +while () { + if (s/vt100/VT100/g) { + s/VT100/Vt100/g; + redo; + } + $bad = 1 if /vt100/; + $bad = 1 if /VT100/; +} +ok(eof && !$bad); + +# now do the same with a label and a continue block + +# test "last" command + +$badcont = ''; +open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; +line: while () { + if (/vt100/) {last line;} +} continue { + $badcont = 1 if /vt100/; +} +ok(!eof && /vt100/); +ok(!$badcont); + +# test "next" command + +$bad = ''; +$badcont = 1; +open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; +entry: while () { + next entry if /vt100/; + $bad = 1 if /vt100/; +} continue { + $badcont = '' if /vt100/; +} +ok(eof && !/vt100/ && !$bad); +ok(!$badcont); + +# test "redo" command + +$bad = ''; +$badcont = ''; +open(fh,$tmpfile) || die "Can't open Cmd_while.tmp."; +loop: while () { + if (s/vt100/VT100/g) { + s/VT100/Vt100/g; + redo loop; + } + $bad = 1 if /vt100/; + $bad = 1 if /VT100/; +} continue { + $badcont = 1 if /vt100/; +} +ok(eof && !$bad); +ok(!$badcont); + +close(fh) || die "Can't close Cmd_while.tmp."; + +$i = 9; +{ + $i++; +} +is($i, 10); + +# Check curpm is reset when jumping out of a scope +$i = 0; +'abc' =~ /b/; +WHILE: +while (1) { + $i++; + is($` . $& . $', "abc"); + { # Localize changes to $` and friends + 'end' =~ /end/; + redo WHILE if $i == 1; + next WHILE if $i == 2; + # 3 do a normal loop + last WHILE if $i == 4; + } +} +is($` . $& . $', "abc"); + +# check that scope cleanup happens right when there's a continue block +{ + my $var = 16; + my (@got_var, @got_i); + while (my $i = ++$var) { + next if $i == 17; + last if $i > 17; + my $i = 0; + } + continue { + ($got_var, $got_i) = ($var, $i); + } + is($got_var, 17); + is($got_i, 17); +} + +{ + my $got_l; + local $l = 18; + { + local $l = 0 + } + continue { + $got_l = $l; + } + is($got_l, 18); +} + +{ + my $got_l; + local $l = 19; + my $x = 0; + while (!$x++) { + local $l = 0 + } + continue { + $got_l = $l; + } + is($got_l, $l); +} + +{ + my $ok = 1; + $i = 20; + while (1) { + my $x; + $ok = 0 if defined $x; + if ($i == 21) { + next; + } + last; + } + continue { + ++$i; + } + ok($ok); +} + +sub save_context { $_[0] = wantarray; $_[1] } + +{ + my $context = -1; + my $p = sub { + my $x = 1; + while ($x--) { + save_context($context, "foo"); + } + }; + is(scalar($p->()), 0); + is($context, undef, "last statement in while block has 'void' context"); +} + +{ + my $context = -1; + my $p = sub { + my $x = 1; + { + save_context($context, "foo"); + } + }; + is(scalar($p->()), "foo"); + is($context, "", "last statement in block has 'scalar' context"); +} + +{ + # test scope is cleaned + my $i = 0; + my @a; + while ($i++ < 2) { + my $x; + push @a, \$x; + } + ok($a[0] ne $a[1]); +} -- cgit v1.2.1