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
   8 BEGIN {
   9     chdir 't' if -d 't';
  10     @INC = '../lib';
  11 }
  12
  13 use Config;
  14
  15 print "1..171\n";
  16
  17 my $test = 1;
  18 sub test (&) {
  19   print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
  20   $test++;
  21 }
  22
  23 my $i = 1;
  24 sub foo { $i = shift if @_; $i }
  25
  26 # no closure
  27 test { foo == 1 };
  28 foo(2);
  29 test { foo == 2 };
  30
  31 # closure: lexical outside sub
  32 my $foo = sub {$i = shift if @_; $i };
  33 my $bar = sub {$i = shift if @_; $i };
  34 test {&$foo() == 2 };
  35 &$foo(3);
  36 test {&$foo() == 3 };
  37 # did the lexical change?
  38 test { foo == 3 and $i == 3};
  39 # did the second closure notice?
  40 test {&$bar() == 3 };
  41
  42 # closure: lexical inside sub
  43 sub bar {
  44   my $i = shift;
  45   sub { $i = shift if @_; $i }
  46 }
  47
  48 $foo = bar(4);
  49 $bar = bar(5);
  50 test {&$foo() == 4 };
  51 &$foo(6);
  52 test {&$foo() == 6 };
  53 test {&$bar() == 5 };
  54
  55 # nested closures
  56 sub bizz {
  57   my $i = 7;
  58   if (@_) {
  59     my $i = shift;
  60     sub {$i = shift if @_; $i };
  61   } else {
  62     my $i = $i;
  63     sub {$i = shift if @_; $i };
  64   }
  65 }
  66 $foo = bizz();
  67 $bar = bizz();
  68 test {&$foo() == 7 };
  69 &$foo(8);
  70 test {&$foo() == 8 };
  71 test {&$bar() == 7 };
  72
  73 $foo = bizz(9);
  74 $bar = bizz(10);
  75 test {&$foo(11)-1 == &$bar()};
  76
  77 my @foo;
  78 for (qw(0 1 2 3 4)) {
  79   my $i = $_;
  80   $foo[$_] = sub {$i = shift if @_; $i };
  81 }
  82
  83 test {
  84   &{$foo[0]}() == 0 and
  85   &{$foo[1]}() == 1 and
  86   &{$foo[2]}() == 2 and
  87   &{$foo[3]}() == 3 and
  88   &{$foo[4]}() == 4
  89   };
  90
  91 for (0 .. 4) {
  92   &{$foo[$_]}(4-$_);
  93 }
  94
  95 test {
  96   &{$foo[0]}() == 4 and
  97   &{$foo[1]}() == 3 and
  98   &{$foo[2]}() == 2 and
  99   &{$foo[3]}() == 1 and
 100   &{$foo[4]}() == 0
 101   };
 102
 103 sub barf {
 104   my @foo;
 105   for (qw(0 1 2 3 4)) {
 106     my $i = $_;
 107     $foo[$_] = sub {$i = shift if @_; $i };
 108   }
 109   @foo;
 110 }
 111
 112 @foo = barf();
 113 test {
 114   &{$foo[0]}() == 0 and
 115   &{$foo[1]}() == 1 and
 116   &{$foo[2]}() == 2 and
 117   &{$foo[3]}() == 3 and
 118   &{$foo[4]}() == 4
 119   };
 120
 121 for (0 .. 4) {
 122   &{$foo[$_]}(4-$_);
 123 }
 124
 125 test {
 126   &{$foo[0]}() == 4 and
 127   &{$foo[1]}() == 3 and
 128   &{$foo[2]}() == 2 and
 129   &{$foo[3]}() == 1 and
 130   &{$foo[4]}() == 0
 131   };
 132
 133 # test if closures get created in optimized for loops
 134
 135 my %foo;
 136 for my $n ('A'..'E') {
 137     $foo{$n} = sub { $n eq $_[0] };
 138 }
 139
 140 test {
 141   &{$foo{A}}('A') and
 142   &{$foo{B}}('B') and
 143   &{$foo{C}}('C') and
 144   &{$foo{D}}('D') and
 145   &{$foo{E}}('E')
 146 };
 147
 148 for my $n (0..4) {
 149     $foo[$n] = sub { $n == $_[0] };
 150 }
 151
 152 test {
 153   &{$foo[0]}(0) and
 154   &{$foo[1]}(1) and
 155   &{$foo[2]}(2) and
 156   &{$foo[3]}(3) and
 157   &{$foo[4]}(4)
 158 };
 159
 160 for my $n (0..4) {
 161     $foo[$n] = sub {
 162                      # no intervening reference to $n here
 163                      sub { $n == $_[0] }
 164                    };
 165 }
 166
 167 test {
 168   $foo[0]->()->(0) and
 169   $foo[1]->()->(1) and
 170   $foo[2]->()->(2) and
 171   $foo[3]->()->(3) and
 172   $foo[4]->()->(4)
 173 };
 174
 175 {
 176     my $w;
 177     $w = sub {
 178         my ($i) = @_;
 179         test { $i == 10 };
 180         sub { $w };
 181     };
 182     $w->(10);
 183 }
 184
 185 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
 186
 187 {
 188     use strict;
 189
 190     use vars qw!$test!;
 191     my($debugging, %expected, $inner_type, $where_declared, $within);
 192     my($nc_attempt, $call_outer, $call_inner, $undef_outer);
 193     my($code, $inner_sub_test, $expected, $line, $errors, $output);
 194     my(@inners, $sub_test, $pid);
 195     $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
 196
 197     # The expected values for these tests
 198     %expected = (
 199         'global_scalar' => 1001,
 200         'global_array'  => 2101,
 201         'global_hash'   => 3004,
 202         'fs_scalar'     => 4001,
 203         'fs_array'      => 5101,
 204         'fs_hash'       => 6004,
 205         'sub_scalar'    => 7001,
 206         'sub_array'     => 8101,
 207         'sub_hash'      => 9004,
 208         'foreach'       => 10011,
 209     );
 210
 211     # Our innermost sub is either named or anonymous
 212     for $inner_type (qw!named anon!) {
 213       # And it may be declared at filescope, within a named
 214       # sub, or within an anon sub
 215       for $where_declared (qw!filescope in_named in_anon!) {
 216         # And that, in turn, may be within a foreach loop,
 217         # a naked block, or another named sub
 218         for $within (qw!foreach naked other_sub!) {
 219
 220           # Here are a number of variables which show what's
 221           # going on, in a way.
 222           $nc_attempt = 0+              # Named closure attempted
 223               ( ($inner_type eq 'named') ||
 224               ($within eq 'other_sub') ) ;
 225           $call_inner = 0+              # Need to call &inner
 226               ( ($inner_type eq 'anon') &&
 227               ($within eq 'other_sub') ) ;
 228           $call_outer = 0+              # Need to call &outer or &$outer
 229               ( ($inner_type eq 'anon') &&
 230               ($within ne 'other_sub') ) ;
 231           $undef_outer = 0+             # $outer is created but unused
 232               ( ($where_declared eq 'in_anon') &&
 233               (not $call_outer) ) ;
 234
 235           $code = "# This is a test script built by t/op/closure.t\n\n";
 236
 237           $code .= <<"DEBUG_INFO" if $debugging;
 238 # inner_type: $inner_type
 239 # where_declared: $where_declared
 240 # within: $within
 241 # nc_attempt: $nc_attempt
 242 # call_inner: $call_inner
 243 # call_outer: $call_outer
 244 # undef_outer: $undef_outer
 245 DEBUG_INFO
 246
 247           $code .= <<"END_MARK_ONE";
 248
 249 BEGIN { \$SIG{__WARN__} = sub {
 250     my \$msg = \$_[0];
 251 END_MARK_ONE
 252
 253           $code .=  <<"END_MARK_TWO" if $nc_attempt;
 254     return if index(\$msg, 'will not stay shared') != -1;
 255     return if index(\$msg, 'may be unavailable') != -1;
 256 END_MARK_TWO
 257
 258           $code .= <<"END_MARK_THREE";          # Backwhack a lot!
 259     print "not ok: got unexpected warning \$msg\\n";
 260 } }
 261
 262 {
 263     my \$test = $test;
 264     sub test (&) {
 265       my \$result = &{\$_[0]};
 266       print "not " unless \$result;
 267       print "ok \$test\\n";
 268       \$test++;
 269     }
 270 }
 271
 272 # some of the variables which the closure will access
 273 \$global_scalar = 1000;
 274 \@global_array = (2000, 2100, 2200, 2300);
 275 %global_hash = 3000..3009;
 276
 277 my \$fs_scalar = 4000;
 278 my \@fs_array = (5000, 5100, 5200, 5300);
 279 my %fs_hash = 6000..6009;
 280
 281 END_MARK_THREE
 282
 283           if ($where_declared eq 'filescope') {
 284             # Nothing here
 285           } elsif ($where_declared eq 'in_named') {
 286             $code .= <<'END';
 287 sub outer {
 288   my $sub_scalar = 7000;
 289   my @sub_array = (8000, 8100, 8200, 8300);
 290   my %sub_hash = 9000..9009;
 291 END
 292     # }
 293           } elsif ($where_declared eq 'in_anon') {
 294             $code .= <<'END';
 295 $outer = sub {
 296   my $sub_scalar = 7000;
 297   my @sub_array = (8000, 8100, 8200, 8300);
 298   my %sub_hash = 9000..9009;
 299 END
 300     # }
 301           } else {
 302             die "What was $where_declared?"
 303           }
 304
 305           if ($within eq 'foreach') {
 306             $code .= "
 307       my \$foreach = 12000;
 308       my \@list = (10000, 10010);
 309       foreach \$foreach (\@list) {
 310     " # }
 311           } elsif ($within eq 'naked') {
 312             $code .= "  { # naked block\n"      # }
 313           } elsif ($within eq 'other_sub') {
 314             $code .= "  sub inner_sub {\n"      # }
 315           } else {
 316             die "What was $within?"
 317           }
 318
 319           $sub_test = $test;
 320           @inners = ( qw!global_scalar global_array global_hash! ,
 321             qw!fs_scalar fs_array fs_hash! );
 322           push @inners, 'foreach' if $within eq 'foreach';
 323           if ($where_declared ne 'filescope') {
 324             push @inners, qw!sub_scalar sub_array sub_hash!;
 325           }
 326           for $inner_sub_test (@inners) {
 327
 328             if ($inner_type eq 'named') {
 329               $code .= "    sub named_$sub_test "
 330             } elsif ($inner_type eq 'anon') {
 331               $code .= "    \$anon_$sub_test = sub "
 332             } else {
 333               die "What was $inner_type?"
 334             }
 335
 336             # Now to write the body of the test sub
 337             if ($inner_sub_test eq 'global_scalar') {
 338               $code .= '{ ++$global_scalar }'
 339             } elsif ($inner_sub_test eq 'fs_scalar') {
 340               $code .= '{ ++$fs_scalar }'
 341             } elsif ($inner_sub_test eq 'sub_scalar') {
 342               $code .= '{ ++$sub_scalar }'
 343             } elsif ($inner_sub_test eq 'global_array') {
 344               $code .= '{ ++$global_array[1] }'
 345             } elsif ($inner_sub_test eq 'fs_array') {
 346               $code .= '{ ++$fs_array[1] }'
 347             } elsif ($inner_sub_test eq 'sub_array') {
 348               $code .= '{ ++$sub_array[1] }'
 349             } elsif ($inner_sub_test eq 'global_hash') {
 350               $code .= '{ ++$global_hash{3002} }'
 351             } elsif ($inner_sub_test eq 'fs_hash') {
 352               $code .= '{ ++$fs_hash{6002} }'
 353             } elsif ($inner_sub_test eq 'sub_hash') {
 354               $code .= '{ ++$sub_hash{9002} }'
 355             } elsif ($inner_sub_test eq 'foreach') {
 356               $code .= '{ ++$foreach }'
 357             } else {
 358               die "What was $inner_sub_test?"
 359             }
 360
 361             # Close up
 362             if ($inner_type eq 'anon') {
 363               $code .= ';'
 364             }
 365             $code .= "\n";
 366             $sub_test++;        # sub name sequence number
 367
 368           } # End of foreach $inner_sub_test
 369
 370           # Close up $within block              # {
 371           $code .= "  }\n\n";
 372
 373           # Close up $where_declared block
 374           if ($where_declared eq 'in_named') {  # {
 375             $code .= "}\n\n";
 376           } elsif ($where_declared eq 'in_anon') {      # {
 377             $code .= "};\n\n";
 378           }
 379
 380           # We may need to do something with the sub we just made...
 381           $code .= "undef \$outer;\n" if $undef_outer;
 382           $code .= "&inner_sub;\n" if $call_inner;
 383           if ($call_outer) {
 384             if ($where_declared eq 'in_named') {
 385               $code .= "&outer;\n\n";
 386             } elsif ($where_declared eq 'in_anon') {
 387               $code .= "&\$outer;\n\n"
 388             }
 389           }
 390
 391           # Now, we can actually prep to run the tests.
 392           for $inner_sub_test (@inners) {
 393             $expected = $expected{$inner_sub_test} or
 394               die "expected $inner_sub_test missing";
 395
 396             # Named closures won't access the expected vars
 397             if ( $nc_attempt and
 398                 substr($inner_sub_test, 0, 4) eq "sub_" ) {
 399               $expected = 1;
 400             }
 401
 402             # If you make a sub within a foreach loop,
 403             # what happens if it tries to access the
 404             # foreach index variable? If it's a named
 405             # sub, it gets the var from "outside" the loop,
 406             # but if it's anon, it gets the value to which
 407             # the index variable is aliased.
 408             #
 409             # Of course, if the value was set only
 410             # within another sub which was never called,
 411             # the value has not been set yet.
 412             #
 413             if ($inner_sub_test eq 'foreach') {
 414               if ($inner_type eq 'named') {
 415                 if ($call_outer || ($where_declared eq 'filescope')) {
 416                   $expected = 12001
 417                 } else {
 418                   $expected = 1
 419                 }
 420               }
 421             }
 422
 423             # Here's the test:
 424             if ($inner_type eq 'anon') {
 425               $code .= "test { &\$anon_$test == $expected };\n"
 426             } else {
 427               $code .= "test { &named_$test == $expected };\n"
 428             }
 429             $test++;
 430           }
 431
 432           if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') {
 433             # Fork off a new perl to run the tests.
 434             # (This is so we can catch spurious warnings.)
 435             $| = 1; print ""; $| = 0; # flush output before forking
 436             pipe READ, WRITE or die "Can't make pipe: $!";
 437             pipe READ2, WRITE2 or die "Can't make second pipe: $!";
 438             die "Can't fork: $!" unless defined($pid = open PERL, "|-");
 439             unless ($pid) {
 440               # Child process here. We're going to send errors back
 441               # through the extra pipe.
 442               close READ;
 443               close READ2;
 444               open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
 445               open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
 446               exec './perl', '-w', '-'
 447                 or die "Can't exec ./perl: $!";
 448             } else {
 449               # Parent process here.
 450               close WRITE;
 451               close WRITE2;
 452               print PERL $code;
 453               close PERL;
 454               { local $/;
 455                 $output = join '', <READ>;
 456                 $errors = join '', <READ2>; }
 457               close READ;
 458               close READ2;
 459             }
 460           } else {
 461             # No fork().  Do it the hard way.
 462             my $cmdfile = "tcmd$$";  $cmdfile++ while -e $cmdfile;
 463             my $errfile = "terr$$";  $errfile++ while -e $errfile;
 464             my @tmpfiles = ($cmdfile, $errfile);
 465             open CMD, ">$cmdfile"; print CMD $code; close CMD;
 466             my $cmd = (($^O eq 'VMS') ? "MCR $^X"
 467                        : ($^O eq 'MSWin32') ? '.\perl'
 468                        : './perl');
 469             $cmd .= " -w $cmdfile 2>$errfile";
 470             if ($^O eq 'VMS' or $^O eq 'MSWin32') {
 471               # Use pipe instead of system so we don't inherit STD* from
 472               # this process, and then foul our pipe back to parent by
 473               # redirecting output in the child.
 474               open PERL,"$cmd |" or die "Can't open pipe: $!\n";
 475               { local $/; $output = join '', <PERL> }
 476               close PERL;
 477             } else {
 478               my $outfile = "tout$$";  $outfile++ while -e $outfile;
 479               push @tmpfiles, $outfile;
 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               $debugging or do { 1 while unlink @tmpfiles };
 486               exit;
 487             }
 488             { local $/; open IN, $errfile; $errors = <IN>; close IN }
 489             1 while unlink @tmpfiles;
 490           }
 491           print $output;
 492           print STDERR $errors;
 493           if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
 494             my $lnum = 0;
 495             for $line (split '\n', $code) {
 496               printf "%3d:  %s\n", ++$lnum, $line;
 497             }
 498           }
 499           printf "not ok: exited with error code %04X\n", $? if $?;
 500           print "-" x 30, "\n" if $debugging;
 501
 502         }       # End of foreach $within
 503       } # End of foreach $where_declared
 504     }   # End of foreach $inner_type
 505
 506 }
 507