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