4 # Original written by Ulrich Pfeifer on 2 Jan 1997.
5 # Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
7 # Run with -debug for debugging output.
21 print $ok ? "ok $test\n" : "not ok $test\n";
22 printf "# Failed at line %d\n", (caller)[2] unless $ok;
27 sub foo { $i = shift if @_; $i }
34 # closure: lexical outside sub
35 my $foo = sub {$i = shift if @_; $i };
36 my $bar = sub {$i = shift if @_; $i };
40 # did the lexical change?
41 test { foo == 3 and $i == 3};
42 # did the second closure notice?
45 # closure: lexical inside sub
48 sub { $i = shift if @_; $i }
63 sub {$i = shift if @_; $i };
66 sub {$i = shift if @_; $i };
78 test {&$foo(11)-1 == &$bar()};
83 $foo[$_] = sub {$i = shift if @_; $i };
100 &{$foo[1]}() == 3 and
101 &{$foo[2]}() == 2 and
102 &{$foo[3]}() == 1 and
108 for (qw(0 1 2 3 4)) {
110 $foo[$_] = sub {$i = shift if @_; $i };
117 &{$foo[0]}() == 0 and
118 &{$foo[1]}() == 1 and
119 &{$foo[2]}() == 2 and
120 &{$foo[3]}() == 3 and
129 &{$foo[0]}() == 4 and
130 &{$foo[1]}() == 3 and
131 &{$foo[2]}() == 2 and
132 &{$foo[3]}() == 1 and
136 # test if closures get created in optimized for loops
139 for my $n ('A'..'E') {
140 $foo{$n} = sub { $n eq $_[0] };
152 $foo[$n] = sub { $n == $_[0] };
165 # no intervening reference to $n here
188 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
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';
200 # The expected values for these tests
202 'global_scalar' => 1001,
203 'global_array' => 2101,
204 'global_hash' => 3004,
208 'sub_scalar' => 7001,
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!) {
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) ) ;
238 $code = "# This is a test script built by t/op/closure.t\n\n";
240 print <<"DEBUG_INFO" if $debugging;
241 # inner_type: $inner_type
242 # where_declared: $where_declared
244 # nc_attempt: $nc_attempt
245 # call_inner: $call_inner
246 # call_outer: $call_outer
247 # undef_outer: $undef_outer
250 $code .= <<"END_MARK_ONE";
252 BEGIN { \$SIG{__WARN__} = sub {
256 $code .= <<"END_MARK_TWO" if $nc_attempt;
257 return if index(\$msg, 'will not stay shared') != -1;
258 return if index(\$msg, 'may be unavailable') != -1;
261 $code .= <<"END_MARK_THREE"; # Backwhack a lot!
262 print "not ok: got unexpected warning \$msg\\n";
269 print \$ok ? "ok \$test\n" : "not ok \$test\n";
270 printf "# Failed at line %d\n", (caller)[2] unless \$ok;
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;
280 my \$fs_scalar = 4000;
281 my \@fs_array = (5000, 5100, 5200, 5300);
282 my %fs_hash = 6000..6009;
286 if ($where_declared eq 'filescope') {
288 } elsif ($where_declared eq 'in_named') {
291 my $sub_scalar = 7000;
292 my @sub_array = (8000, 8100, 8200, 8300);
293 my %sub_hash = 9000..9009;
296 } elsif ($where_declared eq 'in_anon') {
299 my $sub_scalar = 7000;
300 my @sub_array = (8000, 8100, 8200, 8300);
301 my %sub_hash = 9000..9009;
305 die "What was $where_declared?"
308 if ($within eq 'foreach') {
310 my \$foreach = 12000;
311 my \@list = (10000, 10010);
312 foreach \$foreach (\@list) {
314 } elsif ($within eq 'naked') {
315 $code .= " { # naked block\n" # }
316 } elsif ($within eq 'other_sub') {
317 $code .= " sub inner_sub {\n" # }
319 die "What was $within?"
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!;
329 for $inner_sub_test (@inners) {
331 if ($inner_type eq 'named') {
332 $code .= " sub named_$sub_test "
333 } elsif ($inner_type eq 'anon') {
334 $code .= " \$anon_$sub_test = sub "
336 die "What was $inner_type?"
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 }'
361 die "What was $inner_sub_test?"
365 if ($inner_type eq 'anon') {
369 $sub_test++; # sub name sequence number
371 } # End of foreach $inner_sub_test
373 # Close up $within block # {
376 # Close up $where_declared block
377 if ($where_declared eq 'in_named') { # {
379 } elsif ($where_declared eq 'in_anon') { # {
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;
387 if ($where_declared eq 'in_named') {
388 $code .= "&outer;\n\n";
389 } elsif ($where_declared eq 'in_anon') {
390 $code .= "&\$outer;\n\n"
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";
399 # Named closures won't access the expected vars
401 substr($inner_sub_test, 0, 4) eq "sub_" ) {
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.
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.
416 if ($inner_sub_test eq 'foreach') {
417 if ($inner_type eq 'named') {
418 if ($call_outer || ($where_declared eq 'filescope')) {
427 if ($inner_type eq 'anon') {
428 $code .= "test { &\$anon_$test == $expected };\n"
430 $code .= "test { &named_$test == $expected };\n"
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, "|-");
443 # Child process here. We're going to send errors back
444 # through the extra pipe.
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: $!";
452 # Parent process here.
458 $output = join '', <READ>;
459 $errors = join '', <READ2>; }
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'
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> }
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 }
489 printf "not ok: exited with error code %04X\n", $?;
490 $debugging or do { 1 while unlink @tmpfiles };
493 { local $/; open IN, $errfile; $errors = <IN>; close IN }
494 1 while unlink @tmpfiles;
497 print STDERR $errors;
498 if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
500 for $line (split '\n', $code) {
501 printf "%3d: %s\n", ++$lnum, $line;
504 printf "not ok: exited with error code %04X\n", $? if $?;
505 print '#', "-" x 30, "\n" if $debugging;
507 } # End of foreach $within
508 } # End of foreach $where_declared
509 } # End of foreach $inner_type
513 # The following dumps core with perl <= 5.8.0
514 BEGIN { $vanishing_pad = sub { eval $_[0] } }
516 test { $vanishing_pad->( '$some_var' ) == 123 };