X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2affe78f01f9cd3aae1b214beb9140e1fe830c7d..fca7221246069070a65ab8fbc4fa10405266be20:/t/op/closure.t diff --git a/t/op/closure.t b/t/op/closure.t old mode 100755 new mode 100644 index dd7b50c..322b592 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -12,35 +12,27 @@ BEGIN { } use Config; - -print "1..184\n"; - -my $test = 1; -sub test (&) { - my $ok = &{$_[0]}; - print $ok ? "ok $test\n" : "not ok $test\n"; - printf "# Failed at line %d\n", (caller)[2] unless $ok; - $test++; -} +require './test.pl'; my $i = 1; sub foo { $i = shift if @_; $i } # no closure -test { foo == 1 }; +is(foo, 1); foo(2); -test { foo == 2 }; +is(foo, 2); # closure: lexical outside sub my $foo = sub {$i = shift if @_; $i }; my $bar = sub {$i = shift if @_; $i }; -test {&$foo() == 2 }; +is(&$foo(), 2); &$foo(3); -test {&$foo() == 3 }; +is(&$foo(), 3); # did the lexical change? -test { foo == 3 and $i == 3}; +is(foo, 3, 'lexical changed'); +is($i, 3, 'lexical changed'); # did the second closure notice? -test {&$bar() == 3 }; +is(&$bar(), 3, 'second closure noticed'); # closure: lexical inside sub sub bar { @@ -50,10 +42,10 @@ sub bar { $foo = bar(4); $bar = bar(5); -test {&$foo() == 4 }; +is(&$foo(), 4); &$foo(6); -test {&$foo() == 6 }; -test {&$bar() == 5 }; +is(&$foo(), 6); +is(&$bar(), 5); # nested closures sub bizz { @@ -68,14 +60,14 @@ sub bizz { } $foo = bizz(); $bar = bizz(); -test {&$foo() == 7 }; +is(&$foo(), 7); &$foo(8); -test {&$foo() == 8 }; -test {&$bar() == 7 }; +is(&$foo(), 8); +is(&$bar(), 7); $foo = bizz(9); $bar = bizz(10); -test {&$foo(11)-1 == &$bar()}; +is(&$foo(11)-1, &$bar()); my @foo; for (qw(0 1 2 3 4)) { @@ -83,25 +75,21 @@ for (qw(0 1 2 3 4)) { $foo[$_] = sub {$i = shift if @_; $i }; } -test { - &{$foo[0]}() == 0 and - &{$foo[1]}() == 1 and - &{$foo[2]}() == 2 and - &{$foo[3]}() == 3 and - &{$foo[4]}() == 4 - }; +is(&{$foo[0]}(), 0); +is(&{$foo[1]}(), 1); +is(&{$foo[2]}(), 2); +is(&{$foo[3]}(), 3); +is(&{$foo[4]}(), 4); for (0 .. 4) { &{$foo[$_]}(4-$_); } -test { - &{$foo[0]}() == 4 and - &{$foo[1]}() == 3 and - &{$foo[2]}() == 2 and - &{$foo[3]}() == 1 and - &{$foo[4]}() == 0 - }; +is(&{$foo[0]}(), 4); +is(&{$foo[1]}(), 3); +is(&{$foo[2]}(), 2); +is(&{$foo[3]}(), 1); +is(&{$foo[4]}(), 0); sub barf { my @foo; @@ -113,25 +101,21 @@ sub barf { } @foo = barf(); -test { - &{$foo[0]}() == 0 and - &{$foo[1]}() == 1 and - &{$foo[2]}() == 2 and - &{$foo[3]}() == 3 and - &{$foo[4]}() == 4 - }; +is(&{$foo[0]}(), 0); +is(&{$foo[1]}(), 1); +is(&{$foo[2]}(), 2); +is(&{$foo[3]}(), 3); +is(&{$foo[4]}(), 4); for (0 .. 4) { &{$foo[$_]}(4-$_); } -test { - &{$foo[0]}() == 4 and - &{$foo[1]}() == 3 and - &{$foo[2]}() == 2 and - &{$foo[3]}() == 1 and - &{$foo[4]}() == 0 - }; +is(&{$foo[0]}(), 4); +is(&{$foo[1]}(), 3); +is(&{$foo[2]}(), 2); +is(&{$foo[3]}(), 1); +is(&{$foo[4]}(), 0); # test if closures get created in optimized for loops @@ -140,25 +124,21 @@ for my $n ('A'..'E') { $foo{$n} = sub { $n eq $_[0] }; } -test { - &{$foo{A}}('A') and - &{$foo{B}}('B') and - &{$foo{C}}('C') and - &{$foo{D}}('D') and - &{$foo{E}}('E') -}; +ok(&{$foo{A}}('A')); +ok(&{$foo{B}}('B')); +ok(&{$foo{C}}('C')); +ok(&{$foo{D}}('D')); +ok(&{$foo{E}}('E')); for my $n (0..4) { $foo[$n] = sub { $n == $_[0] }; } -test { - &{$foo[0]}(0) and - &{$foo[1]}(1) and - &{$foo[2]}(2) and - &{$foo[3]}(3) and - &{$foo[4]}(4) -}; +ok(&{$foo[0]}(0)); +ok(&{$foo[1]}(1)); +ok(&{$foo[2]}(2)); +ok(&{$foo[3]}(3)); +ok(&{$foo[4]}(4)); for my $n (0..4) { $foo[$n] = sub { @@ -167,19 +147,17 @@ for my $n (0..4) { }; } -test { - $foo[0]->()->(0) and - $foo[1]->()->(1) and - $foo[2]->()->(2) and - $foo[3]->()->(3) and - $foo[4]->()->(4) -}; +ok($foo[0]->()->(0)); +ok($foo[1]->()->(1)); +ok($foo[2]->()->(2)); +ok($foo[3]->()->(3)); +ok($foo[4]->()->(4)); { my $w; $w = sub { my ($i) = @_; - test { $i == 10 }; + is($i, 10); sub { $w }; }; $w->(10); @@ -220,6 +198,7 @@ test { # a naked block, or another named sub for $within (qw!foreach naked other_sub!) { + my $test = curr_test(); # Here are a number of variables which show what's # going on, in a way. $nc_attempt = 0+ # Named closure attempted @@ -262,15 +241,8 @@ END_MARK_TWO print "not ok: got unexpected warning \$msg\\n"; } } -{ - my \$test = $test; - sub test (&) { - my \$ok = &{\$_[0]}; - print \$ok ? "ok \$test\n" : "not ok \$test\n"; - printf "# Failed at line %d\n", (caller)[2] unless \$ok; - \$test++; - } -} +require './test.pl'; +curr_test($test); # some of the variables which the closure will access \$global_scalar = 1000; @@ -424,10 +396,11 @@ END } # Here's the test: + my $desc = "$inner_type $where_declared $within $inner_sub_test"; if ($inner_type eq 'anon') { - $code .= "test { &\$anon_$test == $expected };\n" + $code .= "is(&\$anon_$test, $expected, '$desc');\n" } else { - $code .= "test { &named_$test == $expected };\n" + $code .= "is(&named_$test, $expected, '$desc');\n" } $test++; } @@ -446,8 +419,8 @@ END close READ2; open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; - exec './perl', '-w', '-' - or die "Can't exec ./perl: $!"; + exec which_perl(), '-w', '-' + or die "Can't exec perl: $!"; } else { # Parent process here. close WRITE; @@ -462,15 +435,10 @@ END } } else { # No fork(). Do it the hard way. - my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; - my $errfile = "terr$$"; $errfile++ while -e $errfile; - my @tmpfiles = ($cmdfile, $errfile); + my $cmdfile = tempfile(); + my $errfile = tempfile(); open CMD, ">$cmdfile"; print CMD $code; close CMD; - my $cmd = (($^O eq 'VMS') ? "MCR $^X" - : ($^O eq 'MSWin32') ? '.\perl' - : ($^O eq 'MacOS') ? $^X - : ($^O eq 'NetWare') ? 'perl' - : './perl'); + my $cmd = which_perl(); $cmd .= " -w $cmdfile 2>$errfile"; if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') { # Use pipe instead of system so we don't inherit STD* from @@ -480,28 +448,31 @@ END { local $/; $output = join '', } close PERL; } else { - my $outfile = "tout$$"; $outfile++ while -e $outfile; - push @tmpfiles, $outfile; + my $outfile = tempfile(); system "$cmd >$outfile"; { local $/; open IN, $outfile; $output = ; close IN } } if ($?) { printf "not ok: exited with error code %04X\n", $?; - $debugging or do { 1 while unlink @tmpfiles }; exit; } { local $/; open IN, $errfile; $errors = ; close IN } - 1 while unlink @tmpfiles; } print $output; + curr_test($test); print STDERR $errors; + # This has the side effect of alerting *our* test.pl to the state of + # what has just been passed to STDOUT, so that if anything there has + # failed, our test.pl will print a diagnostic and exit uncleanly. + unlike($output, qr/not ok/, 'All good'); + is($errors, '', 'STDERR is silent'); if ($debugging && ($errors || $? || ($output =~ /not ok/))) { my $lnum = 0; for $line (split '\n', $code) { printf "%3d: %s\n", ++$lnum, $line; } } - printf "not ok: exited with error code %04X\n", $? if $?; + is($?, 0, 'exited cleanly') or diag(sprintf "Error code $? = 0x%X", $?); print '#', "-" x 30, "\n" if $debugging; } # End of foreach $within @@ -513,7 +484,7 @@ END # The following dumps core with perl <= 5.8.0 (bugid 9535) ... BEGIN { $vanishing_pad = sub { eval $_[0] } } $some_var = 123; -test { $vanishing_pad->( '$some_var' ) == 123 }; +is($vanishing_pad->('$some_var'), 123, 'RT #9535'); # ... and here's another coredump variant - this time we explicitly # delete the sub rather than using a BEGIN ... @@ -522,7 +493,7 @@ sub deleteme { $a = sub { eval '$newvar' } } deleteme(); *deleteme = sub {}; # delete the sub $newvar = 123; # realloc the SV of the freed CV -test { $a->() == 123 }; +is($a->(), 123, 'RT #9535'); # ... and a further coredump variant - the fixup of the anon sub's # CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to @@ -535,7 +506,7 @@ $a = eval q( ] ); @a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs -test { $a->() == 123 }; +is($a->(), 123, 'RT #9535'); # this coredumped on <= 5.8.0 because evaling the closure caused # an SvFAKE to be added to the outer anon's pad, which was then grown. @@ -547,14 +518,14 @@ sub { $a = [ 99 ]; $x->(); }->(); -test {1}; +pass(); # [perl #17605] found that an empty block called in scalar context # can lead to stack corruption { my $x = "foooobar"; $x =~ s/o//eg; - test { $x eq 'fbar' } + is($x, 'fbar', 'RT #17605'); } # DAPM 24-Nov-02 @@ -564,22 +535,21 @@ test {1}; { my $x = 1; sub fake { - test { sub {eval'$x'}->() == 1 }; - { $x; test { sub {eval'$x'}->() == 1 } } - test { sub {eval'$x'}->() == 1 }; + is(sub {eval'$x'}->(), 1, 'RT #18286'); + { $x; is(sub {eval'$x'}->(), 1, 'RT #18286'); } + is(sub {eval'$x'}->(), 1, 'RT #18286'); } } fake(); -# undefining a sub shouldn't alter visibility of outer lexicals - { $x = 1; my $x = 2; sub tmp { sub { eval '$x' } } my $a = tmp(); undef &tmp; - test { $a->() == 2 }; + is($a->(), 2, + "undefining a sub shouldn't alter visibility of outer lexicals"); } # handy class: $x = Watch->new(\$foo,'bar') @@ -587,7 +557,6 @@ fake(); sub Watch::new { bless [ $_[1], $_[2] ], $_[0] } sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] } - # bugid 1028: # nested anon subs (and associated lexicals) not freed early enough @@ -602,7 +571,7 @@ sub linger { { my $watch = '1'; linger(\$watch); - test { $watch eq '12' } + is($watch, '12', 'RT #1028'); } # bugid 10085 @@ -615,7 +584,7 @@ sub linger2 { { my $watch = '1'; linger2(\$watch); - test { $watch eq '12' } + is($watch, 12, 'RT #10085'); } # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs @@ -624,7 +593,7 @@ sub linger2 { my $x = 1; sub f16302 { sub { - test { defined $x and $x == 1 } + is($x, 1, 'RT #16302'); }->(); } } @@ -638,7 +607,99 @@ f16302(); for my $x (7,11) { $a{$x} = sub { $x=$x; sub { eval '$x' } }; } - test { $a{7}->()->() + $a{11}->()->() == 18 }; + is($a{7}->()->() + $a{11}->()->(), 18); +} + +{ + # bugid #23265 - this used to coredump during destruction of PL_maincv + # and its children + + fresh_perl_is(<< '__EOF__', "yxx\n", {stderr => 1}, 'RT #23265'); + print + sub {$_[0]->(@_)} -> ( + sub { + $_[1] + ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->() + : "y" + }, + 2 + ) + , "\n" + ; +__EOF__ +} + +{ + # bugid #24914 = used to coredump restoring PL_comppad in the + # savestack, due to the early freeing of the anon closure + + fresh_perl_is('sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)', + "ok\n", {stderr => 1}, 'RT #24914'); } +# After newsub is redefined outside the BEGIN, its CvOUTSIDE should point +# to main rather than BEGIN, and BEGIN should be freed. + +{ + my $flag = 0; + sub X::DESTROY { $flag = 1 } + { + my $x; + BEGIN {$x = \&newsub } + sub newsub {}; + $x = bless {}, 'X'; + } + is($flag, 1); +} + +sub f { + my $x if $_[0]; + sub { \$x } +} + +{ + f(1); + my $c1= f(0); + my $c2= f(0); + + my $r1 = $c1->(); + my $r2 = $c2->(); + isnt($r1, $r2, + "don't copy a stale lexical; crate a fresh undef one instead"); +} + +# [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant + +BEGIN { + my $x = 7; + *baz = sub() { if($x){ () = "tralala"; blonk() }; 0 } +} +{ + my $blonk_was_called; + *blonk = sub { ++$blonk_was_called }; + my $ret = baz(); + is($ret, 0, 'RT #63540'); + is($blonk_was_called, 1, 'RT #63540'); +} + +# test PL_cv_has_eval. Any anon sub that could conceivably contain an +# eval, should be marked as cloneable + +{ + + my @s; + push @s, sub { eval '1' } for 1,2; + isnt($s[0], $s[1], "cloneable with eval"); + @s = (); + push @s, sub { use re 'eval'; my $x; s/$x/1/; } for 1,2; + isnt($s[0], $s[1], "cloneable with use re eval"); + @s = (); + push @s, sub { s/1/1/ee; } for 1,2; + isnt($s[0], $s[1], "cloneable with //ee"); +} + + + + +done_testing();