Suppress a few compilation warnings in pp_hot.c.
[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
16 print "1..181\n";
17
18 my $test = 1;
19 sub test (&) {
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;
23   $test++;
24 }
25
26 my $i = 1;
27 sub foo { $i = shift if @_; $i }
28
29 # no closure
30 test { foo == 1 };
31 foo(2);
32 test { foo == 2 };
33
34 # closure: lexical outside sub
35 my $foo = sub {$i = shift if @_; $i };
36 my $bar = sub {$i = shift if @_; $i };
37 test {&$foo() == 2 };
38 &$foo(3);
39 test {&$foo() == 3 };
40 # did the lexical change?
41 test { foo == 3 and $i == 3};
42 # did the second closure notice?
43 test {&$bar() == 3 };
44
45 # closure: lexical inside sub
46 sub bar {
47   my $i = shift;
48   sub { $i = shift if @_; $i }
49 }
50
51 $foo = bar(4);
52 $bar = bar(5);
53 test {&$foo() == 4 };
54 &$foo(6);
55 test {&$foo() == 6 };
56 test {&$bar() == 5 };
57
58 # nested closures
59 sub 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();
71 test {&$foo() == 7 };
72 &$foo(8);
73 test {&$foo() == 8 };
74 test {&$bar() == 7 };
75
76 $foo = bizz(9);
77 $bar = bizz(10);
78 test {&$foo(11)-1 == &$bar()};
79
80 my @foo;
81 for (qw(0 1 2 3 4)) {
82   my $i = $_;
83   $foo[$_] = sub {$i = shift if @_; $i };
84 }
85
86 test {
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
94 for (0 .. 4) {
95   &{$foo[$_]}(4-$_);
96 }
97
98 test {
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
106 sub 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();
116 test {
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
124 for (0 .. 4) {
125   &{$foo[$_]}(4-$_);
126 }
127
128 test {
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
136 # test if closures get created in optimized for loops
137
138 my %foo;
139 for my $n ('A'..'E') {
140     $foo{$n} = sub { $n eq $_[0] };
141 }
142
143 test {
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
151 for my $n (0..4) {
152     $foo[$n] = sub { $n == $_[0] };
153 }
154
155 test {
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
163 for my $n (0..4) {
164     $foo[$n] = sub {
165                      # no intervening reference to $n here
166                      sub { $n == $_[0] }
167                    };
168 }
169
170 test {
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
178 {
179     my $w;
180     $w = sub {
181         my ($i) = @_;
182         test { $i == 10 };
183         sub { $w };
184     };
185     $w->(10);
186 }
187
188 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
189
190 {
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
240           print <<"DEBUG_INFO" if $debugging;
241 # inner_type:     $inner_type 
242 # where_declared: $where_declared 
243 # within:         $within
244 # nc_attempt:     $nc_attempt
245 # call_inner:     $call_inner
246 # call_outer:     $call_outer
247 # undef_outer:    $undef_outer
248 DEBUG_INFO
249
250           $code .= <<"END_MARK_ONE";
251
252 BEGIN { \$SIG{__WARN__} = sub { 
253     my \$msg = \$_[0];
254 END_MARK_ONE
255
256           $code .=  <<"END_MARK_TWO" if $nc_attempt;
257     return if index(\$msg, 'will not stay shared') != -1;
258     return if index(\$msg, 'may be unavailable') != -1;
259 END_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 (&) {
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;
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
280 my \$fs_scalar = 4000;
281 my \@fs_array = (5000, 5100, 5200, 5300);
282 my %fs_hash = 6000..6009;
283
284 END_MARK_THREE
285
286           if ($where_declared eq 'filescope') {
287             # Nothing here
288           } elsif ($where_declared eq 'in_named') {
289             $code .= <<'END';
290 sub outer {
291   my $sub_scalar = 7000;
292   my @sub_array = (8000, 8100, 8200, 8300);
293   my %sub_hash = 9000..9009;
294 END
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;
302 END
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
435           if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
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', '-'
450                 or die "Can't exec ./perl: $!";
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;
466             my $errfile = "terr$$";  $errfile++ while -e $errfile;
467             my @tmpfiles = ($cmdfile, $errfile);
468             open CMD, ">$cmdfile"; print CMD $code; close CMD;
469             my $cmd = (($^O eq 'VMS') ? "MCR $^X"
470                        : ($^O eq 'MSWin32') ? '.\perl'
471                        : ($^O eq 'MacOS') ? $^X
472                        : ($^O eq 'NetWare') ? 'perl'
473                        : './perl');
474             $cmd .= " -w $cmdfile 2>$errfile";
475             if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
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             }
488             if ($?) {
489               printf "not ok: exited with error code %04X\n", $?;
490               $debugging or do { 1 while unlink @tmpfiles };
491               exit;
492             }
493             { local $/; open IN, $errfile; $errors = <IN>; close IN }
494             1 while unlink @tmpfiles;
495           }
496           print $output;
497           print STDERR $errors;
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           }
504           printf "not ok: exited with error code %04X\n", $? if $?;
505           print '#', "-" x 30, "\n" if $debugging;
506
507         }       # End of foreach $within
508       } # End of foreach $where_declared
509     }   # End of foreach $inner_type
510
511 }
512
513 # The following dumps core with perl <= 5.8.0 (bugid 9535) ...
514 BEGIN { $vanishing_pad = sub { eval $_[0] } }
515 $some_var = 123;
516 test { $vanishing_pad->( '$some_var' ) == 123 };
517
518 # ... and here's another coredump variant - this time we explicitly
519 # delete the sub rather than using a BEGIN ...
520
521 sub deleteme { $a = sub { eval '$newvar' } }
522 deleteme();
523 *deleteme = sub {}; # delete the sub
524 $newvar = 123; # realloc the SV of the freed CV
525 test { $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
538 test { $a->() == 123 };
539
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.
542 my $outer;
543 sub {
544     my $x;
545     $x = eval 'sub { $outer }';
546     $x->();
547     $a = [ 99 ];
548     $x->();
549 }->();
550 test {1};
551
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 }
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 }
572 fake();
573
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
587 sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
588 sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
589
590
591 # bugid 1028:
592 # nested anon subs (and associated lexicals) not freed early enough
593
594 sub 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 }