t/op/closure.t

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