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