Move the require './test.pl' to the end of t/comp/hints.t
[p5sagit/p5-mst-13.2.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 print "1..188\n";
18
19 my $test = 1;
20 sub test (&) {
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;
24   $test++;
25 }
26
27 my $i = 1;
28 sub foo { $i = shift if @_; $i }
29
30 # no closure
31 test { foo == 1 };
32 foo(2);
33 test { foo == 2 };
34
35 # closure: lexical outside sub
36 my $foo = sub {$i = shift if @_; $i };
37 my $bar = sub {$i = shift if @_; $i };
38 test {&$foo() == 2 };
39 &$foo(3);
40 test {&$foo() == 3 };
41 # did the lexical change?
42 test { foo == 3 and $i == 3};
43 # did the second closure notice?
44 test {&$bar() == 3 };
45
46 # closure: lexical inside sub
47 sub bar {
48   my $i = shift;
49   sub { $i = shift if @_; $i }
50 }
51
52 $foo = bar(4);
53 $bar = bar(5);
54 test {&$foo() == 4 };
55 &$foo(6);
56 test {&$foo() == 6 };
57 test {&$bar() == 5 };
58
59 # nested closures
60 sub 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();
72 test {&$foo() == 7 };
73 &$foo(8);
74 test {&$foo() == 8 };
75 test {&$bar() == 7 };
76
77 $foo = bizz(9);
78 $bar = bizz(10);
79 test {&$foo(11)-1 == &$bar()};
80
81 my @foo;
82 for (qw(0 1 2 3 4)) {
83   my $i = $_;
84   $foo[$_] = sub {$i = shift if @_; $i };
85 }
86
87 test {
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
95 for (0 .. 4) {
96   &{$foo[$_]}(4-$_);
97 }
98
99 test {
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
107 sub 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();
117 test {
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
125 for (0 .. 4) {
126   &{$foo[$_]}(4-$_);
127 }
128
129 test {
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
137 # test if closures get created in optimized for loops
138
139 my %foo;
140 for my $n ('A'..'E') {
141     $foo{$n} = sub { $n eq $_[0] };
142 }
143
144 test {
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
152 for my $n (0..4) {
153     $foo[$n] = sub { $n == $_[0] };
154 }
155
156 test {
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
164 for my $n (0..4) {
165     $foo[$n] = sub {
166                      # no intervening reference to $n here
167                      sub { $n == $_[0] }
168                    };
169 }
170
171 test {
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
179 {
180     my $w;
181     $w = sub {
182         my ($i) = @_;
183         test { $i == 10 };
184         sub { $w };
185     };
186     $w->(10);
187 }
188
189 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
190
191 {
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
241           print <<"DEBUG_INFO" if $debugging;
242 # inner_type:     $inner_type 
243 # where_declared: $where_declared 
244 # within:         $within
245 # nc_attempt:     $nc_attempt
246 # call_inner:     $call_inner
247 # call_outer:     $call_outer
248 # undef_outer:    $undef_outer
249 DEBUG_INFO
250
251           $code .= <<"END_MARK_ONE";
252
253 BEGIN { \$SIG{__WARN__} = sub { 
254     my \$msg = \$_[0];
255 END_MARK_ONE
256
257           $code .=  <<"END_MARK_TWO" if $nc_attempt;
258     return if index(\$msg, 'will not stay shared') != -1;
259     return if index(\$msg, 'is not available') != -1;
260 END_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 (&) {
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;
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
281 my \$fs_scalar = 4000;
282 my \@fs_array = (5000, 5100, 5200, 5300);
283 my %fs_hash = 6000..6009;
284
285 END_MARK_THREE
286
287           if ($where_declared eq 'filescope') {
288             # Nothing here
289           } elsif ($where_declared eq 'in_named') {
290             $code .= <<'END';
291 sub outer {
292   my $sub_scalar = 7000;
293   my @sub_array = (8000, 8100, 8200, 8300);
294   my %sub_hash = 9000..9009;
295 END
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;
303 END
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
436           if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
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: $!";
450               exec which_perl(), '-w', '-'
451                 or die "Can't exec perl: $!";
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 = tempfile();
467             my $errfile = tempfile();
468             open CMD, ">$cmdfile"; print CMD $code; close CMD;
469             my $cmd = which_perl();
470             $cmd .= " -w $cmdfile 2>$errfile";
471             if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
472               # Use pipe instead of system so we don't inherit STD* from
473               # this process, and then foul our pipe back to parent by
474               # redirecting output in the child.
475               open PERL,"$cmd |" or die "Can't open pipe: $!\n";
476               { local $/; $output = join '', <PERL> }
477               close PERL;
478             } else {
479               my $outfile = tempfile();
480               system "$cmd >$outfile";
481               { local $/; open IN, $outfile; $output = <IN>; close IN }
482             }
483             if ($?) {
484               printf "not ok: exited with error code %04X\n", $?;
485               exit;
486             }
487             { local $/; open IN, $errfile; $errors = <IN>; close IN }
488           }
489           print $output;
490           print STDERR $errors;
491           if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
492             my $lnum = 0;
493             for $line (split '\n', $code) {
494               printf "%3d:  %s\n", ++$lnum, $line;
495             }
496           }
497           printf "not ok: exited with error code %04X\n", $? if $?;
498           print '#', "-" x 30, "\n" if $debugging;
499
500         }       # End of foreach $within
501       } # End of foreach $where_declared
502     }   # End of foreach $inner_type
503
504 }
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 test { $vanishing_pad->( '$some_var' ) == 123 };
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 test { $a->() == 123 };
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 test { $a->() == 123 };
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 test {1};
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     test { $x eq 'fbar' }
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                 test { sub {eval'$x'}->() == 1 };
561         { $x;   test { sub {eval'$x'}->() == 1 } }
562                 test { sub {eval'$x'}->() == 1 };
563     }
564 }
565 fake();
566
567 # undefining a sub shouldn't alter visibility of outer lexicals
568
569 {
570     $x = 1;
571     my $x = 2;
572     sub tmp { sub { eval '$x' } }
573     my $a = tmp();
574     undef &tmp;
575     test { $a->() == 2 };
576 }
577
578 # handy class: $x = Watch->new(\$foo,'bar')
579 # causes 'bar' to be appended to $foo when $x is destroyed
580 sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
581 sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
582
583
584 # bugid 1028:
585 # nested anon subs (and associated lexicals) not freed early enough
586
587 sub linger {
588     my $x = Watch->new($_[0], '2');
589     sub {
590         $x;
591         my $y;
592         sub { $y; };
593     };
594 }
595 {
596     my $watch = '1';
597     linger(\$watch);
598     test { $watch eq '12' }
599 }
600
601 # bugid 10085
602 # obj not freed early enough
603
604 sub linger2 { 
605     my $obj = Watch->new($_[0], '2');
606     sub { sub { $obj } };
607 }   
608 {
609     my $watch = '1';
610     linger2(\$watch);
611     test { $watch eq '12' }
612 }
613
614 # bugid 16302 - named subs didn't capture lexicals on behalf of inner subs
615
616 {
617     my $x = 1;
618     sub f16302 {
619         sub {
620             test { defined $x and $x == 1 }
621         }->();
622     }
623 }
624 f16302();
625
626 # The presence of an eval should turn cloneless anon subs into clonable
627 # subs - otherwise the CvOUTSIDE of that sub may be wrong
628
629 {
630     my %a;
631     for my $x (7,11) {
632         $a{$x} = sub { $x=$x; sub { eval '$x' } };
633     }
634     test { $a{7}->()->() + $a{11}->()->() == 18 };
635 }
636
637 {
638    # bugid #23265 - this used to coredump during destruction of PL_maincv
639    # and its children
640
641     my $progfile = "b23265.pl";
642     open(T, ">$progfile") or die "$0: $!\n";
643     print T << '__EOF__';
644         print
645             sub {$_[0]->(@_)} -> (
646                 sub {
647                     $_[1]
648                         ?  $_[0]->($_[0], $_[1] - 1) .  sub {"x"}->()
649                         : "y"
650                 },   
651                 2
652             )
653             , "\n"
654         ;
655 __EOF__
656     close T;
657     my $got = runperl(progfile => $progfile);
658     test { chomp $got; $got eq "yxx" };
659     END { 1 while unlink $progfile }
660 }
661
662 {
663     # bugid #24914 = used to coredump restoring PL_comppad in the
664     # savestack, due to the early freeing of the anon closure
665
666     my $got = runperl(stderr => 1, prog => 
667 'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)'
668     );
669     test { $got eq "ok\n" };
670 }
671
672 # After newsub is redefined outside the BEGIN, it's CvOUTSIDE should point
673 # to main rather than BEGIN, and BEGIN should be freed.
674
675 {
676     my $flag = 0;
677     sub  X::DESTROY { $flag = 1 }
678     {
679         my $x;
680         BEGIN {$x = \&newsub }
681         sub newsub {};
682         $x = bless {}, 'X';
683     }
684     test { $flag == 1 };
685 }
686
687 # don't copy a stale lexical; crate a fresh undef one instead
688
689 sub f {
690     my $x if $_[0];
691     sub { \$x }
692 }
693
694 {
695     f(1);
696     my $c1= f(0);
697     my $c2= f(0);
698
699     my $r1 = $c1->();
700     my $r2 = $c2->();
701     test { $r1 != $r2 };
702 }
703
704
705
706