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