| 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 | unshift @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 | |