This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Double FETCH test
[perl5.git] / t / op / closure.t
CommitLineData
0a753a76
PP
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
f86702cc
PP
8BEGIN {
9 chdir 't' if -d 't';
20822f61 10 @INC = '../lib';
f86702cc
PP
11}
12
13use Config;
14
354992b1 15print "1..171\n";
0a753a76
PP
16
17my $test = 1;
18sub test (&) {
19 print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
20 $test++;
21}
22
23my $i = 1;
24sub foo { $i = shift if @_; $i }
25
26# no closure
27test { foo == 1 };
28foo(2);
29test { foo == 2 };
30
31# closure: lexical outside sub
32my $foo = sub {$i = shift if @_; $i };
33my $bar = sub {$i = shift if @_; $i };
34test {&$foo() == 2 };
35&$foo(3);
36test {&$foo() == 3 };
37# did the lexical change?
38test { foo == 3 and $i == 3};
39# did the second closure notice?
40test {&$bar() == 3 };
41
42# closure: lexical inside sub
43sub bar {
44 my $i = shift;
45 sub { $i = shift if @_; $i }
46}
47
48$foo = bar(4);
49$bar = bar(5);
50test {&$foo() == 4 };
51&$foo(6);
52test {&$foo() == 6 };
53test {&$bar() == 5 };
54
55# nested closures
56sub 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();
68test {&$foo() == 7 };
69&$foo(8);
70test {&$foo() == 8 };
71test {&$bar() == 7 };
72
73$foo = bizz(9);
74$bar = bizz(10);
75test {&$foo(11)-1 == &$bar()};
76
77my @foo;
78for (qw(0 1 2 3 4)) {
79 my $i = $_;
80 $foo[$_] = sub {$i = shift if @_; $i };
81}
82
83test {
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
91for (0 .. 4) {
92 &{$foo[$_]}(4-$_);
93}
94
95test {
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
103sub 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();
113test {
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
121for (0 .. 4) {
122 &{$foo[$_]}(4-$_);
123}
124
125test {
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
3c1f3fdf
GS
133# test if closures get created in optimized for loops
134
135my %foo;
136for my $n ('A'..'E') {
137 $foo{$n} = sub { $n eq $_[0] };
138}
139
140test {
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
148for my $n (0..4) {
149 $foo[$n] = sub { $n == $_[0] };
150}
151
152test {
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
94f23f41
GS
160for my $n (0..4) {
161 $foo[$n] = sub {
162 # no intervening reference to $n here
163 sub { $n == $_[0] }
164 };
165}
166
167test {
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
354992b1
GS
175{
176 my $w;
177 $w = sub {
178 my ($i) = @_;
179 test { $i == 10 };
180 sub { $w };
181 };
182 $w->(10);
183}
94f23f41 184
0a753a76
PP
185# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
186
187{
0a753a76
PP
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
245DEBUG_INFO
246
247 $code .= <<"END_MARK_ONE";
248
249BEGIN { \$SIG{__WARN__} = sub {
250 my \$msg = \$_[0];
251END_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;
256END_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
277my \$fs_scalar = 4000;
278my \@fs_array = (5000, 5100, 5200, 5300);
279my %fs_hash = 6000..6009;
280
281END_MARK_THREE
282
283 if ($where_declared eq 'filescope') {
284 # Nothing here
285 } elsif ($where_declared eq 'in_named') {
286 $code .= <<'END';
287sub outer {
288 my $sub_scalar = 7000;
289 my @sub_array = (8000, 8100, 8200, 8300);
290 my %sub_hash = 9000..9009;
291END
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;
299END
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
2986a63f 432 if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
f86702cc
PP
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', '-'
0a753a76 447 or die "Can't exec ./perl: $!";
f86702cc
PP
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;
f86702cc 463 my $errfile = "terr$$"; $errfile++ while -e $errfile;
aa689395 464 my @tmpfiles = ($cmdfile, $errfile);
f86702cc 465 open CMD, ">$cmdfile"; print CMD $code; close CMD;
68dc0745
PP
466 my $cmd = (($^O eq 'VMS') ? "MCR $^X"
467 : ($^O eq 'MSWin32') ? '.\perl'
95e8664e 468 : ($^O eq 'MacOS') ? $^X
2986a63f 469 : ($^O eq 'NetWare') ? 'perl'
68dc0745 470 : './perl');
aa689395 471 $cmd .= " -w $cmdfile 2>$errfile";
2986a63f 472 if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
aa689395
PP
473 # Use pipe instead of system so we don't inherit STD* from
474 # this process, and then foul our pipe back to parent by
475 # redirecting output in the child.
476 open PERL,"$cmd |" or die "Can't open pipe: $!\n";
477 { local $/; $output = join '', <PERL> }
478 close PERL;
479 } else {
480 my $outfile = "tout$$"; $outfile++ while -e $outfile;
481 push @tmpfiles, $outfile;
482 system "$cmd >$outfile";
483 { local $/; open IN, $outfile; $output = <IN>; close IN }
484 }
f86702cc
PP
485 if ($?) {
486 printf "not ok: exited with error code %04X\n", $?;
aa689395 487 $debugging or do { 1 while unlink @tmpfiles };
f86702cc
PP
488 exit;
489 }
aa689395
PP
490 { local $/; open IN, $errfile; $errors = <IN>; close IN }
491 1 while unlink @tmpfiles;
0a753a76 492 }
f86702cc
PP
493 print $output;
494 print STDERR $errors;
0a753a76
PP
495 if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
496 my $lnum = 0;
497 for $line (split '\n', $code) {
498 printf "%3d: %s\n", ++$lnum, $line;
499 }
500 }
f86702cc
PP
501 printf "not ok: exited with error code %04X\n", $? if $?;
502 print "-" x 30, "\n" if $debugging;
0a753a76
PP
503
504 } # End of foreach $within
505 } # End of foreach $where_declared
506 } # End of foreach $inner_type
507
508}
3c1f3fdf 509