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 | # | |
a16a9fa3 | 7 | # Run with -debug for debugging output. |
0a753a76 | 8 | |
f86702cc | 9 | BEGIN { |
10 | chdir 't' if -d 't'; | |
20822f61 | 11 | @INC = '../lib'; |
60d91a71 | 12 | require './test.pl'; |
f86702cc | 13 | } |
14 | ||
15 | use Config; | |
0a753a76 | 16 | |
17 | my $i = 1; | |
18 | sub foo { $i = shift if @_; $i } | |
19 | ||
20 | # no closure | |
13d4f794 | 21 | is(foo, 1); |
0a753a76 | 22 | foo(2); |
13d4f794 | 23 | is(foo, 2); |
0a753a76 | 24 | |
25 | # closure: lexical outside sub | |
26 | my $foo = sub {$i = shift if @_; $i }; | |
27 | my $bar = sub {$i = shift if @_; $i }; | |
13d4f794 | 28 | is(&$foo(), 2); |
0a753a76 | 29 | &$foo(3); |
13d4f794 | 30 | is(&$foo(), 3); |
0a753a76 | 31 | # did the lexical change? |
13d4f794 NC |
32 | is(foo, 3, 'lexical changed'); |
33 | is($i, 3, 'lexical changed'); | |
0a753a76 | 34 | # did the second closure notice? |
13d4f794 | 35 | is(&$bar(), 3, 'second closure noticed'); |
0a753a76 | 36 | |
37 | # closure: lexical inside sub | |
38 | sub bar { | |
39 | my $i = shift; | |
40 | sub { $i = shift if @_; $i } | |
41 | } | |
42 | ||
43 | $foo = bar(4); | |
44 | $bar = bar(5); | |
13d4f794 | 45 | is(&$foo(), 4); |
0a753a76 | 46 | &$foo(6); |
13d4f794 NC |
47 | is(&$foo(), 6); |
48 | is(&$bar(), 5); | |
0a753a76 | 49 | |
50 | # nested closures | |
51 | sub bizz { | |
52 | my $i = 7; | |
53 | if (@_) { | |
54 | my $i = shift; | |
55 | sub {$i = shift if @_; $i }; | |
56 | } else { | |
57 | my $i = $i; | |
58 | sub {$i = shift if @_; $i }; | |
59 | } | |
60 | } | |
61 | $foo = bizz(); | |
62 | $bar = bizz(); | |
13d4f794 | 63 | is(&$foo(), 7); |
0a753a76 | 64 | &$foo(8); |
13d4f794 NC |
65 | is(&$foo(), 8); |
66 | is(&$bar(), 7); | |
0a753a76 | 67 | |
68 | $foo = bizz(9); | |
69 | $bar = bizz(10); | |
13d4f794 | 70 | is(&$foo(11)-1, &$bar()); |
0a753a76 | 71 | |
72 | my @foo; | |
73 | for (qw(0 1 2 3 4)) { | |
74 | my $i = $_; | |
75 | $foo[$_] = sub {$i = shift if @_; $i }; | |
76 | } | |
77 | ||
13d4f794 NC |
78 | is(&{$foo[0]}(), 0); |
79 | is(&{$foo[1]}(), 1); | |
80 | is(&{$foo[2]}(), 2); | |
81 | is(&{$foo[3]}(), 3); | |
82 | is(&{$foo[4]}(), 4); | |
0a753a76 | 83 | |
84 | for (0 .. 4) { | |
85 | &{$foo[$_]}(4-$_); | |
86 | } | |
87 | ||
13d4f794 NC |
88 | is(&{$foo[0]}(), 4); |
89 | is(&{$foo[1]}(), 3); | |
90 | is(&{$foo[2]}(), 2); | |
91 | is(&{$foo[3]}(), 1); | |
92 | is(&{$foo[4]}(), 0); | |
0a753a76 | 93 | |
94 | sub barf { | |
95 | my @foo; | |
96 | for (qw(0 1 2 3 4)) { | |
97 | my $i = $_; | |
98 | $foo[$_] = sub {$i = shift if @_; $i }; | |
99 | } | |
100 | @foo; | |
101 | } | |
102 | ||
103 | @foo = barf(); | |
13d4f794 NC |
104 | is(&{$foo[0]}(), 0); |
105 | is(&{$foo[1]}(), 1); | |
106 | is(&{$foo[2]}(), 2); | |
107 | is(&{$foo[3]}(), 3); | |
108 | is(&{$foo[4]}(), 4); | |
0a753a76 | 109 | |
110 | for (0 .. 4) { | |
111 | &{$foo[$_]}(4-$_); | |
112 | } | |
113 | ||
13d4f794 NC |
114 | is(&{$foo[0]}(), 4); |
115 | is(&{$foo[1]}(), 3); | |
116 | is(&{$foo[2]}(), 2); | |
117 | is(&{$foo[3]}(), 1); | |
118 | is(&{$foo[4]}(), 0); | |
0a753a76 | 119 | |
3c1f3fdf GS |
120 | # test if closures get created in optimized for loops |
121 | ||
122 | my %foo; | |
123 | for my $n ('A'..'E') { | |
124 | $foo{$n} = sub { $n eq $_[0] }; | |
125 | } | |
126 | ||
13d4f794 NC |
127 | ok(&{$foo{A}}('A')); |
128 | ok(&{$foo{B}}('B')); | |
129 | ok(&{$foo{C}}('C')); | |
130 | ok(&{$foo{D}}('D')); | |
131 | ok(&{$foo{E}}('E')); | |
3c1f3fdf GS |
132 | |
133 | for my $n (0..4) { | |
134 | $foo[$n] = sub { $n == $_[0] }; | |
135 | } | |
136 | ||
13d4f794 NC |
137 | ok(&{$foo[0]}(0)); |
138 | ok(&{$foo[1]}(1)); | |
139 | ok(&{$foo[2]}(2)); | |
140 | ok(&{$foo[3]}(3)); | |
141 | ok(&{$foo[4]}(4)); | |
3c1f3fdf | 142 | |
94f23f41 GS |
143 | for my $n (0..4) { |
144 | $foo[$n] = sub { | |
145 | # no intervening reference to $n here | |
146 | sub { $n == $_[0] } | |
147 | }; | |
148 | } | |
149 | ||
13d4f794 NC |
150 | ok($foo[0]->()->(0)); |
151 | ok($foo[1]->()->(1)); | |
152 | ok($foo[2]->()->(2)); | |
153 | ok($foo[3]->()->(3)); | |
154 | ok($foo[4]->()->(4)); | |
94f23f41 | 155 | |
354992b1 GS |
156 | { |
157 | my $w; | |
158 | $w = sub { | |
159 | my ($i) = @_; | |
13d4f794 | 160 | is($i, 10); |
354992b1 GS |
161 | sub { $w }; |
162 | }; | |
163 | $w->(10); | |
164 | } | |
94f23f41 | 165 | |
0a753a76 | 166 | # Additional tests by Tom Phoenix <rootbeer@teleport.com>. |
167 | ||
168 | { | |
0a753a76 | 169 | use strict; |
170 | ||
171 | use vars qw!$test!; | |
172 | my($debugging, %expected, $inner_type, $where_declared, $within); | |
173 | my($nc_attempt, $call_outer, $call_inner, $undef_outer); | |
174 | my($code, $inner_sub_test, $expected, $line, $errors, $output); | |
175 | my(@inners, $sub_test, $pid); | |
176 | $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; | |
177 | ||
178 | # The expected values for these tests | |
179 | %expected = ( | |
180 | 'global_scalar' => 1001, | |
181 | 'global_array' => 2101, | |
182 | 'global_hash' => 3004, | |
183 | 'fs_scalar' => 4001, | |
184 | 'fs_array' => 5101, | |
185 | 'fs_hash' => 6004, | |
186 | 'sub_scalar' => 7001, | |
187 | 'sub_array' => 8101, | |
188 | 'sub_hash' => 9004, | |
189 | 'foreach' => 10011, | |
190 | ); | |
191 | ||
192 | # Our innermost sub is either named or anonymous | |
193 | for $inner_type (qw!named anon!) { | |
194 | # And it may be declared at filescope, within a named | |
195 | # sub, or within an anon sub | |
196 | for $where_declared (qw!filescope in_named in_anon!) { | |
197 | # And that, in turn, may be within a foreach loop, | |
198 | # a naked block, or another named sub | |
199 | for $within (qw!foreach naked other_sub!) { | |
200 | ||
3f0b0e8e | 201 | my $test = curr_test(); |
0a753a76 | 202 | # Here are a number of variables which show what's |
203 | # going on, in a way. | |
204 | $nc_attempt = 0+ # Named closure attempted | |
205 | ( ($inner_type eq 'named') || | |
206 | ($within eq 'other_sub') ) ; | |
207 | $call_inner = 0+ # Need to call &inner | |
208 | ( ($inner_type eq 'anon') && | |
209 | ($within eq 'other_sub') ) ; | |
210 | $call_outer = 0+ # Need to call &outer or &$outer | |
211 | ( ($inner_type eq 'anon') && | |
212 | ($within ne 'other_sub') ) ; | |
213 | $undef_outer = 0+ # $outer is created but unused | |
214 | ( ($where_declared eq 'in_anon') && | |
215 | (not $call_outer) ) ; | |
216 | ||
217 | $code = "# This is a test script built by t/op/closure.t\n\n"; | |
218 | ||
a16a9fa3 MS |
219 | print <<"DEBUG_INFO" if $debugging; |
220 | # inner_type: $inner_type | |
0a753a76 | 221 | # where_declared: $where_declared |
a16a9fa3 MS |
222 | # within: $within |
223 | # nc_attempt: $nc_attempt | |
224 | # call_inner: $call_inner | |
225 | # call_outer: $call_outer | |
226 | # undef_outer: $undef_outer | |
0a753a76 | 227 | DEBUG_INFO |
228 | ||
229 | $code .= <<"END_MARK_ONE"; | |
230 | ||
231 | BEGIN { \$SIG{__WARN__} = sub { | |
232 | my \$msg = \$_[0]; | |
233 | END_MARK_ONE | |
234 | ||
235 | $code .= <<"END_MARK_TWO" if $nc_attempt; | |
236 | return if index(\$msg, 'will not stay shared') != -1; | |
b5c19bd7 | 237 | return if index(\$msg, 'is not available') != -1; |
0a753a76 | 238 | END_MARK_TWO |
239 | ||
240 | $code .= <<"END_MARK_THREE"; # Backwhack a lot! | |
241 | print "not ok: got unexpected warning \$msg\\n"; | |
242 | } } | |
243 | ||
3f0b0e8e NC |
244 | require './test.pl'; |
245 | curr_test($test); | |
0a753a76 | 246 | |
247 | # some of the variables which the closure will access | |
248 | \$global_scalar = 1000; | |
249 | \@global_array = (2000, 2100, 2200, 2300); | |
250 | %global_hash = 3000..3009; | |
251 | ||
252 | my \$fs_scalar = 4000; | |
253 | my \@fs_array = (5000, 5100, 5200, 5300); | |
254 | my %fs_hash = 6000..6009; | |
255 | ||
256 | END_MARK_THREE | |
257 | ||
258 | if ($where_declared eq 'filescope') { | |
259 | # Nothing here | |
260 | } elsif ($where_declared eq 'in_named') { | |
261 | $code .= <<'END'; | |
262 | sub outer { | |
263 | my $sub_scalar = 7000; | |
264 | my @sub_array = (8000, 8100, 8200, 8300); | |
265 | my %sub_hash = 9000..9009; | |
266 | END | |
267 | # } | |
268 | } elsif ($where_declared eq 'in_anon') { | |
269 | $code .= <<'END'; | |
270 | $outer = sub { | |
271 | my $sub_scalar = 7000; | |
272 | my @sub_array = (8000, 8100, 8200, 8300); | |
273 | my %sub_hash = 9000..9009; | |
274 | END | |
275 | # } | |
276 | } else { | |
277 | die "What was $where_declared?" | |
278 | } | |
279 | ||
280 | if ($within eq 'foreach') { | |
281 | $code .= " | |
282 | my \$foreach = 12000; | |
283 | my \@list = (10000, 10010); | |
284 | foreach \$foreach (\@list) { | |
285 | " # } | |
286 | } elsif ($within eq 'naked') { | |
287 | $code .= " { # naked block\n" # } | |
288 | } elsif ($within eq 'other_sub') { | |
289 | $code .= " sub inner_sub {\n" # } | |
290 | } else { | |
291 | die "What was $within?" | |
292 | } | |
293 | ||
294 | $sub_test = $test; | |
295 | @inners = ( qw!global_scalar global_array global_hash! , | |
296 | qw!fs_scalar fs_array fs_hash! ); | |
297 | push @inners, 'foreach' if $within eq 'foreach'; | |
298 | if ($where_declared ne 'filescope') { | |
299 | push @inners, qw!sub_scalar sub_array sub_hash!; | |
300 | } | |
301 | for $inner_sub_test (@inners) { | |
302 | ||
303 | if ($inner_type eq 'named') { | |
304 | $code .= " sub named_$sub_test " | |
305 | } elsif ($inner_type eq 'anon') { | |
306 | $code .= " \$anon_$sub_test = sub " | |
307 | } else { | |
308 | die "What was $inner_type?" | |
309 | } | |
310 | ||
311 | # Now to write the body of the test sub | |
312 | if ($inner_sub_test eq 'global_scalar') { | |
313 | $code .= '{ ++$global_scalar }' | |
314 | } elsif ($inner_sub_test eq 'fs_scalar') { | |
315 | $code .= '{ ++$fs_scalar }' | |
316 | } elsif ($inner_sub_test eq 'sub_scalar') { | |
317 | $code .= '{ ++$sub_scalar }' | |
318 | } elsif ($inner_sub_test eq 'global_array') { | |
319 | $code .= '{ ++$global_array[1] }' | |
320 | } elsif ($inner_sub_test eq 'fs_array') { | |
321 | $code .= '{ ++$fs_array[1] }' | |
322 | } elsif ($inner_sub_test eq 'sub_array') { | |
323 | $code .= '{ ++$sub_array[1] }' | |
324 | } elsif ($inner_sub_test eq 'global_hash') { | |
325 | $code .= '{ ++$global_hash{3002} }' | |
326 | } elsif ($inner_sub_test eq 'fs_hash') { | |
327 | $code .= '{ ++$fs_hash{6002} }' | |
328 | } elsif ($inner_sub_test eq 'sub_hash') { | |
329 | $code .= '{ ++$sub_hash{9002} }' | |
330 | } elsif ($inner_sub_test eq 'foreach') { | |
331 | $code .= '{ ++$foreach }' | |
332 | } else { | |
333 | die "What was $inner_sub_test?" | |
334 | } | |
335 | ||
336 | # Close up | |
337 | if ($inner_type eq 'anon') { | |
338 | $code .= ';' | |
339 | } | |
340 | $code .= "\n"; | |
341 | $sub_test++; # sub name sequence number | |
342 | ||
343 | } # End of foreach $inner_sub_test | |
344 | ||
345 | # Close up $within block # { | |
346 | $code .= " }\n\n"; | |
347 | ||
348 | # Close up $where_declared block | |
349 | if ($where_declared eq 'in_named') { # { | |
350 | $code .= "}\n\n"; | |
351 | } elsif ($where_declared eq 'in_anon') { # { | |
352 | $code .= "};\n\n"; | |
353 | } | |
354 | ||
355 | # We may need to do something with the sub we just made... | |
356 | $code .= "undef \$outer;\n" if $undef_outer; | |
357 | $code .= "&inner_sub;\n" if $call_inner; | |
358 | if ($call_outer) { | |
359 | if ($where_declared eq 'in_named') { | |
360 | $code .= "&outer;\n\n"; | |
361 | } elsif ($where_declared eq 'in_anon') { | |
362 | $code .= "&\$outer;\n\n" | |
363 | } | |
364 | } | |
365 | ||
366 | # Now, we can actually prep to run the tests. | |
367 | for $inner_sub_test (@inners) { | |
368 | $expected = $expected{$inner_sub_test} or | |
369 | die "expected $inner_sub_test missing"; | |
370 | ||
371 | # Named closures won't access the expected vars | |
372 | if ( $nc_attempt and | |
373 | substr($inner_sub_test, 0, 4) eq "sub_" ) { | |
374 | $expected = 1; | |
375 | } | |
376 | ||
377 | # If you make a sub within a foreach loop, | |
378 | # what happens if it tries to access the | |
379 | # foreach index variable? If it's a named | |
380 | # sub, it gets the var from "outside" the loop, | |
381 | # but if it's anon, it gets the value to which | |
382 | # the index variable is aliased. | |
383 | # | |
384 | # Of course, if the value was set only | |
385 | # within another sub which was never called, | |
386 | # the value has not been set yet. | |
387 | # | |
388 | if ($inner_sub_test eq 'foreach') { | |
389 | if ($inner_type eq 'named') { | |
390 | if ($call_outer || ($where_declared eq 'filescope')) { | |
391 | $expected = 12001 | |
392 | } else { | |
393 | $expected = 1 | |
394 | } | |
395 | } | |
396 | } | |
397 | ||
398 | # Here's the test: | |
3f0b0e8e | 399 | my $desc = "$inner_type $where_declared $within $inner_sub_test"; |
0a753a76 | 400 | if ($inner_type eq 'anon') { |
3f0b0e8e | 401 | $code .= "is(&\$anon_$test, $expected, '$desc');\n" |
0a753a76 | 402 | } else { |
3f0b0e8e | 403 | $code .= "is(&named_$test, $expected, '$desc');\n" |
0a753a76 | 404 | } |
405 | $test++; | |
406 | } | |
407 | ||
2986a63f | 408 | if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') { |
f86702cc | 409 | # Fork off a new perl to run the tests. |
410 | # (This is so we can catch spurious warnings.) | |
411 | $| = 1; print ""; $| = 0; # flush output before forking | |
412 | pipe READ, WRITE or die "Can't make pipe: $!"; | |
413 | pipe READ2, WRITE2 or die "Can't make second pipe: $!"; | |
414 | die "Can't fork: $!" unless defined($pid = open PERL, "|-"); | |
415 | unless ($pid) { | |
416 | # Child process here. We're going to send errors back | |
417 | # through the extra pipe. | |
418 | close READ; | |
419 | close READ2; | |
420 | open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; | |
421 | open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; | |
c8d62b71 RGS |
422 | exec which_perl(), '-w', '-' |
423 | or die "Can't exec perl: $!"; | |
f86702cc | 424 | } else { |
425 | # Parent process here. | |
426 | close WRITE; | |
427 | close WRITE2; | |
428 | print PERL $code; | |
429 | close PERL; | |
430 | { local $/; | |
431 | $output = join '', <READ>; | |
432 | $errors = join '', <READ2>; } | |
433 | close READ; | |
434 | close READ2; | |
435 | } | |
436 | } else { | |
437 | # No fork(). Do it the hard way. | |
1c25d394 NC |
438 | my $cmdfile = tempfile(); |
439 | my $errfile = tempfile(); | |
f86702cc | 440 | open CMD, ">$cmdfile"; print CMD $code; close CMD; |
c8d62b71 | 441 | my $cmd = which_perl(); |
aa689395 | 442 | $cmd .= " -w $cmdfile 2>$errfile"; |
2986a63f | 443 | if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') { |
aa689395 | 444 | # Use pipe instead of system so we don't inherit STD* from |
445 | # this process, and then foul our pipe back to parent by | |
446 | # redirecting output in the child. | |
447 | open PERL,"$cmd |" or die "Can't open pipe: $!\n"; | |
448 | { local $/; $output = join '', <PERL> } | |
449 | close PERL; | |
450 | } else { | |
1c25d394 | 451 | my $outfile = tempfile(); |
aa689395 | 452 | system "$cmd >$outfile"; |
453 | { local $/; open IN, $outfile; $output = <IN>; close IN } | |
454 | } | |
f86702cc | 455 | if ($?) { |
456 | printf "not ok: exited with error code %04X\n", $?; | |
f86702cc | 457 | exit; |
458 | } | |
aa689395 | 459 | { local $/; open IN, $errfile; $errors = <IN>; close IN } |
0a753a76 | 460 | } |
f86702cc | 461 | print $output; |
3f0b0e8e | 462 | curr_test($test); |
f86702cc | 463 | print STDERR $errors; |
3f0b0e8e NC |
464 | # This has the side effect of alerting *our* test.pl to the state of |
465 | # what has just been passed to STDOUT, so that if anything there has | |
466 | # failed, our test.pl will print a diagnostic and exit uncleanly. | |
467 | unlike($output, qr/not ok/, 'All good'); | |
468 | is($errors, '', 'STDERR is silent'); | |
0a753a76 | 469 | if ($debugging && ($errors || $? || ($output =~ /not ok/))) { |
470 | my $lnum = 0; | |
471 | for $line (split '\n', $code) { | |
472 | printf "%3d: %s\n", ++$lnum, $line; | |
473 | } | |
474 | } | |
3f0b0e8e | 475 | is($?, 0, 'exited cleanly') or diag(sprintf "Error code $? = 0x%X", $?); |
a16a9fa3 | 476 | print '#', "-" x 30, "\n" if $debugging; |
0a753a76 | 477 | |
478 | } # End of foreach $within | |
479 | } # End of foreach $where_declared | |
480 | } # End of foreach $inner_type | |
481 | ||
482 | } | |
3c1f3fdf | 483 | |
7dafbf52 | 484 | # The following dumps core with perl <= 5.8.0 (bugid 9535) ... |
2f647fb2 RGS |
485 | BEGIN { $vanishing_pad = sub { eval $_[0] } } |
486 | $some_var = 123; | |
ff31df89 | 487 | is($vanishing_pad->('$some_var'), 123, 'RT #9535'); |
f3548bdc | 488 | |
7dafbf52 DM |
489 | # ... and here's another coredump variant - this time we explicitly |
490 | # delete the sub rather than using a BEGIN ... | |
491 | ||
492 | sub deleteme { $a = sub { eval '$newvar' } } | |
493 | deleteme(); | |
494 | *deleteme = sub {}; # delete the sub | |
495 | $newvar = 123; # realloc the SV of the freed CV | |
ff31df89 | 496 | is($a->(), 123, 'RT #9535'); |
7dafbf52 DM |
497 | |
498 | # ... and a further coredump variant - the fixup of the anon sub's | |
499 | # CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to | |
500 | # survive the outer eval also being freed. | |
501 | ||
502 | $x = 123; | |
503 | $a = eval q( | |
504 | eval q[ | |
505 | sub { eval '$x' } | |
506 | ] | |
507 | ); | |
508 | @a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs | |
ff31df89 | 509 | is($a->(), 123, 'RT #9535'); |
7dafbf52 | 510 | |
f3548bdc DM |
511 | # this coredumped on <= 5.8.0 because evaling the closure caused |
512 | # an SvFAKE to be added to the outer anon's pad, which was then grown. | |
513 | my $outer; | |
514 | sub { | |
515 | my $x; | |
516 | $x = eval 'sub { $outer }'; | |
517 | $x->(); | |
518 | $a = [ 99 ]; | |
519 | $x->(); | |
520 | }->(); | |
ff31df89 | 521 | pass(); |
f3548bdc | 522 | |
e9f19e3c HS |
523 | # [perl #17605] found that an empty block called in scalar context |
524 | # can lead to stack corruption | |
525 | { | |
526 | my $x = "foooobar"; | |
527 | $x =~ s/o//eg; | |
ff31df89 | 528 | is($x, 'fbar', 'RT #17605'); |
e9f19e3c | 529 | } |
ee6cee0c DM |
530 | |
531 | # DAPM 24-Nov-02 | |
532 | # SvFAKE lexicals should be visible thoughout a function. | |
533 | # On <= 5.8.0, the third test failed, eg bugid #18286 | |
534 | ||
535 | { | |
536 | my $x = 1; | |
537 | sub fake { | |
ff31df89 NC |
538 | is(sub {eval'$x'}->(), 1, 'RT #18286'); |
539 | { $x; is(sub {eval'$x'}->(), 1, 'RT #18286'); } | |
540 | is(sub {eval'$x'}->(), 1, 'RT #18286'); | |
ee6cee0c DM |
541 | } |
542 | } | |
543 | fake(); | |
544 | ||
7dafbf52 DM |
545 | { |
546 | $x = 1; | |
547 | my $x = 2; | |
548 | sub tmp { sub { eval '$x' } } | |
549 | my $a = tmp(); | |
550 | undef &tmp; | |
ff31df89 NC |
551 | is($a->(), 2, |
552 | "undefining a sub shouldn't alter visibility of outer lexicals"); | |
7dafbf52 DM |
553 | } |
554 | ||
555 | # handy class: $x = Watch->new(\$foo,'bar') | |
556 | # causes 'bar' to be appended to $foo when $x is destroyed | |
557 | sub Watch::new { bless [ $_[1], $_[2] ], $_[0] } | |
558 | sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] } | |
559 | ||
7dafbf52 DM |
560 | # bugid 1028: |
561 | # nested anon subs (and associated lexicals) not freed early enough | |
562 | ||
563 | sub linger { | |
564 | my $x = Watch->new($_[0], '2'); | |
565 | sub { | |
566 | $x; | |
567 | my $y; | |
568 | sub { $y; }; | |
569 | }; | |
570 | } | |
571 | { | |
572 | my $watch = '1'; | |
573 | linger(\$watch); | |
ff31df89 | 574 | is($watch, '12', 'RT #1028'); |
7dafbf52 | 575 | } |
b5c19bd7 DM |
576 | |
577 | # bugid 10085 | |
578 | # obj not freed early enough | |
579 | ||
580 | sub linger2 { | |
581 | my $obj = Watch->new($_[0], '2'); | |
582 | sub { sub { $obj } }; | |
583 | } | |
584 | { | |
585 | my $watch = '1'; | |
586 | linger2(\$watch); | |
ff31df89 | 587 | is($watch, 12, 'RT #10085'); |
b5c19bd7 DM |
588 | } |
589 | ||
590 | # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs | |
591 | ||
592 | { | |
593 | my $x = 1; | |
594 | sub f16302 { | |
595 | sub { | |
ff31df89 | 596 | is($x, 1, 'RT #16302'); |
b5c19bd7 DM |
597 | }->(); |
598 | } | |
599 | } | |
600 | f16302(); | |
601 | ||
602 | # The presence of an eval should turn cloneless anon subs into clonable | |
603 | # subs - otherwise the CvOUTSIDE of that sub may be wrong | |
604 | ||
605 | { | |
606 | my %a; | |
607 | for my $x (7,11) { | |
608 | $a{$x} = sub { $x=$x; sub { eval '$x' } }; | |
609 | } | |
ff31df89 | 610 | is($a{7}->()->() + $a{11}->()->(), 18); |
b5c19bd7 DM |
611 | } |
612 | ||
ed1af28e JH |
613 | { |
614 | # bugid #23265 - this used to coredump during destruction of PL_maincv | |
615 | # and its children | |
616 | ||
ff31df89 | 617 | fresh_perl_is(<< '__EOF__', "yxx\n", {stderr => 1}, 'RT #23265'); |
ed1af28e JH |
618 | |
619 | sub {$_[0]->(@_)} -> ( | |
620 | sub { | |
621 | $_[1] | |
622 | ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->() | |
623 | : "y" | |
624 | }, | |
625 | 2 | |
626 | ) | |
627 | , "\n" | |
628 | ; | |
629 | __EOF__ | |
ed1af28e JH |
630 | } |
631 | ||
b36bdeca DM |
632 | { |
633 | # bugid #24914 = used to coredump restoring PL_comppad in the | |
634 | # savestack, due to the early freeing of the anon closure | |
635 | ||
ff31df89 NC |
636 | fresh_perl_is('sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)', |
637 | "ok\n", {stderr => 1}, 'RT #24914'); | |
b36bdeca DM |
638 | } |
639 | ||
ff31df89 NC |
640 | |
641 | # After newsub is redefined outside the BEGIN, its CvOUTSIDE should point | |
154b970c DM |
642 | # to main rather than BEGIN, and BEGIN should be freed. |
643 | ||
644 | { | |
645 | my $flag = 0; | |
646 | sub X::DESTROY { $flag = 1 } | |
647 | { | |
648 | my $x; | |
649 | BEGIN {$x = \&newsub } | |
650 | sub newsub {}; | |
651 | $x = bless {}, 'X'; | |
652 | } | |
ff31df89 | 653 | is($flag, 1); |
154b970c DM |
654 | } |
655 | ||
33894c1a | 656 | sub f { |
cae5dbbe FC |
657 | my $x; |
658 | format ff = | |
659 | @ | |
660 | $r = \$x | |
661 | . | |
33894c1a DM |
662 | } |
663 | ||
664 | { | |
cae5dbbe FC |
665 | fileno ff; |
666 | write ff; | |
667 | my $r1 = $r; | |
668 | write ff; | |
669 | my $r2 = $r; | |
ff31df89 NC |
670 | isnt($r1, $r2, |
671 | "don't copy a stale lexical; crate a fresh undef one instead"); | |
33894c1a | 672 | } |
154b970c | 673 | |
dbe92b04 | 674 | # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant |
b36bdeca | 675 | |
dbe92b04 FC |
676 | BEGIN { |
677 | my $x = 7; | |
678 | *baz = sub() { if($x){ () = "tralala"; blonk() }; 0 } | |
679 | } | |
680 | { | |
681 | my $blonk_was_called; | |
682 | *blonk = sub { ++$blonk_was_called }; | |
683 | my $ret = baz(); | |
ff31df89 NC |
684 | is($ret, 0, 'RT #63540'); |
685 | is($blonk_was_called, 1, 'RT #63540'); | |
dbe92b04 | 686 | } |
b36bdeca | 687 | |
fca72212 DM |
688 | # test PL_cv_has_eval. Any anon sub that could conceivably contain an |
689 | # eval, should be marked as cloneable | |
690 | ||
691 | { | |
692 | ||
693 | my @s; | |
694 | push @s, sub { eval '1' } for 1,2; | |
695 | isnt($s[0], $s[1], "cloneable with eval"); | |
696 | @s = (); | |
697 | push @s, sub { use re 'eval'; my $x; s/$x/1/; } for 1,2; | |
698 | isnt($s[0], $s[1], "cloneable with use re eval"); | |
699 | @s = (); | |
700 | push @s, sub { s/1/1/ee; } for 1,2; | |
701 | isnt($s[0], $s[1], "cloneable with //ee"); | |
702 | } | |
703 | ||
a0d2bbd5 FC |
704 | # [perl #89544] |
705 | { | |
706 | sub trace::DESTROY { | |
707 | push @trace::trace, "destroyed"; | |
708 | } | |
709 | ||
710 | my $outer2 = sub { | |
711 | my $a = bless \my $dummy, trace::; | |
712 | ||
713 | my $outer = sub { | |
714 | my $b; | |
715 | my $inner = sub { | |
716 | undef $b; | |
717 | }; | |
718 | ||
719 | $a; | |
fca72212 | 720 | |
a0d2bbd5 FC |
721 | $inner |
722 | }; | |
723 | ||
724 | $outer->() | |
725 | }; | |
726 | ||
727 | my $inner = $outer2->(); | |
728 | is "@trace::trace", "destroyed", | |
729 | 'closures only close over named variables, not entire subs'; | |
730 | } | |
fca72212 | 731 | |
0f9db002 FC |
732 | # [perl #113812] Closure prototypes with no CvOUTSIDE (crash caused by the |
733 | # fix for #89544) | |
734 | do "./op/closure_test.pl" or die $@||$!; | |
735 | is $closure_test::s2->()(), '10 cubes', | |
736 | 'cloning closure proto with no CvOUTSIDE'; | |
737 | ||
5dff782d FC |
738 | # Also brought up in #113812: Even when being cloned, a closure prototype |
739 | # might have its CvOUTSIDE pointing to the wrong thing. | |
740 | { | |
741 | package main::113812; | |
742 | $s1 = sub { | |
743 | my $x = 3; | |
744 | $s2 = sub { | |
745 | $x; | |
746 | $s3 = sub { $x }; | |
747 | }; | |
748 | }; | |
749 | $s1->(); | |
750 | undef &$s1; # frees $s2’s prototype, causing the $s3 proto to have its | |
751 | # CvOUTSIDE point to $s1 | |
752 | ::is $s2->()(), 3, 'cloning closure proto whose CvOUTSIDE has changed'; | |
753 | } | |
754 | ||
cae5dbbe FC |
755 | # This should never emit two different values: |
756 | # print $x, "\n"; | |
757 | # print sub { $x }->(), "\n"; | |
758 | # This test case started to do just that in commit 33894c1aa3e | |
759 | # (5.10.1/5.12.0): | |
760 | sub mosquito { | |
761 | my $x if @_; | |
762 | return if @_; | |
763 | ||
764 | $x = 17; | |
765 | is sub { $x }->(), $x, 'closing over stale var in 2nd sub call'; | |
766 | } | |
767 | mosquito(1); | |
768 | mosquito; | |
769 | # And this case in commit adf8f095c588 (5.14): | |
770 | sub anything { | |
771 | my $x; | |
772 | sub gnat { | |
773 | $x = 3; | |
774 | is sub { $x }->(), $x, | |
775 | 'closing over stale var before 1st sub call'; | |
776 | } | |
777 | } | |
778 | gnat(); | |
779 | ||
7ef30830 FC |
780 | # [perl #114018] Similar to the above, but with string eval |
781 | sub staleval { | |
782 | my $x if @_; | |
783 | return if @_; | |
784 | ||
785 | $x = 3; | |
786 | is eval '$x', $x, 'eval closing over stale var in active sub'; | |
787 | return # | |
788 | } | |
789 | staleval 1; | |
790 | staleval; | |
fca72212 | 791 | |
cbacc9aa FC |
792 | # [perl #114888] |
793 | # Test that closure creation localises PL_comppad_name properly. Usually | |
794 | # at compile time a BEGIN block will localise PL_comppad_name for use, so | |
795 | # pp_anoncode can mess with it without any visible effects. | |
796 | # But inside a source filter, it affects the directly enclosing compila- | |
797 | # tion scope. | |
798 | SKIP: { | |
799 | skip_if_miniperl("no XS on miniperl (for source filters)"); | |
800 | fresh_perl_is <<' [perl #114888]', "ok\n", {stderr=>1}, | |
801 | use strict; | |
802 | BEGIN { | |
803 | package Foo; | |
804 | use Filter::Util::Call; | |
805 | sub import { filter_add( sub { | |
806 | my $status = filter_read(); | |
807 | sub { $status }; | |
808 | $status; | |
809 | })} | |
810 | Foo->import | |
811 | } | |
812 | my $x = "ok\n"; # stores $x in the wrong padnamelist | |
813 | print $x; # cannot find it - strict violation | |
814 | [perl #114888] | |
815 | 'closures in source filters do not interfere with pad names'; | |
816 | } | |
817 | ||
ff31df89 | 818 | done_testing(); |