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     set_up_inc('../lib');
  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 # test PL_cv_has_eval.  Any anon sub that could conceivably contain an
 675 # eval, should be marked as cloneable
 676
 677 {
 678
 679     my @s;
 680     push @s, sub {  eval '1' } for 1,2;
 681     isnt($s[0], $s[1], "cloneable with eval");
 682     @s = ();
 683     push @s, sub { use re 'eval'; my $x; s/$x/1/; } for 1,2;
 684     isnt($s[0], $s[1], "cloneable with use re eval");
 685     @s = ();
 686     push @s, sub { s/1/1/ee; } for 1,2;
 687     isnt($s[0], $s[1], "cloneable with //ee");
 688 }
 689
 690 # [perl #89544]
 691 {
 692    sub trace::DESTROY {
 693        push @trace::trace, "destroyed";
 694    }
 695
 696    my $outer2 = sub {
 697        my $a = bless \my $dummy, trace::;
 698
 699        my $outer = sub {
 700            my $b;
 701            my $inner = sub {
 702                undef $b;
 703            };
 704
 705            $a;
 706
 707            $inner
 708        };
 709
 710        $outer->()
 711    };
 712
 713    my $inner = $outer2->();
 714    is "@trace::trace", "destroyed",
 715       'closures only close over named variables, not entire subs';
 716 }
 717
 718 # [perl #113812] Closure prototypes with no CvOUTSIDE (crash caused by the
 719 #                fix for #89544)
 720 do "./op/closure_test.pl" or die $@||$!;
 721 is $closure_test::s2->()(), '10 cubes',
 722   'cloning closure proto with no CvOUTSIDE';
 723
 724 # Also brought up in #113812: Even when being cloned, a closure prototype
 725 # might have its CvOUTSIDE pointing to the wrong thing.
 726 {
 727     package main::113812;
 728     $s1 = sub {
 729         my $x = 3;
 730         $s2 = sub {
 731             $x;
 732             $s3 = sub { $x };
 733         };
 734     };
 735     $s1->();
 736     undef &$s1; # frees $s2's prototype, causing the $s3 proto to have its
 737                 # CvOUTSIDE point to $s1
 738     ::is $s2->()(), 3, 'cloning closure proto whose CvOUTSIDE has changed';
 739 }
 740
 741 # This should never emit two different values:
 742 #     print $x, "\n";
 743 #     print sub { $x }->(), "\n";
 744 # This test case started to do just that in commit 33894c1aa3e
 745 # (5.10.1/5.12.0):
 746 sub mosquito {
 747     my $x if @_;
 748     return if @_;
 749
 750     $x = 17;
 751     is sub { $x }->(), $x, 'closing over stale var in 2nd sub call';
 752 }
 753 mosquito(1);
 754 mosquito;
 755 # And this case in commit adf8f095c588 (5.14):
 756 sub anything {
 757     my $x;
 758     sub gnat {
 759         $x = 3;
 760         is sub { $x }->(), $x,
 761             'closing over stale var before 1st sub call';
 762     }
 763 }
 764 gnat();
 765
 766 # [perl #114018] Similar to the above, but with string eval
 767 sub staleval {
 768     my $x if @_;
 769     return if @_;
 770
 771     $x = 3;
 772     is eval '$x', $x, 'eval closing over stale var in active sub';
 773     return #
 774 }
 775 staleval 1;
 776 staleval;
 777
 778 # [perl #114888]
 779 # Test that closure creation localises PL_comppad_name properly.  Usually
 780 # at compile time a BEGIN block will localise PL_comppad_name for use, so
 781 # pp_anoncode can mess with it without any visible effects.
 782 # But inside a source filter, it affects the directly enclosing compila-
 783 # tion scope.
 784 SKIP: {
 785     skip_if_miniperl("no XS on miniperl (for source filters)");
 786     fresh_perl_is <<'    [perl #114888]', "ok\n", {stderr=>1},
 787         use strict;
 788         BEGIN {
 789             package Foo;
 790             use Filter::Util::Call;
 791             sub import { filter_add( sub {
 792                 my $status = filter_read();
 793                 sub { $status };
 794                 $status;
 795             })}
 796             Foo->import
 797         }
 798         my $x = "ok\n"; # stores $x in the wrong padnamelist
 799         print $x;       # cannot find it - strict violation
 800     [perl #114888]
 801         'closures in source filters do not interfere with pad names';
 802 }
 803
 804 sub {
 805     my $f;
 806     sub test_ref_to_unavailable {
 807         my $ref = \$f;
 808         $$ref = 7;
 809         is $f, 7, 'taking a ref to unavailable var should not copy it';
 810     }
 811 };
 812 test_ref_to_unavailable();
 813
 814 done_testing();