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