This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #114888] Localise PL_comppad_name in cv_clone
[perl5.git] / t / op / closure.t
CommitLineData
0a753a76
PP
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
PP
9BEGIN {
10 chdir 't' if -d 't';
20822f61 11 @INC = '../lib';
60d91a71 12 require './test.pl';
f86702cc
PP
13}
14
15use Config;
0a753a76
PP
16
17my $i = 1;
18sub foo { $i = shift if @_; $i }
19
20# no closure
13d4f794 21is(foo, 1);
0a753a76 22foo(2);
13d4f794 23is(foo, 2);
0a753a76
PP
24
25# closure: lexical outside sub
26my $foo = sub {$i = shift if @_; $i };
27my $bar = sub {$i = shift if @_; $i };
13d4f794 28is(&$foo(), 2);
0a753a76 29&$foo(3);
13d4f794 30is(&$foo(), 3);
0a753a76 31# did the lexical change?
13d4f794
NC
32is(foo, 3, 'lexical changed');
33is($i, 3, 'lexical changed');
0a753a76 34# did the second closure notice?
13d4f794 35is(&$bar(), 3, 'second closure noticed');
0a753a76
PP
36
37# closure: lexical inside sub
38sub bar {
39 my $i = shift;
40 sub { $i = shift if @_; $i }
41}
42
43$foo = bar(4);
44$bar = bar(5);
13d4f794 45is(&$foo(), 4);
0a753a76 46&$foo(6);
13d4f794
NC
47is(&$foo(), 6);
48is(&$bar(), 5);
0a753a76
PP
49
50# nested closures
51sub 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 63is(&$foo(), 7);
0a753a76 64&$foo(8);
13d4f794
NC
65is(&$foo(), 8);
66is(&$bar(), 7);
0a753a76
PP
67
68$foo = bizz(9);
69$bar = bizz(10);
13d4f794 70is(&$foo(11)-1, &$bar());
0a753a76
PP
71
72my @foo;
73for (qw(0 1 2 3 4)) {
74 my $i = $_;
75 $foo[$_] = sub {$i = shift if @_; $i };
76}
77
13d4f794
NC
78is(&{$foo[0]}(), 0);
79is(&{$foo[1]}(), 1);
80is(&{$foo[2]}(), 2);
81is(&{$foo[3]}(), 3);
82is(&{$foo[4]}(), 4);
0a753a76
PP
83
84for (0 .. 4) {
85 &{$foo[$_]}(4-$_);
86}
87
13d4f794
NC
88is(&{$foo[0]}(), 4);
89is(&{$foo[1]}(), 3);
90is(&{$foo[2]}(), 2);
91is(&{$foo[3]}(), 1);
92is(&{$foo[4]}(), 0);
0a753a76
PP
93
94sub 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
104is(&{$foo[0]}(), 0);
105is(&{$foo[1]}(), 1);
106is(&{$foo[2]}(), 2);
107is(&{$foo[3]}(), 3);
108is(&{$foo[4]}(), 4);
0a753a76
PP
109
110for (0 .. 4) {
111 &{$foo[$_]}(4-$_);
112}
113
13d4f794
NC
114is(&{$foo[0]}(), 4);
115is(&{$foo[1]}(), 3);
116is(&{$foo[2]}(), 2);
117is(&{$foo[3]}(), 1);
118is(&{$foo[4]}(), 0);
0a753a76 119
3c1f3fdf
GS
120# test if closures get created in optimized for loops
121
122my %foo;
123for my $n ('A'..'E') {
124 $foo{$n} = sub { $n eq $_[0] };
125}
126
13d4f794
NC
127ok(&{$foo{A}}('A'));
128ok(&{$foo{B}}('B'));
129ok(&{$foo{C}}('C'));
130ok(&{$foo{D}}('D'));
131ok(&{$foo{E}}('E'));
3c1f3fdf
GS
132
133for my $n (0..4) {
134 $foo[$n] = sub { $n == $_[0] };
135}
136
13d4f794
NC
137ok(&{$foo[0]}(0));
138ok(&{$foo[1]}(1));
139ok(&{$foo[2]}(2));
140ok(&{$foo[3]}(3));
141ok(&{$foo[4]}(4));
3c1f3fdf 142
94f23f41
GS
143for my $n (0..4) {
144 $foo[$n] = sub {
145 # no intervening reference to $n here
146 sub { $n == $_[0] }
147 };
148}
149
13d4f794
NC
150ok($foo[0]->()->(0));
151ok($foo[1]->()->(1));
152ok($foo[2]->()->(2));
153ok($foo[3]->()->(3));
154ok($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
PP
166# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
167
168{
0a753a76
PP
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
PP
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
PP
227DEBUG_INFO
228
229 $code .= <<"END_MARK_ONE";
230
231BEGIN { \$SIG{__WARN__} = sub {
232 my \$msg = \$_[0];
233END_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
PP
238END_MARK_TWO
239
240 $code .= <<"END_MARK_THREE"; # Backwhack a lot!
241 print "not ok: got unexpected warning \$msg\\n";
242} }
243
3f0b0e8e
NC
244require './test.pl';
245curr_test($test);
0a753a76
PP
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
252my \$fs_scalar = 4000;
253my \@fs_array = (5000, 5100, 5200, 5300);
254my %fs_hash = 6000..6009;
255
256END_MARK_THREE
257
258 if ($where_declared eq 'filescope') {
259 # Nothing here
260 } elsif ($where_declared eq 'in_named') {
261 $code .= <<'END';
262sub outer {
263 my $sub_scalar = 7000;
264 my @sub_array = (8000, 8100, 8200, 8300);
265 my %sub_hash = 9000..9009;
266END
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;
274END
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
PP
404 }
405 $test++;
406 }
407
2986a63f 408 if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
f86702cc
PP
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
PP
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
PP
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
PP
452 system "$cmd >$outfile";
453 { local $/; open IN, $outfile; $output = <IN>; close IN }
454 }
f86702cc
PP
455 if ($?) {
456 printf "not ok: exited with error code %04X\n", $?;
f86702cc
PP
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
PP
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
PP
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
485BEGIN { $vanishing_pad = sub { eval $_[0] } }
486$some_var = 123;
ff31df89 487is($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
492sub deleteme { $a = sub { eval '$newvar' } }
493deleteme();
494*deleteme = sub {}; # delete the sub
495$newvar = 123; # realloc the SV of the freed CV
ff31df89 496is($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 509is($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.
513my $outer;
514sub {
515 my $x;
516 $x = eval 'sub { $outer }';
517 $x->();
518 $a = [ 99 ];
519 $x->();
520}->();
ff31df89 521pass();
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}
543fake();
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
557sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
558sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
559
7dafbf52
DM
560# bugid 1028:
561# nested anon subs (and associated lexicals) not freed early enough
562
563sub 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
580sub 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}
600f16302();
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 print
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 656sub 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
676BEGIN {
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)
734do "./op/closure_test.pl" or die $@||$!;
735is $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):
760sub 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}
767mosquito(1);
768mosquito;
769# And this case in commit adf8f095c588 (5.14):
770sub 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}
778gnat();
779
7ef30830
FC
780# [perl #114018] Similar to the above, but with string eval
781sub 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}
789staleval 1;
790staleval;
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.
798SKIP: {
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 818done_testing();