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