This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
new (Feb 1) perlembed.pod
[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
8print "1..167\n";
9
10my $test = 1;
11sub test (&) {
12 print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
13 $test++;
14}
15
16my $i = 1;
17sub foo { $i = shift if @_; $i }
18
19# no closure
20test { foo == 1 };
21foo(2);
22test { foo == 2 };
23
24# closure: lexical outside sub
25my $foo = sub {$i = shift if @_; $i };
26my $bar = sub {$i = shift if @_; $i };
27test {&$foo() == 2 };
28&$foo(3);
29test {&$foo() == 3 };
30# did the lexical change?
31test { foo == 3 and $i == 3};
32# did the second closure notice?
33test {&$bar() == 3 };
34
35# closure: lexical inside sub
36sub bar {
37 my $i = shift;
38 sub { $i = shift if @_; $i }
39}
40
41$foo = bar(4);
42$bar = bar(5);
43test {&$foo() == 4 };
44&$foo(6);
45test {&$foo() == 6 };
46test {&$bar() == 5 };
47
48# nested closures
49sub 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();
61test {&$foo() == 7 };
62&$foo(8);
63test {&$foo() == 8 };
64test {&$bar() == 7 };
65
66$foo = bizz(9);
67$bar = bizz(10);
68test {&$foo(11)-1 == &$bar()};
69
70my @foo;
71for (qw(0 1 2 3 4)) {
72 my $i = $_;
73 $foo[$_] = sub {$i = shift if @_; $i };
74}
75
76test {
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
84for (0 .. 4) {
85 &{$foo[$_]}(4-$_);
86}
87
88test {
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
96sub 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();
106test {
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
114for (0 .. 4) {
115 &{$foo[$_]}(4-$_);
116}
117
118test {
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
193DEBUG_INFO
194
195 $code .= <<"END_MARK_ONE";
196
197BEGIN { \$SIG{__WARN__} = sub {
198 my \$msg = \$_[0];
199END_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;
204END_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
225my \$fs_scalar = 4000;
226my \@fs_array = (5000, 5100, 5200, 5300);
227my %fs_hash = 6000..6009;
228
229END_MARK_THREE
230
231 if ($where_declared eq 'filescope') {
232 # Nothing here
233 } elsif ($where_declared eq 'in_named') {
234 $code .= <<'END';
235sub outer {
236 my $sub_scalar = 7000;
237 my @sub_array = (8000, 8100, 8200, 8300);
238 my %sub_hash = 9000..9009;
239END
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;
247END
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}