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