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