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