4 # Original written by Ulrich Pfeifer on 2 Jan 1997.
5 # Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
19 print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
24 sub foo { $i = shift if @_; $i }
31 # closure: lexical outside sub
32 my $foo = sub {$i = shift if @_; $i };
33 my $bar = sub {$i = shift if @_; $i };
37 # did the lexical change?
38 test { foo == 3 and $i == 3};
39 # did the second closure notice?
42 # closure: lexical inside sub
45 sub { $i = shift if @_; $i }
60 sub {$i = shift if @_; $i };
63 sub {$i = shift if @_; $i };
75 test {&$foo(11)-1 == &$bar()};
80 $foo[$_] = sub {$i = shift if @_; $i };
105 for (qw(0 1 2 3 4)) {
107 $foo[$_] = sub {$i = shift if @_; $i };
114 &{$foo[0]}() == 0 and
115 &{$foo[1]}() == 1 and
116 &{$foo[2]}() == 2 and
117 &{$foo[3]}() == 3 and
126 &{$foo[0]}() == 4 and
127 &{$foo[1]}() == 3 and
128 &{$foo[2]}() == 2 and
129 &{$foo[3]}() == 1 and
133 exit 0 unless $Config{'d_fork'};
135 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
141 my($debugging, %expected, $inner_type, $where_declared, $within);
142 my($nc_attempt, $call_outer, $call_inner, $undef_outer);
143 my($code, $inner_sub_test, $expected, $line, $errors, $output);
144 my(@inners, $sub_test, $pid);
145 $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
147 # The expected values for these tests
149 'global_scalar' => 1001,
150 'global_array' => 2101,
151 'global_hash' => 3004,
155 'sub_scalar' => 7001,
161 # Our innermost sub is either named or anonymous
162 for $inner_type (qw!named anon!) {
163 # And it may be declared at filescope, within a named
164 # sub, or within an anon sub
165 for $where_declared (qw!filescope in_named in_anon!) {
166 # And that, in turn, may be within a foreach loop,
167 # a naked block, or another named sub
168 for $within (qw!foreach naked other_sub!) {
170 # Here are a number of variables which show what's
171 # going on, in a way.
172 $nc_attempt = 0+ # Named closure attempted
173 ( ($inner_type eq 'named') ||
174 ($within eq 'other_sub') ) ;
175 $call_inner = 0+ # Need to call &inner
176 ( ($inner_type eq 'anon') &&
177 ($within eq 'other_sub') ) ;
178 $call_outer = 0+ # Need to call &outer or &$outer
179 ( ($inner_type eq 'anon') &&
180 ($within ne 'other_sub') ) ;
181 $undef_outer = 0+ # $outer is created but unused
182 ( ($where_declared eq 'in_anon') &&
183 (not $call_outer) ) ;
185 $code = "# This is a test script built by t/op/closure.t\n\n";
187 $code .= <<"DEBUG_INFO" if $debugging;
188 # inner_type: $inner_type
189 # where_declared: $where_declared
191 # nc_attempt: $nc_attempt
192 # call_inner: $call_inner
193 # call_outer: $call_outer
194 # undef_outer: $undef_outer
197 $code .= <<"END_MARK_ONE";
199 BEGIN { \$SIG{__WARN__} = sub {
203 $code .= <<"END_MARK_TWO" if $nc_attempt;
204 return if index(\$msg, 'will not stay shared') != -1;
205 return if index(\$msg, 'may be unavailable') != -1;
208 $code .= <<"END_MARK_THREE"; # Backwhack a lot!
209 print "not ok: got unexpected warning \$msg\\n";
215 my \$result = &{\$_[0]};
216 print "not " unless \$result;
217 print "ok \$test\\n";
222 # some of the variables which the closure will access
223 \$global_scalar = 1000;
224 \@global_array = (2000, 2100, 2200, 2300);
225 %global_hash = 3000..3009;
227 my \$fs_scalar = 4000;
228 my \@fs_array = (5000, 5100, 5200, 5300);
229 my %fs_hash = 6000..6009;
233 if ($where_declared eq 'filescope') {
235 } elsif ($where_declared eq 'in_named') {
238 my $sub_scalar = 7000;
239 my @sub_array = (8000, 8100, 8200, 8300);
240 my %sub_hash = 9000..9009;
243 } elsif ($where_declared eq 'in_anon') {
246 my $sub_scalar = 7000;
247 my @sub_array = (8000, 8100, 8200, 8300);
248 my %sub_hash = 9000..9009;
252 die "What was $where_declared?"
255 if ($within eq 'foreach') {
257 my \$foreach = 12000;
258 my \@list = (10000, 10010);
259 foreach \$foreach (\@list) {
261 } elsif ($within eq 'naked') {
262 $code .= " { # naked block\n" # }
263 } elsif ($within eq 'other_sub') {
264 $code .= " sub inner_sub {\n" # }
266 die "What was $within?"
270 @inners = ( qw!global_scalar global_array global_hash! ,
271 qw!fs_scalar fs_array fs_hash! );
272 push @inners, 'foreach' if $within eq 'foreach';
273 if ($where_declared ne 'filescope') {
274 push @inners, qw!sub_scalar sub_array sub_hash!;
276 for $inner_sub_test (@inners) {
278 if ($inner_type eq 'named') {
279 $code .= " sub named_$sub_test "
280 } elsif ($inner_type eq 'anon') {
281 $code .= " \$anon_$sub_test = sub "
283 die "What was $inner_type?"
286 # Now to write the body of the test sub
287 if ($inner_sub_test eq 'global_scalar') {
288 $code .= '{ ++$global_scalar }'
289 } elsif ($inner_sub_test eq 'fs_scalar') {
290 $code .= '{ ++$fs_scalar }'
291 } elsif ($inner_sub_test eq 'sub_scalar') {
292 $code .= '{ ++$sub_scalar }'
293 } elsif ($inner_sub_test eq 'global_array') {
294 $code .= '{ ++$global_array[1] }'
295 } elsif ($inner_sub_test eq 'fs_array') {
296 $code .= '{ ++$fs_array[1] }'
297 } elsif ($inner_sub_test eq 'sub_array') {
298 $code .= '{ ++$sub_array[1] }'
299 } elsif ($inner_sub_test eq 'global_hash') {
300 $code .= '{ ++$global_hash{3002} }'
301 } elsif ($inner_sub_test eq 'fs_hash') {
302 $code .= '{ ++$fs_hash{6002} }'
303 } elsif ($inner_sub_test eq 'sub_hash') {
304 $code .= '{ ++$sub_hash{9002} }'
305 } elsif ($inner_sub_test eq 'foreach') {
306 $code .= '{ ++$foreach }'
308 die "What was $inner_sub_test?"
312 if ($inner_type eq 'anon') {
316 $sub_test++; # sub name sequence number
318 } # End of foreach $inner_sub_test
320 # Close up $within block # {
323 # Close up $where_declared block
324 if ($where_declared eq 'in_named') { # {
326 } elsif ($where_declared eq 'in_anon') { # {
330 # We may need to do something with the sub we just made...
331 $code .= "undef \$outer;\n" if $undef_outer;
332 $code .= "&inner_sub;\n" if $call_inner;
334 if ($where_declared eq 'in_named') {
335 $code .= "&outer;\n\n";
336 } elsif ($where_declared eq 'in_anon') {
337 $code .= "&\$outer;\n\n"
341 # Now, we can actually prep to run the tests.
342 for $inner_sub_test (@inners) {
343 $expected = $expected{$inner_sub_test} or
344 die "expected $inner_sub_test missing";
346 # Named closures won't access the expected vars
348 substr($inner_sub_test, 0, 4) eq "sub_" ) {
352 # If you make a sub within a foreach loop,
353 # what happens if it tries to access the
354 # foreach index variable? If it's a named
355 # sub, it gets the var from "outside" the loop,
356 # but if it's anon, it gets the value to which
357 # the index variable is aliased.
359 # Of course, if the value was set only
360 # within another sub which was never called,
361 # the value has not been set yet.
363 if ($inner_sub_test eq 'foreach') {
364 if ($inner_type eq 'named') {
365 if ($call_outer || ($where_declared eq 'filescope')) {
374 if ($inner_type eq 'anon') {
375 $code .= "test { &\$anon_$test == $expected };\n"
377 $code .= "test { &named_$test == $expected };\n"
382 if ($Config{d_fork} and $^O ne 'VMS') {
383 # Fork off a new perl to run the tests.
384 # (This is so we can catch spurious warnings.)
385 $| = 1; print ""; $| = 0; # flush output before forking
386 pipe READ, WRITE or die "Can't make pipe: $!";
387 pipe READ2, WRITE2 or die "Can't make second pipe: $!";
388 die "Can't fork: $!" unless defined($pid = open PERL, "|-");
390 # Child process here. We're going to send errors back
391 # through the extra pipe.
394 open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!";
395 open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
396 exec './perl', '-w', '-'
397 or die "Can't exec ./perl: $!";
399 # Parent process here.
405 $output = join '', <READ>;
406 $errors = join '', <READ2>; }
411 # No fork(). Do it the hard way.
412 my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile;
413 my $outfile = "tout$$"; $outfile++ while -e $outfile;
414 my $errfile = "terr$$"; $errfile++ while -e $errfile;
415 open CMD, ">$cmdfile"; print CMD $code; close CMD;
416 my $cmd = ($^O eq 'VMS') ? "MCR $^X" : "./perl";
417 $cmd .= " -w $cmdfile >$outfile 2>$errfile";
419 $? = 0 if $^O eq 'VMS' and $? & 1; # Keep Unix-minded code below happy
421 printf "not ok: exited with error code %04X\n", $?;
422 $debugging or do { 1 while unlink $cmdfile, $outfile, $errfile };
426 open IN, $outfile; $output = <IN>; close IN;
427 open IN, $errfile; $errors = <IN>; close IN; }
428 1 while unlink $cmdfile, $outfile, $errfile;
431 print STDERR $errors;
432 if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
434 for $line (split '\n', $code) {
435 printf "%3d: %s\n", ++$lnum, $line;
438 printf "not ok: exited with error code %04X\n", $? if $?;
439 print "-" x 30, "\n" if $debugging;
441 } # End of foreach $within
442 } # End of foreach $where_declared
443 } # End of foreach $inner_type