This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove small memory leak in newATTRSUB that manifested as a
[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';
f86702cc
PP
12}
13
14use Config;
15
b36bdeca 16print "1..186\n";
0a753a76
PP
17
18my $test = 1;
19sub test (&) {
a16a9fa3
MS
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
PP
23 $test++;
24}
25
26my $i = 1;
27sub foo { $i = shift if @_; $i }
28
29# no closure
30test { foo == 1 };
31foo(2);
32test { foo == 2 };
33
34# closure: lexical outside sub
35my $foo = sub {$i = shift if @_; $i };
36my $bar = sub {$i = shift if @_; $i };
37test {&$foo() == 2 };
38&$foo(3);
39test {&$foo() == 3 };
40# did the lexical change?
41test { foo == 3 and $i == 3};
42# did the second closure notice?
43test {&$bar() == 3 };
44
45# closure: lexical inside sub
46sub bar {
47 my $i = shift;
48 sub { $i = shift if @_; $i }
49}
50
51$foo = bar(4);
52$bar = bar(5);
53test {&$foo() == 4 };
54&$foo(6);
55test {&$foo() == 6 };
56test {&$bar() == 5 };
57
58# nested closures
59sub 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();
71test {&$foo() == 7 };
72&$foo(8);
73test {&$foo() == 8 };
74test {&$bar() == 7 };
75
76$foo = bizz(9);
77$bar = bizz(10);
78test {&$foo(11)-1 == &$bar()};
79
80my @foo;
81for (qw(0 1 2 3 4)) {
82 my $i = $_;
83 $foo[$_] = sub {$i = shift if @_; $i };
84}
85
86test {
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
94for (0 .. 4) {
95 &{$foo[$_]}(4-$_);
96}
97
98test {
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
106sub 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();
116test {
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
124for (0 .. 4) {
125 &{$foo[$_]}(4-$_);
126}
127
128test {
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
GS
136# test if closures get created in optimized for loops
137
138my %foo;
139for my $n ('A'..'E') {
140 $foo{$n} = sub { $n eq $_[0] };
141}
142
143test {
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
151for my $n (0..4) {
152 $foo[$n] = sub { $n == $_[0] };
153}
154
155test {
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
GS
163for my $n (0..4) {
164 $foo[$n] = sub {
165 # no intervening reference to $n here
166 sub { $n == $_[0] }
167 };
168}
169
170test {
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
GS
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
PP
188# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
189
190{
0a753a76
PP
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
MS
240 print <<"DEBUG_INFO" if $debugging;
241# inner_type: $inner_type
0a753a76 242# where_declared: $where_declared
a16a9fa3
MS
243# within: $within
244# nc_attempt: $nc_attempt
245# call_inner: $call_inner
246# call_outer: $call_outer
247# undef_outer: $undef_outer
0a753a76
PP
248DEBUG_INFO
249
250 $code .= <<"END_MARK_ONE";
251
252BEGIN { \$SIG{__WARN__} = sub {
253 my \$msg = \$_[0];
254END_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
PP
259END_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
MS
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
PP
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
280my \$fs_scalar = 4000;
281my \@fs_array = (5000, 5100, 5200, 5300);
282my %fs_hash = 6000..6009;
283
284END_MARK_THREE
285
286 if ($where_declared eq 'filescope') {
287 # Nothing here
288 } elsif ($where_declared eq 'in_named') {
289 $code .= <<'END';
290sub outer {
291 my $sub_scalar = 7000;
292 my @sub_array = (8000, 8100, 8200, 8300);
293 my %sub_hash = 9000..9009;
294END
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;
302END
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
PP
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
PP
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
PP
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
PP
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
PP
488 if ($?) {
489 printf "not ok: exited with error code %04X\n", $?;
aa689395 490 $debugging or do { 1 while unlink @tmpfiles };
f86702cc
PP
491 exit;
492 }
aa689395
PP
493 { local $/; open IN, $errfile; $errors = <IN>; close IN }
494 1 while unlink @tmpfiles;
0a753a76 495 }
f86702cc
PP
496 print $output;
497 print STDERR $errors;
0a753a76
PP
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
PP
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
RGS
514BEGIN { $vanishing_pad = sub { eval $_[0] } }
515$some_var = 123;
516test { $vanishing_pad->( '$some_var' ) == 123 };
f3548bdc 517
7dafbf52
DM
518# ... and here's another coredump variant - this time we explicitly
519# delete the sub rather than using a BEGIN ...
520
521sub deleteme { $a = sub { eval '$newvar' } }
522deleteme();
523*deleteme = sub {}; # delete the sub
524$newvar = 123; # realloc the SV of the freed CV
525test { $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
538test { $a->() == 123 };
539
f3548bdc
DM
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.
542my $outer;
543sub {
544 my $x;
545 $x = eval 'sub { $outer }';
546 $x->();
547 $a = [ 99 ];
548 $x->();
549}->();
550test {1};
551
e9f19e3c
HS
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
DM
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}
572fake();
573
7dafbf52
DM
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
587sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
588sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
589
590
591# bugid 1028:
592# nested anon subs (and associated lexicals) not freed early enough
593
594sub 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
DM
607
608# bugid 10085
609# obj not freed early enough
610
611sub 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}
631f16302();
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
ed1af28e
JH
644require './test.pl'; # for runperl()
645
646{
647 # bugid #23265 - this used to coredump during destruction of PL_maincv
648 # and its children
649
650 my $progfile = "b23265.pl";
651 open(T, ">$progfile") or die "$0: $!\n";
652 print T << '__EOF__';
653 print
654 sub {$_[0]->(@_)} -> (
655 sub {
656 $_[1]
657 ? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->()
658 : "y"
659 },
660 2
661 )
662 , "\n"
663 ;
664__EOF__
665 close T;
666 my $got = runperl(progfile => $progfile);
667 test { chomp $got; $got eq "yxx" };
668 END { 1 while unlink $progfile }
669}
670
b36bdeca
DM
671{
672 # bugid #24914 = used to coredump restoring PL_comppad in the
673 # savestack, due to the early freeing of the anon closure
674
675 my $got = runperl(stderr => 1, prog =>
676'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qw(ok)'
677 );
678 test { $got eq 'ok' };
679}
680
681
682
b5c19bd7 683