Commit | Line | Data |
0a753a76 |
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 |
8 | BEGIN { |
9 | chdir 't' if -d 't'; |
93430cb4 |
10 | unshift @INC, '../lib'; |
f86702cc |
11 | } |
12 | |
13 | use Config; |
14 | |
94f23f41 |
15 | print "1..170\n"; |
0a753a76 |
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 | |
3c1f3fdf |
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 | |
94f23f41 |
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 | |
0a753a76 |
176 | # Additional tests by Tom Phoenix <rootbeer@teleport.com>. |
177 | |
178 | { |
0a753a76 |
179 | use strict; |
180 | |
181 | use vars qw!$test!; |
182 | my($debugging, %expected, $inner_type, $where_declared, $within); |
183 | my($nc_attempt, $call_outer, $call_inner, $undef_outer); |
184 | my($code, $inner_sub_test, $expected, $line, $errors, $output); |
185 | my(@inners, $sub_test, $pid); |
186 | $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; |
187 | |
188 | # The expected values for these tests |
189 | %expected = ( |
190 | 'global_scalar' => 1001, |
191 | 'global_array' => 2101, |
192 | 'global_hash' => 3004, |
193 | 'fs_scalar' => 4001, |
194 | 'fs_array' => 5101, |
195 | 'fs_hash' => 6004, |
196 | 'sub_scalar' => 7001, |
197 | 'sub_array' => 8101, |
198 | 'sub_hash' => 9004, |
199 | 'foreach' => 10011, |
200 | ); |
201 | |
202 | # Our innermost sub is either named or anonymous |
203 | for $inner_type (qw!named anon!) { |
204 | # And it may be declared at filescope, within a named |
205 | # sub, or within an anon sub |
206 | for $where_declared (qw!filescope in_named in_anon!) { |
207 | # And that, in turn, may be within a foreach loop, |
208 | # a naked block, or another named sub |
209 | for $within (qw!foreach naked other_sub!) { |
210 | |
211 | # Here are a number of variables which show what's |
212 | # going on, in a way. |
213 | $nc_attempt = 0+ # Named closure attempted |
214 | ( ($inner_type eq 'named') || |
215 | ($within eq 'other_sub') ) ; |
216 | $call_inner = 0+ # Need to call &inner |
217 | ( ($inner_type eq 'anon') && |
218 | ($within eq 'other_sub') ) ; |
219 | $call_outer = 0+ # Need to call &outer or &$outer |
220 | ( ($inner_type eq 'anon') && |
221 | ($within ne 'other_sub') ) ; |
222 | $undef_outer = 0+ # $outer is created but unused |
223 | ( ($where_declared eq 'in_anon') && |
224 | (not $call_outer) ) ; |
225 | |
226 | $code = "# This is a test script built by t/op/closure.t\n\n"; |
227 | |
228 | $code .= <<"DEBUG_INFO" if $debugging; |
229 | # inner_type: $inner_type |
230 | # where_declared: $where_declared |
231 | # within: $within |
232 | # nc_attempt: $nc_attempt |
233 | # call_inner: $call_inner |
234 | # call_outer: $call_outer |
235 | # undef_outer: $undef_outer |
236 | DEBUG_INFO |
237 | |
238 | $code .= <<"END_MARK_ONE"; |
239 | |
240 | BEGIN { \$SIG{__WARN__} = sub { |
241 | my \$msg = \$_[0]; |
242 | END_MARK_ONE |
243 | |
244 | $code .= <<"END_MARK_TWO" if $nc_attempt; |
245 | return if index(\$msg, 'will not stay shared') != -1; |
246 | return if index(\$msg, 'may be unavailable') != -1; |
247 | END_MARK_TWO |
248 | |
249 | $code .= <<"END_MARK_THREE"; # Backwhack a lot! |
250 | print "not ok: got unexpected warning \$msg\\n"; |
251 | } } |
252 | |
253 | { |
254 | my \$test = $test; |
255 | sub test (&) { |
256 | my \$result = &{\$_[0]}; |
257 | print "not " unless \$result; |
258 | print "ok \$test\\n"; |
259 | \$test++; |
260 | } |
261 | } |
262 | |
263 | # some of the variables which the closure will access |
264 | \$global_scalar = 1000; |
265 | \@global_array = (2000, 2100, 2200, 2300); |
266 | %global_hash = 3000..3009; |
267 | |
268 | my \$fs_scalar = 4000; |
269 | my \@fs_array = (5000, 5100, 5200, 5300); |
270 | my %fs_hash = 6000..6009; |
271 | |
272 | END_MARK_THREE |
273 | |
274 | if ($where_declared eq 'filescope') { |
275 | # Nothing here |
276 | } elsif ($where_declared eq 'in_named') { |
277 | $code .= <<'END'; |
278 | sub outer { |
279 | my $sub_scalar = 7000; |
280 | my @sub_array = (8000, 8100, 8200, 8300); |
281 | my %sub_hash = 9000..9009; |
282 | END |
283 | # } |
284 | } elsif ($where_declared eq 'in_anon') { |
285 | $code .= <<'END'; |
286 | $outer = sub { |
287 | my $sub_scalar = 7000; |
288 | my @sub_array = (8000, 8100, 8200, 8300); |
289 | my %sub_hash = 9000..9009; |
290 | END |
291 | # } |
292 | } else { |
293 | die "What was $where_declared?" |
294 | } |
295 | |
296 | if ($within eq 'foreach') { |
297 | $code .= " |
298 | my \$foreach = 12000; |
299 | my \@list = (10000, 10010); |
300 | foreach \$foreach (\@list) { |
301 | " # } |
302 | } elsif ($within eq 'naked') { |
303 | $code .= " { # naked block\n" # } |
304 | } elsif ($within eq 'other_sub') { |
305 | $code .= " sub inner_sub {\n" # } |
306 | } else { |
307 | die "What was $within?" |
308 | } |
309 | |
310 | $sub_test = $test; |
311 | @inners = ( qw!global_scalar global_array global_hash! , |
312 | qw!fs_scalar fs_array fs_hash! ); |
313 | push @inners, 'foreach' if $within eq 'foreach'; |
314 | if ($where_declared ne 'filescope') { |
315 | push @inners, qw!sub_scalar sub_array sub_hash!; |
316 | } |
317 | for $inner_sub_test (@inners) { |
318 | |
319 | if ($inner_type eq 'named') { |
320 | $code .= " sub named_$sub_test " |
321 | } elsif ($inner_type eq 'anon') { |
322 | $code .= " \$anon_$sub_test = sub " |
323 | } else { |
324 | die "What was $inner_type?" |
325 | } |
326 | |
327 | # Now to write the body of the test sub |
328 | if ($inner_sub_test eq 'global_scalar') { |
329 | $code .= '{ ++$global_scalar }' |
330 | } elsif ($inner_sub_test eq 'fs_scalar') { |
331 | $code .= '{ ++$fs_scalar }' |
332 | } elsif ($inner_sub_test eq 'sub_scalar') { |
333 | $code .= '{ ++$sub_scalar }' |
334 | } elsif ($inner_sub_test eq 'global_array') { |
335 | $code .= '{ ++$global_array[1] }' |
336 | } elsif ($inner_sub_test eq 'fs_array') { |
337 | $code .= '{ ++$fs_array[1] }' |
338 | } elsif ($inner_sub_test eq 'sub_array') { |
339 | $code .= '{ ++$sub_array[1] }' |
340 | } elsif ($inner_sub_test eq 'global_hash') { |
341 | $code .= '{ ++$global_hash{3002} }' |
342 | } elsif ($inner_sub_test eq 'fs_hash') { |
343 | $code .= '{ ++$fs_hash{6002} }' |
344 | } elsif ($inner_sub_test eq 'sub_hash') { |
345 | $code .= '{ ++$sub_hash{9002} }' |
346 | } elsif ($inner_sub_test eq 'foreach') { |
347 | $code .= '{ ++$foreach }' |
348 | } else { |
349 | die "What was $inner_sub_test?" |
350 | } |
351 | |
352 | # Close up |
353 | if ($inner_type eq 'anon') { |
354 | $code .= ';' |
355 | } |
356 | $code .= "\n"; |
357 | $sub_test++; # sub name sequence number |
358 | |
359 | } # End of foreach $inner_sub_test |
360 | |
361 | # Close up $within block # { |
362 | $code .= " }\n\n"; |
363 | |
364 | # Close up $where_declared block |
365 | if ($where_declared eq 'in_named') { # { |
366 | $code .= "}\n\n"; |
367 | } elsif ($where_declared eq 'in_anon') { # { |
368 | $code .= "};\n\n"; |
369 | } |
370 | |
371 | # We may need to do something with the sub we just made... |
372 | $code .= "undef \$outer;\n" if $undef_outer; |
373 | $code .= "&inner_sub;\n" if $call_inner; |
374 | if ($call_outer) { |
375 | if ($where_declared eq 'in_named') { |
376 | $code .= "&outer;\n\n"; |
377 | } elsif ($where_declared eq 'in_anon') { |
378 | $code .= "&\$outer;\n\n" |
379 | } |
380 | } |
381 | |
382 | # Now, we can actually prep to run the tests. |
383 | for $inner_sub_test (@inners) { |
384 | $expected = $expected{$inner_sub_test} or |
385 | die "expected $inner_sub_test missing"; |
386 | |
387 | # Named closures won't access the expected vars |
388 | if ( $nc_attempt and |
389 | substr($inner_sub_test, 0, 4) eq "sub_" ) { |
390 | $expected = 1; |
391 | } |
392 | |
393 | # If you make a sub within a foreach loop, |
394 | # what happens if it tries to access the |
395 | # foreach index variable? If it's a named |
396 | # sub, it gets the var from "outside" the loop, |
397 | # but if it's anon, it gets the value to which |
398 | # the index variable is aliased. |
399 | # |
400 | # Of course, if the value was set only |
401 | # within another sub which was never called, |
402 | # the value has not been set yet. |
403 | # |
404 | if ($inner_sub_test eq 'foreach') { |
405 | if ($inner_type eq 'named') { |
406 | if ($call_outer || ($where_declared eq 'filescope')) { |
407 | $expected = 12001 |
408 | } else { |
409 | $expected = 1 |
410 | } |
411 | } |
412 | } |
413 | |
414 | # Here's the test: |
415 | if ($inner_type eq 'anon') { |
416 | $code .= "test { &\$anon_$test == $expected };\n" |
417 | } else { |
418 | $code .= "test { &named_$test == $expected };\n" |
419 | } |
420 | $test++; |
421 | } |
422 | |
68dc0745 |
423 | if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') { |
f86702cc |
424 | # Fork off a new perl to run the tests. |
425 | # (This is so we can catch spurious warnings.) |
426 | $| = 1; print ""; $| = 0; # flush output before forking |
427 | pipe READ, WRITE or die "Can't make pipe: $!"; |
428 | pipe READ2, WRITE2 or die "Can't make second pipe: $!"; |
429 | die "Can't fork: $!" unless defined($pid = open PERL, "|-"); |
430 | unless ($pid) { |
431 | # Child process here. We're going to send errors back |
432 | # through the extra pipe. |
433 | close READ; |
434 | close READ2; |
435 | open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; |
436 | open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; |
437 | exec './perl', '-w', '-' |
0a753a76 |
438 | or die "Can't exec ./perl: $!"; |
f86702cc |
439 | } else { |
440 | # Parent process here. |
441 | close WRITE; |
442 | close WRITE2; |
443 | print PERL $code; |
444 | close PERL; |
445 | { local $/; |
446 | $output = join '', <READ>; |
447 | $errors = join '', <READ2>; } |
448 | close READ; |
449 | close READ2; |
450 | } |
451 | } else { |
452 | # No fork(). Do it the hard way. |
453 | my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; |
f86702cc |
454 | my $errfile = "terr$$"; $errfile++ while -e $errfile; |
aa689395 |
455 | my @tmpfiles = ($cmdfile, $errfile); |
f86702cc |
456 | open CMD, ">$cmdfile"; print CMD $code; close CMD; |
68dc0745 |
457 | my $cmd = (($^O eq 'VMS') ? "MCR $^X" |
458 | : ($^O eq 'MSWin32') ? '.\perl' |
459 | : './perl'); |
aa689395 |
460 | $cmd .= " -w $cmdfile 2>$errfile"; |
68dc0745 |
461 | if ($^O eq 'VMS' or $^O eq 'MSWin32') { |
aa689395 |
462 | # Use pipe instead of system so we don't inherit STD* from |
463 | # this process, and then foul our pipe back to parent by |
464 | # redirecting output in the child. |
465 | open PERL,"$cmd |" or die "Can't open pipe: $!\n"; |
466 | { local $/; $output = join '', <PERL> } |
467 | close PERL; |
468 | } else { |
469 | my $outfile = "tout$$"; $outfile++ while -e $outfile; |
470 | push @tmpfiles, $outfile; |
471 | system "$cmd >$outfile"; |
472 | { local $/; open IN, $outfile; $output = <IN>; close IN } |
473 | } |
f86702cc |
474 | if ($?) { |
475 | printf "not ok: exited with error code %04X\n", $?; |
aa689395 |
476 | $debugging or do { 1 while unlink @tmpfiles }; |
f86702cc |
477 | exit; |
478 | } |
aa689395 |
479 | { local $/; open IN, $errfile; $errors = <IN>; close IN } |
480 | 1 while unlink @tmpfiles; |
0a753a76 |
481 | } |
f86702cc |
482 | print $output; |
483 | print STDERR $errors; |
0a753a76 |
484 | if ($debugging && ($errors || $? || ($output =~ /not ok/))) { |
485 | my $lnum = 0; |
486 | for $line (split '\n', $code) { |
487 | printf "%3d: %s\n", ++$lnum, $line; |
488 | } |
489 | } |
f86702cc |
490 | printf "not ok: exited with error code %04X\n", $? if $?; |
491 | print "-" x 30, "\n" if $debugging; |
0a753a76 |
492 | |
493 | } # End of foreach $within |
494 | } # End of foreach $where_declared |
495 | } # End of foreach $inner_type |
496 | |
497 | } |
3c1f3fdf |
498 | |