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'; | |
20822f61 | 10 | @INC = '../lib'; |
f86702cc | 11 | } |
12 | ||
13 | use Config; | |
14 | ||
354992b1 | 15 | print "1..171\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 GS |
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 GS |
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 | ||
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 | 185 | # Additional tests by Tom Phoenix <rootbeer@teleport.com>. |
186 | ||
187 | { | |
0a753a76 | 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 | |
245 | DEBUG_INFO | |
246 | ||
247 | $code .= <<"END_MARK_ONE"; | |
248 | ||
249 | BEGIN { \$SIG{__WARN__} = sub { | |
250 | my \$msg = \$_[0]; | |
251 | END_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; | |
256 | END_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 | ||
277 | my \$fs_scalar = 4000; | |
278 | my \@fs_array = (5000, 5100, 5200, 5300); | |
279 | my %fs_hash = 6000..6009; | |
280 | ||
281 | END_MARK_THREE | |
282 | ||
283 | if ($where_declared eq 'filescope') { | |
284 | # Nothing here | |
285 | } elsif ($where_declared eq 'in_named') { | |
286 | $code .= <<'END'; | |
287 | sub outer { | |
288 | my $sub_scalar = 7000; | |
289 | my @sub_array = (8000, 8100, 8200, 8300); | |
290 | my %sub_hash = 9000..9009; | |
291 | END | |
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; | |
299 | END | |
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 | 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 | 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 | 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 | 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 | 485 | if ($?) { |
486 | printf "not ok: exited with error code %04X\n", $?; | |
aa689395 | 487 | $debugging or do { 1 while unlink @tmpfiles }; |
f86702cc | 488 | exit; |
489 | } | |
aa689395 | 490 | { local $/; open IN, $errfile; $errors = <IN>; close IN } |
491 | 1 while unlink @tmpfiles; | |
0a753a76 | 492 | } |
f86702cc | 493 | print $output; |
494 | print STDERR $errors; | |
0a753a76 | 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 | 501 | printf "not ok: exited with error code %04X\n", $? if $?; |
502 | print "-" x 30, "\n" if $debugging; | |
0a753a76 | 503 | |
504 | } # End of foreach $within | |
505 | } # End of foreach $where_declared | |
506 | } # End of foreach $inner_type | |
507 | ||
508 | } | |
3c1f3fdf | 509 |