This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_24 to perl5.003_25]
[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
8 BEGIN {
9     chdir 't' if -d 't';
10     @INC = '../lib';
11 }
12
13 use Config;
14
15 print "1..167\n";
16
17 my $test = 1;
18 sub test (&) {
19   print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
20   $test++;
21 }
22
23 my $i = 1;
24 sub foo { $i = shift if @_; $i }
25
26 # no closure
27 test { foo == 1 };
28 foo(2);
29 test { foo == 2 };
30
31 # closure: lexical outside sub
32 my $foo = sub {$i = shift if @_; $i };
33 my $bar = sub {$i = shift if @_; $i };
34 test {&$foo() == 2 };
35 &$foo(3);
36 test {&$foo() == 3 };
37 # did the lexical change?
38 test { foo == 3 and $i == 3};
39 # did the second closure notice?
40 test {&$bar() == 3 };
41
42 # closure: lexical inside sub
43 sub bar {
44   my $i = shift;
45   sub { $i = shift if @_; $i }
46 }
47
48 $foo = bar(4);
49 $bar = bar(5);
50 test {&$foo() == 4 };
51 &$foo(6);
52 test {&$foo() == 6 };
53 test {&$bar() == 5 };
54
55 # nested closures
56 sub bizz {
57   my $i = 7;
58   if (@_) {
59     my $i = shift;
60     sub {$i = shift if @_; $i };
61   } else {
62     my $i = $i;
63     sub {$i = shift if @_; $i };
64   }
65 }
66 $foo = bizz();
67 $bar = bizz();
68 test {&$foo() == 7 };
69 &$foo(8);
70 test {&$foo() == 8 };
71 test {&$bar() == 7 };
72
73 $foo = bizz(9);
74 $bar = bizz(10);
75 test {&$foo(11)-1 == &$bar()};
76
77 my @foo;
78 for (qw(0 1 2 3 4)) {
79   my $i = $_;
80   $foo[$_] = sub {$i = shift if @_; $i };
81 }
82
83 test {
84   &{$foo[0]}() == 0 and
85   &{$foo[1]}() == 1 and
86   &{$foo[2]}() == 2 and
87   &{$foo[3]}() == 3 and
88   &{$foo[4]}() == 4
89   };
90
91 for (0 .. 4) {
92   &{$foo[$_]}(4-$_);
93 }
94
95 test {
96   &{$foo[0]}() == 4 and
97   &{$foo[1]}() == 3 and
98   &{$foo[2]}() == 2 and
99   &{$foo[3]}() == 1 and
100   &{$foo[4]}() == 0
101   };
102
103 sub barf {
104   my @foo;
105   for (qw(0 1 2 3 4)) {
106     my $i = $_;
107     $foo[$_] = sub {$i = shift if @_; $i };
108   }
109   @foo;
110 }
111
112 @foo = barf();
113 test {
114   &{$foo[0]}() == 0 and
115   &{$foo[1]}() == 1 and
116   &{$foo[2]}() == 2 and
117   &{$foo[3]}() == 3 and
118   &{$foo[4]}() == 4
119   };
120
121 for (0 .. 4) {
122   &{$foo[$_]}(4-$_);
123 }
124
125 test {
126   &{$foo[0]}() == 4 and
127   &{$foo[1]}() == 3 and
128   &{$foo[2]}() == 2 and
129   &{$foo[3]}() == 1 and
130   &{$foo[4]}() == 0
131   };
132
133 exit 0 unless $Config{'d_fork'};
134
135 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
136
137 {
138     use strict;
139
140     use vars qw!$test!;
141     my($debugging, %expected, $inner_type, $where_declared, $within);
142     my($nc_attempt, $call_outer, $call_inner, $undef_outer);
143     my($code, $inner_sub_test, $expected, $line, $errors, $output);
144     my(@inners, $sub_test, $pid);
145     $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
146
147     # The expected values for these tests
148     %expected = (
149         'global_scalar' => 1001,
150         'global_array'  => 2101,
151         'global_hash'   => 3004,
152         'fs_scalar'     => 4001,
153         'fs_array'      => 5101,
154         'fs_hash'       => 6004,
155         'sub_scalar'    => 7001,
156         'sub_array'     => 8101,
157         'sub_hash'      => 9004,
158         'foreach'       => 10011,
159     );
160
161     # Our innermost sub is either named or anonymous
162     for $inner_type (qw!named anon!) {
163       # And it may be declared at filescope, within a named
164       # sub, or within an anon sub
165       for $where_declared (qw!filescope in_named in_anon!) {
166         # And that, in turn, may be within a foreach loop,
167         # a naked block, or another named sub
168         for $within (qw!foreach naked other_sub!) {
169
170           # Here are a number of variables which show what's
171           # going on, in a way.
172           $nc_attempt = 0+              # Named closure attempted
173               ( ($inner_type eq 'named') ||
174               ($within eq 'other_sub') ) ;
175           $call_inner = 0+              # Need to call &inner
176               ( ($inner_type eq 'anon') &&
177               ($within eq 'other_sub') ) ;
178           $call_outer = 0+              # Need to call &outer or &$outer
179               ( ($inner_type eq 'anon') &&
180               ($within ne 'other_sub') ) ;
181           $undef_outer = 0+             # $outer is created but unused
182               ( ($where_declared eq 'in_anon') &&
183               (not $call_outer) ) ;
184
185           $code = "# This is a test script built by t/op/closure.t\n\n";
186
187           $code .= <<"DEBUG_INFO" if $debugging;
188 # inner_type: $inner_type 
189 # where_declared: $where_declared 
190 # within: $within
191 # nc_attempt: $nc_attempt
192 # call_inner: $call_inner
193 # call_outer: $call_outer
194 # undef_outer: $undef_outer
195 DEBUG_INFO
196
197           $code .= <<"END_MARK_ONE";
198
199 BEGIN { \$SIG{__WARN__} = sub { 
200     my \$msg = \$_[0];
201 END_MARK_ONE
202
203           $code .=  <<"END_MARK_TWO" if $nc_attempt;
204     return if index(\$msg, 'will not stay shared') != -1;
205     return if index(\$msg, 'may be unavailable') != -1;
206 END_MARK_TWO
207
208           $code .= <<"END_MARK_THREE";          # Backwhack a lot!
209     print "not ok: got unexpected warning \$msg\\n";
210 } }
211
212 {
213     my \$test = $test;
214     sub test (&) {
215       my \$result = &{\$_[0]};
216       print "not " unless \$result;
217       print "ok \$test\\n";
218       \$test++;
219     }
220 }
221
222 # some of the variables which the closure will access
223 \$global_scalar = 1000;
224 \@global_array = (2000, 2100, 2200, 2300);
225 %global_hash = 3000..3009;
226
227 my \$fs_scalar = 4000;
228 my \@fs_array = (5000, 5100, 5200, 5300);
229 my %fs_hash = 6000..6009;
230
231 END_MARK_THREE
232
233           if ($where_declared eq 'filescope') {
234             # Nothing here
235           } elsif ($where_declared eq 'in_named') {
236             $code .= <<'END';
237 sub outer {
238   my $sub_scalar = 7000;
239   my @sub_array = (8000, 8100, 8200, 8300);
240   my %sub_hash = 9000..9009;
241 END
242     # }
243           } elsif ($where_declared eq 'in_anon') {
244             $code .= <<'END';
245 $outer = sub {
246   my $sub_scalar = 7000;
247   my @sub_array = (8000, 8100, 8200, 8300);
248   my %sub_hash = 9000..9009;
249 END
250     # }
251           } else {
252             die "What was $where_declared?"
253           }
254
255           if ($within eq 'foreach') {
256             $code .= "
257       my \$foreach = 12000;
258       my \@list = (10000, 10010);
259       foreach \$foreach (\@list) {
260     " # }
261           } elsif ($within eq 'naked') {
262             $code .= "  { # naked block\n"      # }
263           } elsif ($within eq 'other_sub') {
264             $code .= "  sub inner_sub {\n"      # }
265           } else {
266             die "What was $within?"
267           }
268
269           $sub_test = $test;
270           @inners = ( qw!global_scalar global_array global_hash! ,
271             qw!fs_scalar fs_array fs_hash! );
272           push @inners, 'foreach' if $within eq 'foreach';
273           if ($where_declared ne 'filescope') {
274             push @inners, qw!sub_scalar sub_array sub_hash!;
275           }
276           for $inner_sub_test (@inners) {
277
278             if ($inner_type eq 'named') {
279               $code .= "    sub named_$sub_test "
280             } elsif ($inner_type eq 'anon') {
281               $code .= "    \$anon_$sub_test = sub "
282             } else {
283               die "What was $inner_type?"
284             }
285
286             # Now to write the body of the test sub
287             if ($inner_sub_test eq 'global_scalar') {
288               $code .= '{ ++$global_scalar }'
289             } elsif ($inner_sub_test eq 'fs_scalar') {
290               $code .= '{ ++$fs_scalar }'
291             } elsif ($inner_sub_test eq 'sub_scalar') {
292               $code .= '{ ++$sub_scalar }'
293             } elsif ($inner_sub_test eq 'global_array') {
294               $code .= '{ ++$global_array[1] }'
295             } elsif ($inner_sub_test eq 'fs_array') {
296               $code .= '{ ++$fs_array[1] }'
297             } elsif ($inner_sub_test eq 'sub_array') {
298               $code .= '{ ++$sub_array[1] }'
299             } elsif ($inner_sub_test eq 'global_hash') {
300               $code .= '{ ++$global_hash{3002} }'
301             } elsif ($inner_sub_test eq 'fs_hash') {
302               $code .= '{ ++$fs_hash{6002} }'
303             } elsif ($inner_sub_test eq 'sub_hash') {
304               $code .= '{ ++$sub_hash{9002} }'
305             } elsif ($inner_sub_test eq 'foreach') {
306               $code .= '{ ++$foreach }'
307             } else {
308               die "What was $inner_sub_test?"
309             }
310           
311             # Close up
312             if ($inner_type eq 'anon') {
313               $code .= ';'
314             }
315             $code .= "\n";
316             $sub_test++;        # sub name sequence number
317
318           } # End of foreach $inner_sub_test
319
320           # Close up $within block              # {
321           $code .= "  }\n\n";
322
323           # Close up $where_declared block
324           if ($where_declared eq 'in_named') {  # {
325             $code .= "}\n\n";
326           } elsif ($where_declared eq 'in_anon') {      # {
327             $code .= "};\n\n";
328           }
329
330           # We may need to do something with the sub we just made...
331           $code .= "undef \$outer;\n" if $undef_outer;
332           $code .= "&inner_sub;\n" if $call_inner;
333           if ($call_outer) {
334             if ($where_declared eq 'in_named') {
335               $code .= "&outer;\n\n";
336             } elsif ($where_declared eq 'in_anon') {
337               $code .= "&\$outer;\n\n"
338             }
339           }
340
341           # Now, we can actually prep to run the tests.
342           for $inner_sub_test (@inners) {
343             $expected = $expected{$inner_sub_test} or
344               die "expected $inner_sub_test missing";
345
346             # Named closures won't access the expected vars
347             if ( $nc_attempt and 
348                 substr($inner_sub_test, 0, 4) eq "sub_" ) {
349               $expected = 1;
350             }
351
352             # If you make a sub within a foreach loop,
353             # what happens if it tries to access the 
354             # foreach index variable? If it's a named
355             # sub, it gets the var from "outside" the loop,
356             # but if it's anon, it gets the value to which
357             # the index variable is aliased.
358             #
359             # Of course, if the value was set only
360             # within another sub which was never called,
361             # the value has not been set yet.
362             #
363             if ($inner_sub_test eq 'foreach') {
364               if ($inner_type eq 'named') {
365                 if ($call_outer || ($where_declared eq 'filescope')) {
366                   $expected = 12001
367                 } else {
368                   $expected = 1
369                 }
370               }
371             }
372
373             # Here's the test:
374             if ($inner_type eq 'anon') {
375               $code .= "test { &\$anon_$test == $expected };\n"
376             } else {
377               $code .= "test { &named_$test == $expected };\n"
378             }
379             $test++;
380           }
381
382           if ($Config{d_fork} and $^O ne 'VMS') {
383             # Fork off a new perl to run the tests.
384             # (This is so we can catch spurious warnings.)
385             $| = 1; print ""; $| = 0; # flush output before forking
386             pipe READ, WRITE or die "Can't make pipe: $!";
387             pipe READ2, WRITE2 or die "Can't make second pipe: $!";
388             die "Can't fork: $!" unless defined($pid = open PERL, "|-");
389             unless ($pid) {
390               # Child process here. We're going to send errors back
391               # through the extra pipe.
392               close READ;
393               close READ2;
394               open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
395               open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
396               exec './perl', '-w', '-'
397                 or die "Can't exec ./perl: $!";
398             } else {
399               # Parent process here.
400               close WRITE;
401               close WRITE2;
402               print PERL $code;
403               close PERL;
404               { local $/;
405                 $output = join '', <READ>;
406                 $errors = join '', <READ2>; }
407               close READ;
408               close READ2;
409             }
410           } else {
411             # No fork().  Do it the hard way.
412             my $cmdfile = "tcmd$$";  $cmdfile++ while -e $cmdfile;
413             my $outfile = "tout$$";  $outfile++ while -e $outfile;
414             my $errfile = "terr$$";  $errfile++ while -e $errfile;
415             open CMD, ">$cmdfile"; print CMD $code; close CMD;
416             my $cmd = ($^O eq 'VMS') ? "MCR $^X" : "./perl";
417             $cmd .= " -w $cmdfile >$outfile 2>$errfile";
418             system $cmd;
419             $? = 0 if $^O eq 'VMS' and $? & 1;  # Keep Unix-minded code below happy
420             if ($?) {
421               printf "not ok: exited with error code %04X\n", $?;
422               $debugging or do { 1 while unlink $cmdfile, $outfile, $errfile };
423               exit;
424             }
425             { local $/;
426               open IN, $outfile; $output = <IN>; close IN;
427               open IN, $errfile; $errors = <IN>; close IN; }
428             1 while unlink $cmdfile, $outfile, $errfile;
429           }
430           print $output;
431           print STDERR $errors;
432           if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
433             my $lnum = 0;
434             for $line (split '\n', $code) {
435               printf "%3d:  %s\n", ++$lnum, $line;
436             }
437           }
438           printf "not ok: exited with error code %04X\n", $? if $?;
439           print "-" x 30, "\n" if $debugging;
440
441         }       # End of foreach $within
442       } # End of foreach $where_declared
443     }   # End of foreach $inner_type
444
445 }