From work done at NY Perl Hackathon by Charlie Gonzalez and Taqqai Karim.
For: RT #116615
Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
Charles Randall <cfriv@yahoo.com>
Charles Wilson <cwilson@ece.gatech.edu>
+Charlie Gonzalez <itcharlie@gmail.com>
Chas. Owens <chas.owens@gmail.com>
Chaskiel M Grundman
Chia-liang Kao <clkao@clkao.org>
Milton L. Hankins <mlh@swl.msd.ray.com>
Moritz Lenz <moritz@casella.verplant.org>
Moshe Kaminsky <kaminsky@math.huji.ac.il>
+Mottaqui Karim taqqui.karim@gmail.com
Mr. Nobody <mrnobo1024@yahoo.com>
Murray Nesbitt <murray@nesbitt.ca>
Nathan Kurz <nate@valleytel.net>
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
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
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
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
#!./perl
-print "1..118\n";
+print "1..14\n";
for ($i = 0; $i <= 10; $i++) {
$x[$i] = $i;
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";
-}
+++ /dev/null
-#!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"
- }
- }
-}
+++ /dev/null
-#!./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 (<fh>) {
- last if /vt100/;
-}
-ok(!eof && /vt100/);
-
-# test "next" command
-
-$bad = '';
-open(fh, $tmpfile) || die "Can't open Cmd_while.tmp.";
-while (<fh>) {
- 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 (<fh>) {
- 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 (<fh>) {
- 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 (<fh>) {
- 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 (<fh>) {
- 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]);
-}
--- /dev/null
+#!./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");
+ }
+}
--- /dev/null
+#!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"
+ }
+ }
+}
--- /dev/null
+#!./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 (<fh>) {
+ last if /vt100/;
+}
+ok(!eof && /vt100/);
+
+# test "next" command
+
+$bad = '';
+open(fh, $tmpfile) || die "Can't open Cmd_while.tmp.";
+while (<fh>) {
+ 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 (<fh>) {
+ 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 (<fh>) {
+ 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 (<fh>) {
+ 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 (<fh>) {
+ 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]);
+}
projects / platform / upstream / perl.git / commitdiff