| 1 | #!./perl |
| 2 | # -*- Mode: Perl -*- |
| 3 | # closure.t: |
| 4 | # Original written by Ulrich Pfeifer on 2 Jan 1997. |
| 5 | # Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997. |
| 6 | # |
| 7 | # Run with -debug for debugging output. |
| 8 | |
| 9 | BEGIN { |
| 10 | chdir 't' if -d 't'; |
| 11 | @INC = '../lib'; |
| 12 | require './test.pl'; |
| 13 | } |
| 14 | |
| 15 | use Config; |
| 16 | |
| 17 | my $i = 1; |
| 18 | sub foo { $i = shift if @_; $i } |
| 19 | |
| 20 | # no closure |
| 21 | is(foo, 1); |
| 22 | foo(2); |
| 23 | is(foo, 2); |
| 24 | |
| 25 | # closure: lexical outside sub |
| 26 | my $foo = sub {$i = shift if @_; $i }; |
| 27 | my $bar = sub {$i = shift if @_; $i }; |
| 28 | is(&$foo(), 2); |
| 29 | &$foo(3); |
| 30 | is(&$foo(), 3); |
| 31 | # did the lexical change? |
| 32 | is(foo, 3, 'lexical changed'); |
| 33 | is($i, 3, 'lexical changed'); |
| 34 | # did the second closure notice? |
| 35 | is(&$bar(), 3, 'second closure noticed'); |
| 36 | |
| 37 | # closure: lexical inside sub |
| 38 | sub bar { |
| 39 | my $i = shift; |
| 40 | sub { $i = shift if @_; $i } |
| 41 | } |
| 42 | |
| 43 | $foo = bar(4); |
| 44 | $bar = bar(5); |
| 45 | is(&$foo(), 4); |
| 46 | &$foo(6); |
| 47 | is(&$foo(), 6); |
| 48 | is(&$bar(), 5); |
| 49 | |
| 50 | # nested closures |
| 51 | sub bizz { |
| 52 | my $i = 7; |
| 53 | if (@_) { |
| 54 | my $i = shift; |
| 55 | sub {$i = shift if @_; $i }; |
| 56 | } else { |
| 57 | my $i = $i; |
| 58 | sub {$i = shift if @_; $i }; |
| 59 | } |
| 60 | } |
| 61 | $foo = bizz(); |
| 62 | $bar = bizz(); |
| 63 | is(&$foo(), 7); |
| 64 | &$foo(8); |
| 65 | is(&$foo(), 8); |
| 66 | is(&$bar(), 7); |
| 67 | |
| 68 | $foo = bizz(9); |
| 69 | $bar = bizz(10); |
| 70 | is(&$foo(11)-1, &$bar()); |
| 71 | |
| 72 | my @foo; |
| 73 | for (qw(0 1 2 3 4)) { |
| 74 | my $i = $_; |
| 75 | $foo[$_] = sub {$i = shift if @_; $i }; |
| 76 | } |
| 77 | |
| 78 | is(&{$foo[0]}(), 0); |
| 79 | is(&{$foo[1]}(), 1); |
| 80 | is(&{$foo[2]}(), 2); |
| 81 | is(&{$foo[3]}(), 3); |
| 82 | is(&{$foo[4]}(), 4); |
| 83 | |
| 84 | for (0 .. 4) { |
| 85 | &{$foo[$_]}(4-$_); |
| 86 | } |
| 87 | |
| 88 | is(&{$foo[0]}(), 4); |
| 89 | is(&{$foo[1]}(), 3); |
| 90 | is(&{$foo[2]}(), 2); |
| 91 | is(&{$foo[3]}(), 1); |
| 92 | is(&{$foo[4]}(), 0); |
| 93 | |
| 94 | sub barf { |
| 95 | my @foo; |
| 96 | for (qw(0 1 2 3 4)) { |
| 97 | my $i = $_; |
| 98 | $foo[$_] = sub {$i = shift if @_; $i }; |
| 99 | } |
| 100 | @foo; |
| 101 | } |
| 102 | |
| 103 | @foo = barf(); |
| 104 | is(&{$foo[0]}(), 0); |
| 105 | is(&{$foo[1]}(), 1); |
| 106 | is(&{$foo[2]}(), 2); |
| 107 | is(&{$foo[3]}(), 3); |
| 108 | is(&{$foo[4]}(), 4); |
| 109 | |
| 110 | for (0 .. 4) { |
| 111 | &{$foo[$_]}(4-$_); |
| 112 | } |
| 113 | |
| 114 | is(&{$foo[0]}(), 4); |
| 115 | is(&{$foo[1]}(), 3); |
| 116 | is(&{$foo[2]}(), 2); |
| 117 | is(&{$foo[3]}(), 1); |
| 118 | is(&{$foo[4]}(), 0); |
| 119 | |
| 120 | # test if closures get created in optimized for loops |
| 121 | |
| 122 | my %foo; |
| 123 | for my $n ('A'..'E') { |
| 124 | $foo{$n} = sub { $n eq $_[0] }; |
| 125 | } |
| 126 | |
| 127 | ok(&{$foo{A}}('A')); |
| 128 | ok(&{$foo{B}}('B')); |
| 129 | ok(&{$foo{C}}('C')); |
| 130 | ok(&{$foo{D}}('D')); |
| 131 | ok(&{$foo{E}}('E')); |
| 132 | |
| 133 | for my $n (0..4) { |
| 134 | $foo[$n] = sub { $n == $_[0] }; |
| 135 | } |
| 136 | |
| 137 | ok(&{$foo[0]}(0)); |
| 138 | ok(&{$foo[1]}(1)); |
| 139 | ok(&{$foo[2]}(2)); |
| 140 | ok(&{$foo[3]}(3)); |
| 141 | ok(&{$foo[4]}(4)); |
| 142 | |
| 143 | for my $n (0..4) { |
| 144 | $foo[$n] = sub { |
| 145 | # no intervening reference to $n here |
| 146 | sub { $n == $_[0] } |
| 147 | }; |
| 148 | } |
| 149 | |
| 150 | ok($foo[0]->()->(0)); |
| 151 | ok($foo[1]->()->(1)); |
| 152 | ok($foo[2]->()->(2)); |
| 153 | ok($foo[3]->()->(3)); |
| 154 | ok($foo[4]->()->(4)); |
| 155 | |
| 156 | { |
| 157 | my $w; |
| 158 | $w = sub { |
| 159 | my ($i) = @_; |
| 160 | is($i, 10); |
| 161 | sub { $w }; |
| 162 | }; |
| 163 | $w->(10); |
| 164 | } |
| 165 | |
| 166 | # Additional tests by Tom Phoenix <rootbeer@teleport.com>. |
| 167 | |
| 168 | { |
| 169 | use strict; |
| 170 | |
| 171 | use vars qw!$test!; |
| 172 | my($debugging, %expected, $inner_type, $where_declared, $within); |
| 173 | my($nc_attempt, $call_outer, $call_inner, $undef_outer); |
| 174 | my($code, $inner_sub_test, $expected, $line, $errors, $output); |
| 175 | my(@inners, $sub_test, $pid); |
| 176 | $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; |
| 177 | |
| 178 | # The expected values for these tests |
| 179 | %expected = ( |
| 180 | 'global_scalar' => 1001, |
| 181 | 'global_array' => 2101, |
| 182 | 'global_hash' => 3004, |
| 183 | 'fs_scalar' => 4001, |
| 184 | 'fs_array' => 5101, |
| 185 | 'fs_hash' => 6004, |
| 186 | 'sub_scalar' => 7001, |
| 187 | 'sub_array' => 8101, |
| 188 | 'sub_hash' => 9004, |
| 189 | 'foreach' => 10011, |
| 190 | ); |
| 191 | |
| 192 | # Our innermost sub is either named or anonymous |
| 193 | for $inner_type (qw!named anon!) { |
| 194 | # And it may be declared at filescope, within a named |
| 195 | # sub, or within an anon sub |
| 196 | for $where_declared (qw!filescope in_named in_anon!) { |
| 197 | # And that, in turn, may be within a foreach loop, |
| 198 | # a naked block, or another named sub |
| 199 | for $within (qw!foreach naked other_sub!) { |
| 200 | |
| 201 | my $test = curr_test(); |
| 202 | # Here are a number of variables which show what's |
| 203 | # going on, in a way. |
| 204 | $nc_attempt = 0+ # Named closure attempted |
| 205 | ( ($inner_type eq 'named') || |
| 206 | ($within eq 'other_sub') ) ; |
| 207 | $call_inner = 0+ # Need to call &inner |
| 208 | ( ($inner_type eq 'anon') && |
| 209 | ($within eq 'other_sub') ) ; |
| 210 | $call_outer = 0+ # Need to call &outer or &$outer |
| 211 | ( ($inner_type eq 'anon') && |
| 212 | ($within ne 'other_sub') ) ; |
| 213 | $undef_outer = 0+ # $outer is created but unused |
| 214 | ( ($where_declared eq 'in_anon') && |
| 215 | (not $call_outer) ) ; |
| 216 | |
| 217 | $code = "# This is a test script built by t/op/closure.t\n\n"; |
| 218 | |
| 219 | print <<"DEBUG_INFO" if $debugging; |
| 220 | # inner_type: $inner_type |
| 221 | # where_declared: $where_declared |
| 222 | # within: $within |
| 223 | # nc_attempt: $nc_attempt |
| 224 | # call_inner: $call_inner |
| 225 | # call_outer: $call_outer |
| 226 | # undef_outer: $undef_outer |
| 227 | DEBUG_INFO |
| 228 | |
| 229 | $code .= <<"END_MARK_ONE"; |
| 230 | |
| 231 | BEGIN { \$SIG{__WARN__} = sub { |
| 232 | my \$msg = \$_[0]; |
| 233 | END_MARK_ONE |
| 234 | |
| 235 | $code .= <<"END_MARK_TWO" if $nc_attempt; |
| 236 | return if index(\$msg, 'will not stay shared') != -1; |
| 237 | return if index(\$msg, 'is not available') != -1; |
| 238 | END_MARK_TWO |
| 239 | |
| 240 | $code .= <<"END_MARK_THREE"; # Backwhack a lot! |
| 241 | print "not ok: got unexpected warning \$msg\\n"; |
| 242 | } } |
| 243 | |
| 244 | require './test.pl'; |
| 245 | curr_test($test); |
| 246 | |
| 247 | # some of the variables which the closure will access |
| 248 | \$global_scalar = 1000; |
| 249 | \@global_array = (2000, 2100, 2200, 2300); |
| 250 | %global_hash = 3000..3009; |
| 251 | |
| 252 | my \$fs_scalar = 4000; |
| 253 | my \@fs_array = (5000, 5100, 5200, 5300); |
| 254 | my %fs_hash = 6000..6009; |
| 255 | |
| 256 | END_MARK_THREE |
| 257 | |
| 258 | if ($where_declared eq 'filescope') { |
| 259 | # Nothing here |
| 260 | } elsif ($where_declared eq 'in_named') { |
| 261 | $code .= <<'END'; |
| 262 | sub outer { |
| 263 | my $sub_scalar = 7000; |
| 264 | my @sub_array = (8000, 8100, 8200, 8300); |
| 265 | my %sub_hash = 9000..9009; |
| 266 | END |
| 267 | # } |
| 268 | } elsif ($where_declared eq 'in_anon') { |
| 269 | $code .= <<'END'; |
| 270 | $outer = sub { |
| 271 | my $sub_scalar = 7000; |
| 272 | my @sub_array = (8000, 8100, 8200, 8300); |
| 273 | my %sub_hash = 9000..9009; |
| 274 | END |
| 275 | # } |
| 276 | } else { |
| 277 | die "What was $where_declared?" |
| 278 | } |
| 279 | |
| 280 | if ($within eq 'foreach') { |
| 281 | $code .= " |
| 282 | my \$foreach = 12000; |
| 283 | my \@list = (10000, 10010); |
| 284 | foreach \$foreach (\@list) { |
| 285 | " # } |
| 286 | } elsif ($within eq 'naked') { |
| 287 | $code .= " { # naked block\n" # } |
| 288 | } elsif ($within eq 'other_sub') { |
| 289 | $code .= " sub inner_sub {\n" # } |
| 290 | } else { |
| 291 | die "What was $within?" |
| 292 | } |
| 293 | |
| 294 | $sub_test = $test; |
| 295 | @inners = ( qw!global_scalar global_array global_hash! , |
| 296 | qw!fs_scalar fs_array fs_hash! ); |
| 297 | push @inners, 'foreach' if $within eq 'foreach'; |
| 298 | if ($where_declared ne 'filescope') { |
| 299 | push @inners, qw!sub_scalar sub_array sub_hash!; |
| 300 | } |
| 301 | for $inner_sub_test (@inners) { |
| 302 | |
| 303 | if ($inner_type eq 'named') { |
| 304 | $code .= " sub named_$sub_test " |
| 305 | } elsif ($inner_type eq 'anon') { |
| 306 | $code .= " \$anon_$sub_test = sub " |
| 307 | } else { |
| 308 | die "What was $inner_type?" |
| 309 | } |
| 310 | |
| 311 | # Now to write the body of the test sub |
| 312 | if ($inner_sub_test eq 'global_scalar') { |
| 313 | $code .= '{ ++$global_scalar }' |
| 314 | } elsif ($inner_sub_test eq 'fs_scalar') { |
| 315 | $code .= '{ ++$fs_scalar }' |
| 316 | } elsif ($inner_sub_test eq 'sub_scalar') { |
| 317 | $code .= '{ ++$sub_scalar }' |
| 318 | } elsif ($inner_sub_test eq 'global_array') { |
| 319 | $code .= '{ ++$global_array[1] }' |
| 320 | } elsif ($inner_sub_test eq 'fs_array') { |
| 321 | $code .= '{ ++$fs_array[1] }' |
| 322 | } elsif ($inner_sub_test eq 'sub_array') { |
| 323 | $code .= '{ ++$sub_array[1] }' |
| 324 | } elsif ($inner_sub_test eq 'global_hash') { |
| 325 | $code .= '{ ++$global_hash{3002} }' |
| 326 | } elsif ($inner_sub_test eq 'fs_hash') { |
| 327 | $code .= '{ ++$fs_hash{6002} }' |
| 328 | } elsif ($inner_sub_test eq 'sub_hash') { |
| 329 | $code .= '{ ++$sub_hash{9002} }' |
| 330 | } elsif ($inner_sub_test eq 'foreach') { |
| 331 | $code .= '{ ++$foreach }' |
| 332 | } else { |
| 333 | die "What was $inner_sub_test?" |
| 334 | } |
| 335 | |
| 336 | # Close up |
| 337 | if ($inner_type eq 'anon') { |
| 338 | $code .= ';' |
| 339 | } |
| 340 | $code .= "\n"; |
| 341 | $sub_test++; # sub name sequence number |
| 342 | |
| 343 | } # End of foreach $inner_sub_test |
| 344 | |
| 345 | # Close up $within block # { |
| 346 | $code .= " }\n\n"; |
| 347 | |
| 348 | # Close up $where_declared block |
| 349 | if ($where_declared eq 'in_named') { # { |
| 350 | $code .= "}\n\n"; |
| 351 | } elsif ($where_declared eq 'in_anon') { # { |
| 352 | $code .= "};\n\n"; |
| 353 | } |
| 354 | |
| 355 | # We may need to do something with the sub we just made... |
| 356 | $code .= "undef \$outer;\n" if $undef_outer; |
| 357 | $code .= "&inner_sub;\n" if $call_inner; |
| 358 | if ($call_outer) { |
| 359 | if ($where_declared eq 'in_named') { |
| 360 | $code .= "&outer;\n\n"; |
| 361 | } elsif ($where_declared eq 'in_anon') { |
| 362 | $code .= "&\$outer;\n\n" |
| 363 | } |
| 364 | } |
| 365 | |
| 366 | # Now, we can actually prep to run the tests. |
| 367 | for $inner_sub_test (@inners) { |
| 368 | $expected = $expected{$inner_sub_test} or |
| 369 | die "expected $inner_sub_test missing"; |
| 370 | |
| 371 | # Named closures won't access the expected vars |
| 372 | if ( $nc_attempt and |
| 373 | substr($inner_sub_test, 0, 4) eq "sub_" ) { |
| 374 | $expected = 1; |
| 375 | } |
| 376 | |
| 377 | # If you make a sub within a foreach loop, |
| 378 | # what happens if it tries to access the |
| 379 | # foreach index variable? If it's a named |
| 380 | # sub, it gets the var from "outside" the loop, |
| 381 | # but if it's anon, it gets the value to which |
| 382 | # the index variable is aliased. |
| 383 | # |
| 384 | # Of course, if the value was set only |
| 385 | # within another sub which was never called, |
| 386 | # the value has not been set yet. |
| 387 | # |
| 388 | if ($inner_sub_test eq 'foreach') { |
| 389 | if ($inner_type eq 'named') { |
| 390 | if ($call_outer || ($where_declared eq 'filescope')) { |
| 391 | $expected = 12001 |
| 392 | } else { |
| 393 | $expected = 1 |
| 394 | } |
| 395 | } |
| 396 | } |
| 397 | |
| 398 | # Here's the test: |
| 399 | my $desc = "$inner_type $where_declared $within $inner_sub_test"; |
| 400 | if ($inner_type eq 'anon') { |
| 401 | $code .= "is(&\$anon_$test, $expected, '$desc');\n" |
| 402 | } else { |
| 403 | $code .= "is(&named_$test, $expected, '$desc');\n" |
| 404 | } |
| 405 | $test++; |
| 406 | } |
| 407 | |
| 408 | if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') { |
| 409 | # Fork off a new perl to run the tests. |
| 410 | # (This is so we can catch spurious warnings.) |
| 411 | $| = 1; print ""; $| = 0; # flush output before forking |
| 412 | pipe READ, WRITE or die "Can't make pipe: $!"; |
| 413 | pipe READ2, WRITE2 or die "Can't make second pipe: $!"; |
| 414 | die "Can't fork: $!" unless defined($pid = open PERL, "|-"); |
| 415 | unless ($pid) { |
| 416 | # Child process here. We're going to send errors back |
| 417 | # through the extra pipe. |
| 418 | close READ; |
| 419 | close READ2; |
| 420 | open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; |
| 421 | open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; |
| 422 | exec which_perl(), '-w', '-' |
| 423 | or die "Can't exec perl: $!"; |
| 424 | } else { |
| 425 | # Parent process here. |
| 426 | close WRITE; |
| 427 | close WRITE2; |
| 428 | print PERL $code; |
| 429 | close PERL; |
| 430 | { local $/; |
| 431 | $output = join '', <READ>; |
| 432 | $errors = join '', <READ2>; } |
| 433 | close READ; |
| 434 | close READ2; |
| 435 | } |
| 436 | } else { |
| 437 | # No fork(). Do it the hard way. |
| 438 | my $cmdfile = tempfile(); |
| 439 | my $errfile = tempfile(); |
| 440 | open CMD, ">$cmdfile"; print CMD $code; close CMD; |
| 441 | my $cmd = which_perl(); |
| 442 | $cmd .= " -w $cmdfile 2>$errfile"; |
| 443 | if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') { |
| 444 | # Use pipe instead of system so we don't inherit STD* from |
| 445 | # this process, and then foul our pipe back to parent by |
| 446 | # redirecting output in the child. |
| 447 | open PERL,"$cmd |" or die "Can't open pipe: $!\n"; |
| 448 | { local $/; $output = join '', <PERL> } |
| 449 | close PERL; |
| 450 | } else { |
| 451 | my $outfile = tempfile(); |
| 452 | system "$cmd >$outfile"; |
| 453 | { local $/; open IN, $outfile; $output = <IN>; close IN } |
| 454 | } |
| 455 | if ($?) { |
| 456 | printf "not ok: exited with error code %04X\n", $?; |
| 457 | exit; |
| 458 | } |
| 459 | { local $/; open IN, $errfile; $errors = <IN>; close IN } |
| 460 | } |
| 461 | print $output; |
| 462 | curr_test($test); |
| 463 | print STDERR $errors; |
| 464 | # This has the side effect of alerting *our* test.pl to the state of |
| 465 | # what has just been passed to STDOUT, so that if anything there has |
| 466 | # failed, our test.pl will print a diagnostic and exit uncleanly. |
| 467 | unlike($output, qr/not ok/, 'All good'); |
| 468 | is($errors, '', 'STDERR is silent'); |
| 469 | if ($debugging && ($errors || $? || ($output =~ /not ok/))) { |
| 470 | my $lnum = 0; |
| 471 | for $line (split '\n', $code) { |
| 472 | printf "%3d: %s\n", ++$lnum, $line; |
| 473 | } |
| 474 | } |
| 475 | is($?, 0, 'exited cleanly') or diag(sprintf "Error code $? = 0x%X", $?); |
| 476 | print '#', "-" x 30, "\n" if $debugging; |
| 477 | |
| 478 | } # End of foreach $within |
| 479 | } # End of foreach $where_declared |
| 480 | } # End of foreach $inner_type |
| 481 | |
| 482 | } |
| 483 | |
| 484 | # The following dumps core with perl <= 5.8.0 (bugid 9535) ... |
| 485 | BEGIN { $vanishing_pad = sub { eval $_[0] } } |
| 486 | $some_var = 123; |
| 487 | is($vanishing_pad->('$some_var'), 123, 'RT #9535'); |
| 488 | |
| 489 | # ... and here's another coredump variant - this time we explicitly |
| 490 | # delete the sub rather than using a BEGIN ... |
| 491 | |
| 492 | sub deleteme { $a = sub { eval '$newvar' } } |
| 493 | deleteme(); |
| 494 | *deleteme = sub {}; # delete the sub |
| 495 | $newvar = 123; # realloc the SV of the freed CV |
| 496 | is($a->(), 123, 'RT #9535'); |
| 497 | |
| 498 | # ... and a further coredump variant - the fixup of the anon sub's |
| 499 | # CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to |
| 500 | # survive the outer eval also being freed. |
| 501 | |
| 502 | $x = 123; |
| 503 | $a = eval q( |
| 504 | eval q[ |
| 505 | sub { eval '$x' } |
| 506 | ] |
| 507 | ); |
| 508 | @a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs |
| 509 | is($a->(), 123, 'RT #9535'); |
| 510 | |
| 511 | # this coredumped on <= 5.8.0 because evaling the closure caused |
| 512 | # an SvFAKE to be added to the outer anon's pad, which was then grown. |
| 513 | my $outer; |
| 514 | sub { |
| 515 | my $x; |
| 516 | $x = eval 'sub { $outer }'; |
| 517 | $x->(); |
| 518 | $a = [ 99 ]; |
| 519 | $x->(); |
| 520 | }->(); |
| 521 | pass(); |
| 522 | |
| 523 | # [perl #17605] found that an empty block called in scalar context |
| 524 | # can lead to stack corruption |
| 525 | { |
| 526 | my $x = "foooobar"; |
| 527 | $x =~ s/o//eg; |
| 528 | is($x, 'fbar', 'RT #17605'); |
| 529 | } |
| 530 | |
| 531 | # DAPM 24-Nov-02 |
| 532 | # SvFAKE lexicals should be visible thoughout a function. |
| 533 | # On <= 5.8.0, the third test failed, eg bugid #18286 |
| 534 | |
| 535 | { |
| 536 | my $x = 1; |
| 537 | sub fake { |
| 538 | is(sub {eval'$x'}->(), 1, 'RT #18286'); |
| 539 | { $x; is(sub {eval'$x'}->(), 1, 'RT #18286'); } |
| 540 | is(sub {eval'$x'}->(), 1, 'RT #18286'); |
| 541 | } |
| 542 | } |
| 543 | fake(); |
| 544 | |
| 545 | { |
| 546 | $x = 1; |
| 547 | my $x = 2; |
| 548 | sub tmp { sub { eval '$x' } } |
| 549 | my $a = tmp(); |
| 550 | undef &tmp; |
| 551 | is($a->(), 2, |
| 552 | "undefining a sub shouldn't alter visibility of outer lexicals"); |
| 553 | } |
| 554 | |
| 555 | # handy class: $x = Watch->new(\$foo,'bar') |
| 556 | # causes 'bar' to be appended to $foo when $x is destroyed |
| 557 | sub Watch::new { bless [ $_[1], $_[2] ], $_[0] } |
| 558 | sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] } |
| 559 | |
| 560 | # bugid 1028: |
| 561 | # nested anon subs (and associated lexicals) not freed early enough |
| 562 | |
| 563 | sub linger { |
| 564 | my $x = Watch->new($_[0], '2'); |
| 565 | sub { |
| 566 | $x; |
| 567 | my $y; |
| 568 | sub { $y; }; |
| 569 | }; |
| 570 | } |
| 571 | { |
| 572 | my $watch = '1'; |
| 573 | linger(\$watch); |
| 574 | is($watch, '12', 'RT #1028'); |
| 575 | } |
| 576 | |
| 577 | # bugid 10085 |
| 578 | # obj not freed early enough |
| 579 | |
| 580 | sub linger2 { |
| 581 | my $obj = Watch->new($_[0], '2'); |
| 582 | sub { sub { $obj } }; |
| 583 | } |
| 584 | { |
| 585 | my $watch = '1'; |
| 586 | linger2(\$watch); |
| 587 | is($watch, 12, 'RT #10085'); |
| 588 | } |
| 589 | |
| 590 | # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs |
| 591 | |
| 592 | { |
| 593 | my $x = 1; |
| 594 | sub f16302 { |
| 595 | sub { |
| 596 | is($x, 1, 'RT #16302'); |
| 597 | }->(); |
| 598 | } |
| 599 | } |
| 600 | f16302(); |
| 601 | |
| 602 | # The presence of an eval should turn cloneless anon subs into clonable |
| 603 | # subs - otherwise the CvOUTSIDE of that sub may be wrong |
| 604 | |
| 605 | { |
| 606 | my %a; |
| 607 | for my $x (7,11) { |
| 608 | $a{$x} = sub { $x=$x; sub { eval '$x' } }; |
| 609 | } |
| 610 | is($a{7}->()->() + $a{11}->()->(), 18); |
| 611 | } |
| 612 | |
| 613 | { |
| 614 | # bugid #23265 - this used to coredump during destruction of PL_maincv |
| 615 | # and its children |
| 616 | |
| 617 | fresh_perl_is(<< '__EOF__', "yxx\n", {stderr => 1}, 'RT #23265'); |
| 618 | print |
| 619 | sub {$_[0]->(@_)} -> ( |
| 620 | sub { |
| 621 | $_[1] |
| 622 | ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->() |
| 623 | : "y" |
| 624 | }, |
| 625 | 2 |
| 626 | ) |
| 627 | , "\n" |
| 628 | ; |
| 629 | __EOF__ |
| 630 | } |
| 631 | |
| 632 | { |
| 633 | # bugid #24914 = used to coredump restoring PL_comppad in the |
| 634 | # savestack, due to the early freeing of the anon closure |
| 635 | |
| 636 | fresh_perl_is('sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)', |
| 637 | "ok\n", {stderr => 1}, 'RT #24914'); |
| 638 | } |
| 639 | |
| 640 | |
| 641 | # After newsub is redefined outside the BEGIN, its CvOUTSIDE should point |
| 642 | # to main rather than BEGIN, and BEGIN should be freed. |
| 643 | |
| 644 | { |
| 645 | my $flag = 0; |
| 646 | sub X::DESTROY { $flag = 1 } |
| 647 | { |
| 648 | my $x; |
| 649 | BEGIN {$x = \&newsub } |
| 650 | sub newsub {}; |
| 651 | $x = bless {}, 'X'; |
| 652 | } |
| 653 | is($flag, 1); |
| 654 | } |
| 655 | |
| 656 | sub f { |
| 657 | my $x; |
| 658 | format ff = |
| 659 | @ |
| 660 | $r = \$x |
| 661 | . |
| 662 | } |
| 663 | |
| 664 | { |
| 665 | fileno ff; |
| 666 | write ff; |
| 667 | my $r1 = $r; |
| 668 | write ff; |
| 669 | my $r2 = $r; |
| 670 | isnt($r1, $r2, |
| 671 | "don't copy a stale lexical; create a fresh undef one instead"); |
| 672 | } |
| 673 | |
| 674 | # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant |
| 675 | |
| 676 | BEGIN { |
| 677 | my $x = 7; |
| 678 | *baz = sub() { if($x){ () = "tralala"; blonk() }; 0 } |
| 679 | } |
| 680 | { |
| 681 | my $blonk_was_called; |
| 682 | *blonk = sub { ++$blonk_was_called }; |
| 683 | my $ret = baz(); |
| 684 | is($ret, 0, 'RT #63540'); |
| 685 | is($blonk_was_called, 1, 'RT #63540'); |
| 686 | } |
| 687 | |
| 688 | # test PL_cv_has_eval. Any anon sub that could conceivably contain an |
| 689 | # eval, should be marked as cloneable |
| 690 | |
| 691 | { |
| 692 | |
| 693 | my @s; |
| 694 | push @s, sub { eval '1' } for 1,2; |
| 695 | isnt($s[0], $s[1], "cloneable with eval"); |
| 696 | @s = (); |
| 697 | push @s, sub { use re 'eval'; my $x; s/$x/1/; } for 1,2; |
| 698 | isnt($s[0], $s[1], "cloneable with use re eval"); |
| 699 | @s = (); |
| 700 | push @s, sub { s/1/1/ee; } for 1,2; |
| 701 | isnt($s[0], $s[1], "cloneable with //ee"); |
| 702 | } |
| 703 | |
| 704 | # [perl #89544] |
| 705 | { |
| 706 | sub trace::DESTROY { |
| 707 | push @trace::trace, "destroyed"; |
| 708 | } |
| 709 | |
| 710 | my $outer2 = sub { |
| 711 | my $a = bless \my $dummy, trace::; |
| 712 | |
| 713 | my $outer = sub { |
| 714 | my $b; |
| 715 | my $inner = sub { |
| 716 | undef $b; |
| 717 | }; |
| 718 | |
| 719 | $a; |
| 720 | |
| 721 | $inner |
| 722 | }; |
| 723 | |
| 724 | $outer->() |
| 725 | }; |
| 726 | |
| 727 | my $inner = $outer2->(); |
| 728 | is "@trace::trace", "destroyed", |
| 729 | 'closures only close over named variables, not entire subs'; |
| 730 | } |
| 731 | |
| 732 | # [perl #113812] Closure prototypes with no CvOUTSIDE (crash caused by the |
| 733 | # fix for #89544) |
| 734 | do "./op/closure_test.pl" or die $@||$!; |
| 735 | is $closure_test::s2->()(), '10 cubes', |
| 736 | 'cloning closure proto with no CvOUTSIDE'; |
| 737 | |
| 738 | # Also brought up in #113812: Even when being cloned, a closure prototype |
| 739 | # might have its CvOUTSIDE pointing to the wrong thing. |
| 740 | { |
| 741 | package main::113812; |
| 742 | $s1 = sub { |
| 743 | my $x = 3; |
| 744 | $s2 = sub { |
| 745 | $x; |
| 746 | $s3 = sub { $x }; |
| 747 | }; |
| 748 | }; |
| 749 | $s1->(); |
| 750 | undef &$s1; # frees $s2’s prototype, causing the $s3 proto to have its |
| 751 | # CvOUTSIDE point to $s1 |
| 752 | ::is $s2->()(), 3, 'cloning closure proto whose CvOUTSIDE has changed'; |
| 753 | } |
| 754 | |
| 755 | # This should never emit two different values: |
| 756 | # print $x, "\n"; |
| 757 | # print sub { $x }->(), "\n"; |
| 758 | # This test case started to do just that in commit 33894c1aa3e |
| 759 | # (5.10.1/5.12.0): |
| 760 | sub mosquito { |
| 761 | my $x if @_; |
| 762 | return if @_; |
| 763 | |
| 764 | $x = 17; |
| 765 | is sub { $x }->(), $x, 'closing over stale var in 2nd sub call'; |
| 766 | } |
| 767 | mosquito(1); |
| 768 | mosquito; |
| 769 | # And this case in commit adf8f095c588 (5.14): |
| 770 | sub anything { |
| 771 | my $x; |
| 772 | sub gnat { |
| 773 | $x = 3; |
| 774 | is sub { $x }->(), $x, |
| 775 | 'closing over stale var before 1st sub call'; |
| 776 | } |
| 777 | } |
| 778 | gnat(); |
| 779 | |
| 780 | # [perl #114018] Similar to the above, but with string eval |
| 781 | sub staleval { |
| 782 | my $x if @_; |
| 783 | return if @_; |
| 784 | |
| 785 | $x = 3; |
| 786 | is eval '$x', $x, 'eval closing over stale var in active sub'; |
| 787 | return # |
| 788 | } |
| 789 | staleval 1; |
| 790 | staleval; |
| 791 | |
| 792 | # [perl #114888] |
| 793 | # Test that closure creation localises PL_comppad_name properly. Usually |
| 794 | # at compile time a BEGIN block will localise PL_comppad_name for use, so |
| 795 | # pp_anoncode can mess with it without any visible effects. |
| 796 | # But inside a source filter, it affects the directly enclosing compila- |
| 797 | # tion scope. |
| 798 | SKIP: { |
| 799 | skip_if_miniperl("no XS on miniperl (for source filters)"); |
| 800 | fresh_perl_is <<' [perl #114888]', "ok\n", {stderr=>1}, |
| 801 | use strict; |
| 802 | BEGIN { |
| 803 | package Foo; |
| 804 | use Filter::Util::Call; |
| 805 | sub import { filter_add( sub { |
| 806 | my $status = filter_read(); |
| 807 | sub { $status }; |
| 808 | $status; |
| 809 | })} |
| 810 | Foo->import |
| 811 | } |
| 812 | my $x = "ok\n"; # stores $x in the wrong padnamelist |
| 813 | print $x; # cannot find it - strict violation |
| 814 | [perl #114888] |
| 815 | 'closures in source filters do not interfere with pad names'; |
| 816 | } |
| 817 | |
| 818 | done_testing(); |