This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
487576562142c07f316d71e31aaed876c184ccae
[perl5.git] / t / op / closure.t
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 #
7 #   Run with -debug for debugging output.
8
9 BEGIN {
10     chdir 't' if -d 't';
11     @INC = '../lib';
12 }
13
14 use Config;
15 require './test.pl'; # for runperl()
16
17 my $test = 1;
18 sub test (&) {
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;
22   $test++;
23 }
24
25 my $i = 1;
26 sub foo { $i = shift if @_; $i }
27
28 # no closure
29 test { foo == 1 };
30 foo(2);
31 test { foo == 2 };
32
33 # closure: lexical outside sub
34 my $foo = sub {$i = shift if @_; $i };
35 my $bar = sub {$i = shift if @_; $i };
36 test {&$foo() == 2 };
37 &$foo(3);
38 test {&$foo() == 3 };
39 # did the lexical change?
40 test { foo == 3 and $i == 3};
41 # did the second closure notice?
42 test {&$bar() == 3 };
43
44 # closure: lexical inside sub
45 sub bar {
46   my $i = shift;
47   sub { $i = shift if @_; $i }
48 }
49
50 $foo = bar(4);
51 $bar = bar(5);
52 test {&$foo() == 4 };
53 &$foo(6);
54 test {&$foo() == 6 };
55 test {&$bar() == 5 };
56
57 # nested closures
58 sub 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();
70 test {&$foo() == 7 };
71 &$foo(8);
72 test {&$foo() == 8 };
73 test {&$bar() == 7 };
74
75 $foo = bizz(9);
76 $bar = bizz(10);
77 test {&$foo(11)-1 == &$bar()};
78
79 my @foo;
80 for (qw(0 1 2 3 4)) {
81   my $i = $_;
82   $foo[$_] = sub {$i = shift if @_; $i };
83 }
84
85 test {
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
93 for (0 .. 4) {
94   &{$foo[$_]}(4-$_);
95 }
96
97 test {
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
105 sub 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();
115 test {
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
123 for (0 .. 4) {
124   &{$foo[$_]}(4-$_);
125 }
126
127 test {
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
135 # test if closures get created in optimized for loops
136
137 my %foo;
138 for my $n ('A'..'E') {
139     $foo{$n} = sub { $n eq $_[0] };
140 }
141
142 test {
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
150 for my $n (0..4) {
151     $foo[$n] = sub { $n == $_[0] };
152 }
153
154 test {
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
162 for my $n (0..4) {
163     $foo[$n] = sub {
164                      # no intervening reference to $n here
165                      sub { $n == $_[0] }
166                    };
167 }
168
169 test {
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
177 {
178     my $w;
179     $w = sub {
180         my ($i) = @_;
181         test { $i == 10 };
182         sub { $w };
183     };
184     $w->(10);
185 }
186
187 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
188
189 {
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
239           print <<"DEBUG_INFO" if $debugging;
240 # inner_type:     $inner_type 
241 # where_declared: $where_declared 
242 # within:         $within
243 # nc_attempt:     $nc_attempt
244 # call_inner:     $call_inner
245 # call_outer:     $call_outer
246 # undef_outer:    $undef_outer
247 DEBUG_INFO
248
249           $code .= <<"END_MARK_ONE";
250
251 BEGIN { \$SIG{__WARN__} = sub { 
252     my \$msg = \$_[0];
253 END_MARK_ONE
254
255           $code .=  <<"END_MARK_TWO" if $nc_attempt;
256     return if index(\$msg, 'will not stay shared') != -1;
257     return if index(\$msg, 'is not available') != -1;
258 END_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 (&) {
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;
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
279 my \$fs_scalar = 4000;
280 my \@fs_array = (5000, 5100, 5200, 5300);
281 my %fs_hash = 6000..6009;
282
283 END_MARK_THREE
284
285           if ($where_declared eq 'filescope') {
286             # Nothing here
287           } elsif ($where_declared eq 'in_named') {
288             $code .= <<'END';
289 sub outer {
290   my $sub_scalar = 7000;
291   my @sub_array = (8000, 8100, 8200, 8300);
292   my %sub_hash = 9000..9009;
293 END
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;
301 END
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
434           if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
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: $!";
448               exec which_perl(), '-w', '-'
449                 or die "Can't exec perl: $!";
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.
464             my $cmdfile = tempfile();
465             my $errfile = tempfile();
466             open CMD, ">$cmdfile"; print CMD $code; close CMD;
467             my $cmd = which_perl();
468             $cmd .= " -w $cmdfile 2>$errfile";
469             if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
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 {
477               my $outfile = tempfile();
478               system "$cmd >$outfile";
479               { local $/; open IN, $outfile; $output = <IN>; close IN }
480             }
481             if ($?) {
482               printf "not ok: exited with error code %04X\n", $?;
483               exit;
484             }
485             { local $/; open IN, $errfile; $errors = <IN>; close IN }
486           }
487           print $output;
488           print STDERR $errors;
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           }
495           printf "not ok: exited with error code %04X\n", $? if $?;
496           print '#', "-" x 30, "\n" if $debugging;
497
498         }       # End of foreach $within
499       } # End of foreach $where_declared
500     }   # End of foreach $inner_type
501
502 }
503
504 curr_test($test);
505
506 # The following dumps core with perl <= 5.8.0 (bugid 9535) ...
507 BEGIN { $vanishing_pad = sub { eval $_[0] } }
508 $some_var = 123;
509 is($vanishing_pad->('$some_var'), 123, 'RT #9535');
510
511 # ... and here's another coredump variant - this time we explicitly
512 # delete the sub rather than using a BEGIN ...
513
514 sub deleteme { $a = sub { eval '$newvar' } }
515 deleteme();
516 *deleteme = sub {}; # delete the sub
517 $newvar = 123; # realloc the SV of the freed CV
518 is($a->(), 123, 'RT #9535');
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
531 is($a->(), 123, 'RT #9535');
532
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.
535 my $outer;
536 sub {
537     my $x;
538     $x = eval 'sub { $outer }';
539     $x->();
540     $a = [ 99 ];
541     $x->();
542 }->();
543 pass();
544
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;
550     is($x, 'fbar', 'RT #17605');
551 }
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 {
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');
563     }
564 }
565 fake();
566
567 {
568     $x = 1;
569     my $x = 2;
570     sub tmp { sub { eval '$x' } }
571     my $a = tmp();
572     undef &tmp;
573     is($a->(), 2,
574        "undefining a sub shouldn't alter visibility of outer lexicals");
575 }
576
577 # handy class: $x = Watch->new(\$foo,'bar')
578 # causes 'bar' to be appended to $foo when $x is destroyed
579 sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
580 sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
581
582 # bugid 1028:
583 # nested anon subs (and associated lexicals) not freed early enough
584
585 sub 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);
596     is($watch, '12', 'RT #1028');
597 }
598
599 # bugid 10085
600 # obj not freed early enough
601
602 sub linger2 { 
603     my $obj = Watch->new($_[0], '2');
604     sub { sub { $obj } };
605 }   
606 {
607     my $watch = '1';
608     linger2(\$watch);
609     is($watch, 12, 'RT #10085');
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 {
618             is($x, 1, 'RT #16302');
619         }->();
620     }
621 }
622 f16302();
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     }
632     is($a{7}->()->() + $a{11}->()->(), 18);
633 }
634
635 {
636    # bugid #23265 - this used to coredump during destruction of PL_maincv
637    # and its children
638
639     fresh_perl_is(<< '__EOF__', "yxx\n", {stderr => 1}, 'RT #23265');
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__
652 }
653
654 {
655     # bugid #24914 = used to coredump restoring PL_comppad in the
656     # savestack, due to the early freeing of the anon closure
657
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');
660 }
661
662
663 # After newsub is redefined outside the BEGIN, its CvOUTSIDE should point
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     }
675     is($flag, 1);
676 }
677
678 sub 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->();
690     isnt($r1, $r2,
691          "don't copy a stale lexical; crate a fresh undef one instead");
692 }
693
694 # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
695
696 BEGIN {
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();
704   is($ret, 0, 'RT #63540');
705   is($blonk_was_called, 1, 'RT #63540');
706 }
707
708 done_testing();