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