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'; |
f86702cc |
12 | } |
13 | |
14 | use Config; |
15 | |
9d1ce744 |
16 | print "1..185\n"; |
0a753a76 |
17 | |
18 | my $test = 1; |
19 | sub test (&) { |
a16a9fa3 |
20 | my $ok = &{$_[0]}; |
21 | print $ok ? "ok $test\n" : "not ok $test\n"; |
22 | printf "# Failed at line %d\n", (caller)[2] unless $ok; |
0a753a76 |
23 | $test++; |
24 | } |
25 | |
26 | my $i = 1; |
27 | sub foo { $i = shift if @_; $i } |
28 | |
29 | # no closure |
30 | test { foo == 1 }; |
31 | foo(2); |
32 | test { foo == 2 }; |
33 | |
34 | # closure: lexical outside sub |
35 | my $foo = sub {$i = shift if @_; $i }; |
36 | my $bar = sub {$i = shift if @_; $i }; |
37 | test {&$foo() == 2 }; |
38 | &$foo(3); |
39 | test {&$foo() == 3 }; |
40 | # did the lexical change? |
41 | test { foo == 3 and $i == 3}; |
42 | # did the second closure notice? |
43 | test {&$bar() == 3 }; |
44 | |
45 | # closure: lexical inside sub |
46 | sub bar { |
47 | my $i = shift; |
48 | sub { $i = shift if @_; $i } |
49 | } |
50 | |
51 | $foo = bar(4); |
52 | $bar = bar(5); |
53 | test {&$foo() == 4 }; |
54 | &$foo(6); |
55 | test {&$foo() == 6 }; |
56 | test {&$bar() == 5 }; |
57 | |
58 | # nested closures |
59 | sub bizz { |
60 | my $i = 7; |
61 | if (@_) { |
62 | my $i = shift; |
63 | sub {$i = shift if @_; $i }; |
64 | } else { |
65 | my $i = $i; |
66 | sub {$i = shift if @_; $i }; |
67 | } |
68 | } |
69 | $foo = bizz(); |
70 | $bar = bizz(); |
71 | test {&$foo() == 7 }; |
72 | &$foo(8); |
73 | test {&$foo() == 8 }; |
74 | test {&$bar() == 7 }; |
75 | |
76 | $foo = bizz(9); |
77 | $bar = bizz(10); |
78 | test {&$foo(11)-1 == &$bar()}; |
79 | |
80 | my @foo; |
81 | for (qw(0 1 2 3 4)) { |
82 | my $i = $_; |
83 | $foo[$_] = sub {$i = shift if @_; $i }; |
84 | } |
85 | |
86 | test { |
87 | &{$foo[0]}() == 0 and |
88 | &{$foo[1]}() == 1 and |
89 | &{$foo[2]}() == 2 and |
90 | &{$foo[3]}() == 3 and |
91 | &{$foo[4]}() == 4 |
92 | }; |
93 | |
94 | for (0 .. 4) { |
95 | &{$foo[$_]}(4-$_); |
96 | } |
97 | |
98 | test { |
99 | &{$foo[0]}() == 4 and |
100 | &{$foo[1]}() == 3 and |
101 | &{$foo[2]}() == 2 and |
102 | &{$foo[3]}() == 1 and |
103 | &{$foo[4]}() == 0 |
104 | }; |
105 | |
106 | sub barf { |
107 | my @foo; |
108 | for (qw(0 1 2 3 4)) { |
109 | my $i = $_; |
110 | $foo[$_] = sub {$i = shift if @_; $i }; |
111 | } |
112 | @foo; |
113 | } |
114 | |
115 | @foo = barf(); |
116 | test { |
117 | &{$foo[0]}() == 0 and |
118 | &{$foo[1]}() == 1 and |
119 | &{$foo[2]}() == 2 and |
120 | &{$foo[3]}() == 3 and |
121 | &{$foo[4]}() == 4 |
122 | }; |
123 | |
124 | for (0 .. 4) { |
125 | &{$foo[$_]}(4-$_); |
126 | } |
127 | |
128 | test { |
129 | &{$foo[0]}() == 4 and |
130 | &{$foo[1]}() == 3 and |
131 | &{$foo[2]}() == 2 and |
132 | &{$foo[3]}() == 1 and |
133 | &{$foo[4]}() == 0 |
134 | }; |
135 | |
3c1f3fdf |
136 | # test if closures get created in optimized for loops |
137 | |
138 | my %foo; |
139 | for my $n ('A'..'E') { |
140 | $foo{$n} = sub { $n eq $_[0] }; |
141 | } |
142 | |
143 | test { |
144 | &{$foo{A}}('A') and |
145 | &{$foo{B}}('B') and |
146 | &{$foo{C}}('C') and |
147 | &{$foo{D}}('D') and |
148 | &{$foo{E}}('E') |
149 | }; |
150 | |
151 | for my $n (0..4) { |
152 | $foo[$n] = sub { $n == $_[0] }; |
153 | } |
154 | |
155 | test { |
156 | &{$foo[0]}(0) and |
157 | &{$foo[1]}(1) and |
158 | &{$foo[2]}(2) and |
159 | &{$foo[3]}(3) and |
160 | &{$foo[4]}(4) |
161 | }; |
162 | |
94f23f41 |
163 | for my $n (0..4) { |
164 | $foo[$n] = sub { |
165 | # no intervening reference to $n here |
166 | sub { $n == $_[0] } |
167 | }; |
168 | } |
169 | |
170 | test { |
171 | $foo[0]->()->(0) and |
172 | $foo[1]->()->(1) and |
173 | $foo[2]->()->(2) and |
174 | $foo[3]->()->(3) and |
175 | $foo[4]->()->(4) |
176 | }; |
177 | |
354992b1 |
178 | { |
179 | my $w; |
180 | $w = sub { |
181 | my ($i) = @_; |
182 | test { $i == 10 }; |
183 | sub { $w }; |
184 | }; |
185 | $w->(10); |
186 | } |
94f23f41 |
187 | |
0a753a76 |
188 | # Additional tests by Tom Phoenix <rootbeer@teleport.com>. |
189 | |
190 | { |
0a753a76 |
191 | use strict; |
192 | |
193 | use vars qw!$test!; |
194 | my($debugging, %expected, $inner_type, $where_declared, $within); |
195 | my($nc_attempt, $call_outer, $call_inner, $undef_outer); |
196 | my($code, $inner_sub_test, $expected, $line, $errors, $output); |
197 | my(@inners, $sub_test, $pid); |
198 | $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug'; |
199 | |
200 | # The expected values for these tests |
201 | %expected = ( |
202 | 'global_scalar' => 1001, |
203 | 'global_array' => 2101, |
204 | 'global_hash' => 3004, |
205 | 'fs_scalar' => 4001, |
206 | 'fs_array' => 5101, |
207 | 'fs_hash' => 6004, |
208 | 'sub_scalar' => 7001, |
209 | 'sub_array' => 8101, |
210 | 'sub_hash' => 9004, |
211 | 'foreach' => 10011, |
212 | ); |
213 | |
214 | # Our innermost sub is either named or anonymous |
215 | for $inner_type (qw!named anon!) { |
216 | # And it may be declared at filescope, within a named |
217 | # sub, or within an anon sub |
218 | for $where_declared (qw!filescope in_named in_anon!) { |
219 | # And that, in turn, may be within a foreach loop, |
220 | # a naked block, or another named sub |
221 | for $within (qw!foreach naked other_sub!) { |
222 | |
223 | # Here are a number of variables which show what's |
224 | # going on, in a way. |
225 | $nc_attempt = 0+ # Named closure attempted |
226 | ( ($inner_type eq 'named') || |
227 | ($within eq 'other_sub') ) ; |
228 | $call_inner = 0+ # Need to call &inner |
229 | ( ($inner_type eq 'anon') && |
230 | ($within eq 'other_sub') ) ; |
231 | $call_outer = 0+ # Need to call &outer or &$outer |
232 | ( ($inner_type eq 'anon') && |
233 | ($within ne 'other_sub') ) ; |
234 | $undef_outer = 0+ # $outer is created but unused |
235 | ( ($where_declared eq 'in_anon') && |
236 | (not $call_outer) ) ; |
237 | |
238 | $code = "# This is a test script built by t/op/closure.t\n\n"; |
239 | |
a16a9fa3 |
240 | print <<"DEBUG_INFO" if $debugging; |
241 | # inner_type: $inner_type |
0a753a76 |
242 | # where_declared: $where_declared |
a16a9fa3 |
243 | # within: $within |
244 | # nc_attempt: $nc_attempt |
245 | # call_inner: $call_inner |
246 | # call_outer: $call_outer |
247 | # undef_outer: $undef_outer |
0a753a76 |
248 | DEBUG_INFO |
249 | |
250 | $code .= <<"END_MARK_ONE"; |
251 | |
252 | BEGIN { \$SIG{__WARN__} = sub { |
253 | my \$msg = \$_[0]; |
254 | END_MARK_ONE |
255 | |
256 | $code .= <<"END_MARK_TWO" if $nc_attempt; |
257 | return if index(\$msg, 'will not stay shared') != -1; |
b5c19bd7 |
258 | return if index(\$msg, 'is not available') != -1; |
0a753a76 |
259 | END_MARK_TWO |
260 | |
261 | $code .= <<"END_MARK_THREE"; # Backwhack a lot! |
262 | print "not ok: got unexpected warning \$msg\\n"; |
263 | } } |
264 | |
265 | { |
266 | my \$test = $test; |
267 | sub test (&) { |
a16a9fa3 |
268 | my \$ok = &{\$_[0]}; |
269 | print \$ok ? "ok \$test\n" : "not ok \$test\n"; |
270 | printf "# Failed at line %d\n", (caller)[2] unless \$ok; |
0a753a76 |
271 | \$test++; |
272 | } |
273 | } |
274 | |
275 | # some of the variables which the closure will access |
276 | \$global_scalar = 1000; |
277 | \@global_array = (2000, 2100, 2200, 2300); |
278 | %global_hash = 3000..3009; |
279 | |
280 | my \$fs_scalar = 4000; |
281 | my \@fs_array = (5000, 5100, 5200, 5300); |
282 | my %fs_hash = 6000..6009; |
283 | |
284 | END_MARK_THREE |
285 | |
286 | if ($where_declared eq 'filescope') { |
287 | # Nothing here |
288 | } elsif ($where_declared eq 'in_named') { |
289 | $code .= <<'END'; |
290 | sub outer { |
291 | my $sub_scalar = 7000; |
292 | my @sub_array = (8000, 8100, 8200, 8300); |
293 | my %sub_hash = 9000..9009; |
294 | END |
295 | # } |
296 | } elsif ($where_declared eq 'in_anon') { |
297 | $code .= <<'END'; |
298 | $outer = sub { |
299 | my $sub_scalar = 7000; |
300 | my @sub_array = (8000, 8100, 8200, 8300); |
301 | my %sub_hash = 9000..9009; |
302 | END |
303 | # } |
304 | } else { |
305 | die "What was $where_declared?" |
306 | } |
307 | |
308 | if ($within eq 'foreach') { |
309 | $code .= " |
310 | my \$foreach = 12000; |
311 | my \@list = (10000, 10010); |
312 | foreach \$foreach (\@list) { |
313 | " # } |
314 | } elsif ($within eq 'naked') { |
315 | $code .= " { # naked block\n" # } |
316 | } elsif ($within eq 'other_sub') { |
317 | $code .= " sub inner_sub {\n" # } |
318 | } else { |
319 | die "What was $within?" |
320 | } |
321 | |
322 | $sub_test = $test; |
323 | @inners = ( qw!global_scalar global_array global_hash! , |
324 | qw!fs_scalar fs_array fs_hash! ); |
325 | push @inners, 'foreach' if $within eq 'foreach'; |
326 | if ($where_declared ne 'filescope') { |
327 | push @inners, qw!sub_scalar sub_array sub_hash!; |
328 | } |
329 | for $inner_sub_test (@inners) { |
330 | |
331 | if ($inner_type eq 'named') { |
332 | $code .= " sub named_$sub_test " |
333 | } elsif ($inner_type eq 'anon') { |
334 | $code .= " \$anon_$sub_test = sub " |
335 | } else { |
336 | die "What was $inner_type?" |
337 | } |
338 | |
339 | # Now to write the body of the test sub |
340 | if ($inner_sub_test eq 'global_scalar') { |
341 | $code .= '{ ++$global_scalar }' |
342 | } elsif ($inner_sub_test eq 'fs_scalar') { |
343 | $code .= '{ ++$fs_scalar }' |
344 | } elsif ($inner_sub_test eq 'sub_scalar') { |
345 | $code .= '{ ++$sub_scalar }' |
346 | } elsif ($inner_sub_test eq 'global_array') { |
347 | $code .= '{ ++$global_array[1] }' |
348 | } elsif ($inner_sub_test eq 'fs_array') { |
349 | $code .= '{ ++$fs_array[1] }' |
350 | } elsif ($inner_sub_test eq 'sub_array') { |
351 | $code .= '{ ++$sub_array[1] }' |
352 | } elsif ($inner_sub_test eq 'global_hash') { |
353 | $code .= '{ ++$global_hash{3002} }' |
354 | } elsif ($inner_sub_test eq 'fs_hash') { |
355 | $code .= '{ ++$fs_hash{6002} }' |
356 | } elsif ($inner_sub_test eq 'sub_hash') { |
357 | $code .= '{ ++$sub_hash{9002} }' |
358 | } elsif ($inner_sub_test eq 'foreach') { |
359 | $code .= '{ ++$foreach }' |
360 | } else { |
361 | die "What was $inner_sub_test?" |
362 | } |
363 | |
364 | # Close up |
365 | if ($inner_type eq 'anon') { |
366 | $code .= ';' |
367 | } |
368 | $code .= "\n"; |
369 | $sub_test++; # sub name sequence number |
370 | |
371 | } # End of foreach $inner_sub_test |
372 | |
373 | # Close up $within block # { |
374 | $code .= " }\n\n"; |
375 | |
376 | # Close up $where_declared block |
377 | if ($where_declared eq 'in_named') { # { |
378 | $code .= "}\n\n"; |
379 | } elsif ($where_declared eq 'in_anon') { # { |
380 | $code .= "};\n\n"; |
381 | } |
382 | |
383 | # We may need to do something with the sub we just made... |
384 | $code .= "undef \$outer;\n" if $undef_outer; |
385 | $code .= "&inner_sub;\n" if $call_inner; |
386 | if ($call_outer) { |
387 | if ($where_declared eq 'in_named') { |
388 | $code .= "&outer;\n\n"; |
389 | } elsif ($where_declared eq 'in_anon') { |
390 | $code .= "&\$outer;\n\n" |
391 | } |
392 | } |
393 | |
394 | # Now, we can actually prep to run the tests. |
395 | for $inner_sub_test (@inners) { |
396 | $expected = $expected{$inner_sub_test} or |
397 | die "expected $inner_sub_test missing"; |
398 | |
399 | # Named closures won't access the expected vars |
400 | if ( $nc_attempt and |
401 | substr($inner_sub_test, 0, 4) eq "sub_" ) { |
402 | $expected = 1; |
403 | } |
404 | |
405 | # If you make a sub within a foreach loop, |
406 | # what happens if it tries to access the |
407 | # foreach index variable? If it's a named |
408 | # sub, it gets the var from "outside" the loop, |
409 | # but if it's anon, it gets the value to which |
410 | # the index variable is aliased. |
411 | # |
412 | # Of course, if the value was set only |
413 | # within another sub which was never called, |
414 | # the value has not been set yet. |
415 | # |
416 | if ($inner_sub_test eq 'foreach') { |
417 | if ($inner_type eq 'named') { |
418 | if ($call_outer || ($where_declared eq 'filescope')) { |
419 | $expected = 12001 |
420 | } else { |
421 | $expected = 1 |
422 | } |
423 | } |
424 | } |
425 | |
426 | # Here's the test: |
427 | if ($inner_type eq 'anon') { |
428 | $code .= "test { &\$anon_$test == $expected };\n" |
429 | } else { |
430 | $code .= "test { &named_$test == $expected };\n" |
431 | } |
432 | $test++; |
433 | } |
434 | |
2986a63f |
435 | if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') { |
f86702cc |
436 | # Fork off a new perl to run the tests. |
437 | # (This is so we can catch spurious warnings.) |
438 | $| = 1; print ""; $| = 0; # flush output before forking |
439 | pipe READ, WRITE or die "Can't make pipe: $!"; |
440 | pipe READ2, WRITE2 or die "Can't make second pipe: $!"; |
441 | die "Can't fork: $!" unless defined($pid = open PERL, "|-"); |
442 | unless ($pid) { |
443 | # Child process here. We're going to send errors back |
444 | # through the extra pipe. |
445 | close READ; |
446 | close READ2; |
447 | open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!"; |
448 | open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!"; |
449 | exec './perl', '-w', '-' |
0a753a76 |
450 | or die "Can't exec ./perl: $!"; |
f86702cc |
451 | } else { |
452 | # Parent process here. |
453 | close WRITE; |
454 | close WRITE2; |
455 | print PERL $code; |
456 | close PERL; |
457 | { local $/; |
458 | $output = join '', <READ>; |
459 | $errors = join '', <READ2>; } |
460 | close READ; |
461 | close READ2; |
462 | } |
463 | } else { |
464 | # No fork(). Do it the hard way. |
465 | my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile; |
f86702cc |
466 | my $errfile = "terr$$"; $errfile++ while -e $errfile; |
aa689395 |
467 | my @tmpfiles = ($cmdfile, $errfile); |
f86702cc |
468 | open CMD, ">$cmdfile"; print CMD $code; close CMD; |
68dc0745 |
469 | my $cmd = (($^O eq 'VMS') ? "MCR $^X" |
470 | : ($^O eq 'MSWin32') ? '.\perl' |
95e8664e |
471 | : ($^O eq 'MacOS') ? $^X |
2986a63f |
472 | : ($^O eq 'NetWare') ? 'perl' |
68dc0745 |
473 | : './perl'); |
aa689395 |
474 | $cmd .= " -w $cmdfile 2>$errfile"; |
2986a63f |
475 | if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') { |
aa689395 |
476 | # Use pipe instead of system so we don't inherit STD* from |
477 | # this process, and then foul our pipe back to parent by |
478 | # redirecting output in the child. |
479 | open PERL,"$cmd |" or die "Can't open pipe: $!\n"; |
480 | { local $/; $output = join '', <PERL> } |
481 | close PERL; |
482 | } else { |
483 | my $outfile = "tout$$"; $outfile++ while -e $outfile; |
484 | push @tmpfiles, $outfile; |
485 | system "$cmd >$outfile"; |
486 | { local $/; open IN, $outfile; $output = <IN>; close IN } |
487 | } |
f86702cc |
488 | if ($?) { |
489 | printf "not ok: exited with error code %04X\n", $?; |
aa689395 |
490 | $debugging or do { 1 while unlink @tmpfiles }; |
f86702cc |
491 | exit; |
492 | } |
aa689395 |
493 | { local $/; open IN, $errfile; $errors = <IN>; close IN } |
494 | 1 while unlink @tmpfiles; |
0a753a76 |
495 | } |
f86702cc |
496 | print $output; |
497 | print STDERR $errors; |
0a753a76 |
498 | if ($debugging && ($errors || $? || ($output =~ /not ok/))) { |
499 | my $lnum = 0; |
500 | for $line (split '\n', $code) { |
501 | printf "%3d: %s\n", ++$lnum, $line; |
502 | } |
503 | } |
f86702cc |
504 | printf "not ok: exited with error code %04X\n", $? if $?; |
a16a9fa3 |
505 | print '#', "-" x 30, "\n" if $debugging; |
0a753a76 |
506 | |
507 | } # End of foreach $within |
508 | } # End of foreach $where_declared |
509 | } # End of foreach $inner_type |
510 | |
511 | } |
3c1f3fdf |
512 | |
7dafbf52 |
513 | # The following dumps core with perl <= 5.8.0 (bugid 9535) ... |
2f647fb2 |
514 | BEGIN { $vanishing_pad = sub { eval $_[0] } } |
515 | $some_var = 123; |
516 | test { $vanishing_pad->( '$some_var' ) == 123 }; |
f3548bdc |
517 | |
7dafbf52 |
518 | # ... and here's another coredump variant - this time we explicitly |
519 | # delete the sub rather than using a BEGIN ... |
520 | |
521 | sub deleteme { $a = sub { eval '$newvar' } } |
522 | deleteme(); |
523 | *deleteme = sub {}; # delete the sub |
524 | $newvar = 123; # realloc the SV of the freed CV |
525 | test { $a->() == 123 }; |
526 | |
527 | # ... and a further coredump variant - the fixup of the anon sub's |
528 | # CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to |
529 | # survive the outer eval also being freed. |
530 | |
531 | $x = 123; |
532 | $a = eval q( |
533 | eval q[ |
534 | sub { eval '$x' } |
535 | ] |
536 | ); |
537 | @a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs |
538 | test { $a->() == 123 }; |
539 | |
f3548bdc |
540 | # this coredumped on <= 5.8.0 because evaling the closure caused |
541 | # an SvFAKE to be added to the outer anon's pad, which was then grown. |
542 | my $outer; |
543 | sub { |
544 | my $x; |
545 | $x = eval 'sub { $outer }'; |
546 | $x->(); |
547 | $a = [ 99 ]; |
548 | $x->(); |
549 | }->(); |
550 | test {1}; |
551 | |
e9f19e3c |
552 | # [perl #17605] found that an empty block called in scalar context |
553 | # can lead to stack corruption |
554 | { |
555 | my $x = "foooobar"; |
556 | $x =~ s/o//eg; |
557 | test { $x eq 'fbar' } |
558 | } |
ee6cee0c |
559 | |
560 | # DAPM 24-Nov-02 |
561 | # SvFAKE lexicals should be visible thoughout a function. |
562 | # On <= 5.8.0, the third test failed, eg bugid #18286 |
563 | |
564 | { |
565 | my $x = 1; |
566 | sub fake { |
567 | test { sub {eval'$x'}->() == 1 }; |
568 | { $x; test { sub {eval'$x'}->() == 1 } } |
569 | test { sub {eval'$x'}->() == 1 }; |
570 | } |
571 | } |
572 | fake(); |
573 | |
7dafbf52 |
574 | # undefining a sub shouldn't alter visibility of outer lexicals |
575 | |
576 | { |
577 | $x = 1; |
578 | my $x = 2; |
579 | sub tmp { sub { eval '$x' } } |
580 | my $a = tmp(); |
581 | undef &tmp; |
582 | test { $a->() == 2 }; |
583 | } |
584 | |
585 | # handy class: $x = Watch->new(\$foo,'bar') |
586 | # causes 'bar' to be appended to $foo when $x is destroyed |
587 | sub Watch::new { bless [ $_[1], $_[2] ], $_[0] } |
588 | sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] } |
589 | |
590 | |
591 | # bugid 1028: |
592 | # nested anon subs (and associated lexicals) not freed early enough |
593 | |
594 | sub linger { |
595 | my $x = Watch->new($_[0], '2'); |
596 | sub { |
597 | $x; |
598 | my $y; |
599 | sub { $y; }; |
600 | }; |
601 | } |
602 | { |
603 | my $watch = '1'; |
604 | linger(\$watch); |
605 | test { $watch eq '12' } |
606 | } |
b5c19bd7 |
607 | |
608 | # bugid 10085 |
609 | # obj not freed early enough |
610 | |
611 | sub linger2 { |
612 | my $obj = Watch->new($_[0], '2'); |
613 | sub { sub { $obj } }; |
614 | } |
615 | { |
616 | my $watch = '1'; |
617 | linger2(\$watch); |
618 | test { $watch eq '12' } |
619 | } |
620 | |
621 | # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs |
622 | |
623 | { |
624 | my $x = 1; |
625 | sub f16302 { |
626 | sub { |
627 | test { defined $x and $x == 1 } |
628 | }->(); |
629 | } |
630 | } |
631 | f16302(); |
632 | |
633 | # The presence of an eval should turn cloneless anon subs into clonable |
634 | # subs - otherwise the CvOUTSIDE of that sub may be wrong |
635 | |
636 | { |
637 | my %a; |
638 | for my $x (7,11) { |
639 | $a{$x} = sub { $x=$x; sub { eval '$x' } }; |
640 | } |
641 | test { $a{7}->()->() + $a{11}->()->() == 18 }; |
642 | } |
643 | |
9d1ce744 |
644 | # bugid #23265 - this used to coredump during destruction of PL_maincv |
645 | # and its children |
646 | |
647 | require './test.pl'; |
648 | |
649 | my $got = runperl( |
650 | prog => q[ |
651 | print |
652 | sub {$_[0]->(@_)} -> ( |
653 | sub { |
654 | $_[1] |
655 | ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->() |
656 | : "y" |
657 | }, |
658 | 2 |
659 | ) |
660 | , "\n" |
661 | ; |
662 | |
663 | ], |
664 | stderr => 1 |
665 | ); |
666 | test { $got eq "yxx\n" }; |
b5c19bd7 |
667 | |