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