[p5sagit/p5-mst-13.2.git] / t / op / closure.t

#!./perl
#                              -*- Mode: Perl -*-
# closure.t:
#   Original written by Ulrich Pfeifer on 2 Jan 1997.
#   Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
#

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

use Config;

print "1..171\n";

my $test = 1;
sub test (&) {
  print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
  $test++;
}

my $i = 1;
sub foo { $i = shift if @_; $i }

# no closure
test { foo == 1 };
foo(2);
test { foo == 2 };

# closure: lexical outside sub
my $foo = sub {$i = shift if @_; $i };
my $bar = sub {$i = shift if @_; $i };
test {&$foo() == 2 };
&$foo(3);
test {&$foo() == 3 };
# did the lexical change?
test { foo == 3 and $i == 3};
# did the second closure notice?
test {&$bar() == 3 };

# closure: lexical inside sub
sub bar {
  my $i = shift;
  sub { $i = shift if @_; $i }
}

$foo = bar(4);
$bar = bar(5);
test {&$foo() == 4 };
&$foo(6);
test {&$foo() == 6 };
test {&$bar() == 5 };

# nested closures
sub bizz {
  my $i = 7;
  if (@_) {
    my $i = shift;
    sub {$i = shift if @_; $i };
  } else {
    my $i = $i;
    sub {$i = shift if @_; $i };
  }
}
$foo = bizz();
$bar = bizz();
test {&$foo() == 7 };
&$foo(8);
test {&$foo() == 8 };
test {&$bar() == 7 };

$foo = bizz(9);
$bar = bizz(10);
test {&$foo(11)-1 == &$bar()};

my @foo;
for (qw(0 1 2 3 4)) {
  my $i = $_;
  $foo[$_] = sub {$i = shift if @_; $i };
}

test {
  &{$foo[0]}() == 0 and
  &{$foo[1]}() == 1 and
  &{$foo[2]}() == 2 and
  &{$foo[3]}() == 3 and
  &{$foo[4]}() == 4
  };

for (0 .. 4) {
  &{$foo[$_]}(4-$_);
}

test {
  &{$foo[0]}() == 4 and
  &{$foo[1]}() == 3 and
  &{$foo[2]}() == 2 and
  &{$foo[3]}() == 1 and
  &{$foo[4]}() == 0
  };

sub barf {
  my @foo;
  for (qw(0 1 2 3 4)) {
    my $i = $_;
    $foo[$_] = sub {$i = shift if @_; $i };
  }
  @foo;
}

@foo = barf();
test {
  &{$foo[0]}() == 0 and
  &{$foo[1]}() == 1 and
  &{$foo[2]}() == 2 and
  &{$foo[3]}() == 3 and
  &{$foo[4]}() == 4
  };

for (0 .. 4) {
  &{$foo[$_]}(4-$_);
}

test {
  &{$foo[0]}() == 4 and
  &{$foo[1]}() == 3 and
  &{$foo[2]}() == 2 and
  &{$foo[3]}() == 1 and
  &{$foo[4]}() == 0
  };

# test if closures get created in optimized for loops

my %foo;
for my $n ('A'..'E') {
    $foo{$n} = sub { $n eq $_[0] };
}

test {
  &{$foo{A}}('A') and
  &{$foo{B}}('B') and
  &{$foo{C}}('C') and
  &{$foo{D}}('D') and
  &{$foo{E}}('E')
};

for my $n (0..4) {
    $foo[$n] = sub { $n == $_[0] };
}

test {
  &{$foo[0]}(0) and
  &{$foo[1]}(1) and
  &{$foo[2]}(2) and
  &{$foo[3]}(3) and
  &{$foo[4]}(4)
};

for my $n (0..4) {
    $foo[$n] = sub {
                     # no intervening reference to $n here
                     sub { $n == $_[0] }
		   };
}

test {
  $foo[0]->()->(0) and
  $foo[1]->()->(1) and
  $foo[2]->()->(2) and
  $foo[3]->()->(3) and
  $foo[4]->()->(4)
};

{
    my $w;
    $w = sub {
	my ($i) = @_;
	test { $i == 10 };
	sub { $w };
    };
    $w->(10);
}

# Additional tests by Tom Phoenix <rootbeer@teleport.com>.

{
    use strict;

    use vars qw!$test!;
    my($debugging, %expected, $inner_type, $where_declared, $within);
    my($nc_attempt, $call_outer, $call_inner, $undef_outer);
    my($code, $inner_sub_test, $expected, $line, $errors, $output);
    my(@inners, $sub_test, $pid);
    $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';

    # The expected values for these tests
    %expected = (
	'global_scalar'	=> 1001,
	'global_array'	=> 2101,
	'global_hash'	=> 3004,
	'fs_scalar'	=> 4001,
	'fs_array'	=> 5101,
	'fs_hash'	=> 6004,
	'sub_scalar'	=> 7001,
	'sub_array'	=> 8101,
	'sub_hash'	=> 9004,
	'foreach'	=> 10011,
    );

    # Our innermost sub is either named or anonymous
    for $inner_type (qw!named anon!) {
      # And it may be declared at filescope, within a named
      # sub, or within an anon sub
      for $where_declared (qw!filescope in_named in_anon!) {
	# And that, in turn, may be within a foreach loop,
	# a naked block, or another named sub
	for $within (qw!foreach naked other_sub!) {

	  # Here are a number of variables which show what's
	  # going on, in a way.
	  $nc_attempt = 0+		# Named closure attempted
	      ( ($inner_type eq 'named') ||
	      ($within eq 'other_sub') ) ;
	  $call_inner = 0+		# Need to call &inner
	      ( ($inner_type eq 'anon') &&
	      ($within eq 'other_sub') ) ;
	  $call_outer = 0+		# Need to call &outer or &$outer
	      ( ($inner_type eq 'anon') &&
	      ($within ne 'other_sub') ) ;
	  $undef_outer = 0+		# $outer is created but unused
	      ( ($where_declared eq 'in_anon') &&
	      (not $call_outer) ) ;

	  $code = "# This is a test script built by t/op/closure.t\n\n";

	  $code .= <<"DEBUG_INFO" if $debugging;
# inner_type: $inner_type 
# where_declared: $where_declared 
# within: $within
# nc_attempt: $nc_attempt
# call_inner: $call_inner
# call_outer: $call_outer
# undef_outer: $undef_outer
DEBUG_INFO

	  $code .= <<"END_MARK_ONE";

BEGIN { \$SIG{__WARN__} = sub { 
    my \$msg = \$_[0];
END_MARK_ONE

	  $code .=  <<"END_MARK_TWO" if $nc_attempt;
    return if index(\$msg, 'will not stay shared') != -1;
    return if index(\$msg, 'may be unavailable') != -1;
END_MARK_TWO

	  $code .= <<"END_MARK_THREE";		# Backwhack a lot!
    print "not ok: got unexpected warning \$msg\\n";
} }

{
    my \$test = $test;
    sub test (&) {
      my \$result = &{\$_[0]};
      print "not " unless \$result;
      print "ok \$test\\n";
      \$test++;
    }
}

# some of the variables which the closure will access
\$global_scalar = 1000;
\@global_array = (2000, 2100, 2200, 2300);
%global_hash = 3000..3009;

my \$fs_scalar = 4000;
my \@fs_array = (5000, 5100, 5200, 5300);
my %fs_hash = 6000..6009;

END_MARK_THREE

	  if ($where_declared eq 'filescope') {
	    # Nothing here
	  } elsif ($where_declared eq 'in_named') {
	    $code .= <<'END';
sub outer {
  my $sub_scalar = 7000;
  my @sub_array = (8000, 8100, 8200, 8300);
  my %sub_hash = 9000..9009;
END
    # }
	  } elsif ($where_declared eq 'in_anon') {
	    $code .= <<'END';
$outer = sub {
  my $sub_scalar = 7000;
  my @sub_array = (8000, 8100, 8200, 8300);
  my %sub_hash = 9000..9009;
END
    # }
	  } else {
	    die "What was $where_declared?"
	  }

	  if ($within eq 'foreach') {
	    $code .= "
      my \$foreach = 12000;
      my \@list = (10000, 10010);
      foreach \$foreach (\@list) {
    " # }
	  } elsif ($within eq 'naked') {
	    $code .= "  { # naked block\n"	# }
	  } elsif ($within eq 'other_sub') {
	    $code .= "  sub inner_sub {\n"	# }
	  } else {
	    die "What was $within?"
	  }

	  $sub_test = $test;
	  @inners = ( qw!global_scalar global_array global_hash! ,
	    qw!fs_scalar fs_array fs_hash! );
	  push @inners, 'foreach' if $within eq 'foreach';
	  if ($where_declared ne 'filescope') {
	    push @inners, qw!sub_scalar sub_array sub_hash!;
	  }
	  for $inner_sub_test (@inners) {

	    if ($inner_type eq 'named') {
	      $code .= "    sub named_$sub_test "
	    } elsif ($inner_type eq 'anon') {
	      $code .= "    \$anon_$sub_test = sub "
	    } else {
	      die "What was $inner_type?"
	    }

	    # Now to write the body of the test sub
	    if ($inner_sub_test eq 'global_scalar') {
	      $code .= '{ ++$global_scalar }'
	    } elsif ($inner_sub_test eq 'fs_scalar') {
	      $code .= '{ ++$fs_scalar }'
	    } elsif ($inner_sub_test eq 'sub_scalar') {
	      $code .= '{ ++$sub_scalar }'
	    } elsif ($inner_sub_test eq 'global_array') {
	      $code .= '{ ++$global_array[1] }'
	    } elsif ($inner_sub_test eq 'fs_array') {
	      $code .= '{ ++$fs_array[1] }'
	    } elsif ($inner_sub_test eq 'sub_array') {
	      $code .= '{ ++$sub_array[1] }'
	    } elsif ($inner_sub_test eq 'global_hash') {
	      $code .= '{ ++$global_hash{3002} }'
	    } elsif ($inner_sub_test eq 'fs_hash') {
	      $code .= '{ ++$fs_hash{6002} }'
	    } elsif ($inner_sub_test eq 'sub_hash') {
	      $code .= '{ ++$sub_hash{9002} }'
	    } elsif ($inner_sub_test eq 'foreach') {
	      $code .= '{ ++$foreach }'
	    } else {
	      die "What was $inner_sub_test?"
	    }
	  
	    # Close up
	    if ($inner_type eq 'anon') {
	      $code .= ';'
	    }
	    $code .= "\n";
	    $sub_test++;	# sub name sequence number

	  } # End of foreach $inner_sub_test

	  # Close up $within block		# {
	  $code .= "  }\n\n";

	  # Close up $where_declared block
	  if ($where_declared eq 'in_named') {	# {
	    $code .= "}\n\n";
	  } elsif ($where_declared eq 'in_anon') {	# {
	    $code .= "};\n\n";
	  }

	  # We may need to do something with the sub we just made...
	  $code .= "undef \$outer;\n" if $undef_outer;
	  $code .= "&inner_sub;\n" if $call_inner;
	  if ($call_outer) {
	    if ($where_declared eq 'in_named') {
	      $code .= "&outer;\n\n";
	    } elsif ($where_declared eq 'in_anon') {
	      $code .= "&\$outer;\n\n"
	    }
	  }

	  # Now, we can actually prep to run the tests.
	  for $inner_sub_test (@inners) {
	    $expected = $expected{$inner_sub_test} or
	      die "expected $inner_sub_test missing";

	    # Named closures won't access the expected vars
	    if ( $nc_attempt and 
		substr($inner_sub_test, 0, 4) eq "sub_" ) {
	      $expected = 1;
	    }

	    # If you make a sub within a foreach loop,
	    # what happens if it tries to access the 
	    # foreach index variable? If it's a named
	    # sub, it gets the var from "outside" the loop,
	    # but if it's anon, it gets the value to which
	    # the index variable is aliased.
	    #
	    # Of course, if the value was set only
	    # within another sub which was never called,
	    # the value has not been set yet.
	    #
	    if ($inner_sub_test eq 'foreach') {
	      if ($inner_type eq 'named') {
		if ($call_outer || ($where_declared eq 'filescope')) {
		  $expected = 12001
		} else {
		  $expected = 1
		}
	      }
	    }

	    # Here's the test:
	    if ($inner_type eq 'anon') {
	      $code .= "test { &\$anon_$test == $expected };\n"
	    } else {
	      $code .= "test { &named_$test == $expected };\n"
	    }
	    $test++;
	  }

	  if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') {
	    # Fork off a new perl to run the tests.
	    # (This is so we can catch spurious warnings.)
	    $| = 1; print ""; $| = 0; # flush output before forking
	    pipe READ, WRITE or die "Can't make pipe: $!";
	    pipe READ2, WRITE2 or die "Can't make second pipe: $!";
	    die "Can't fork: $!" unless defined($pid = open PERL, "|-");
	    unless ($pid) {
	      # Child process here. We're going to send errors back
	      # through the extra pipe.
	      close READ;
	      close READ2;
	      open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
	      open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
	      exec './perl', '-w', '-'
		or die "Can't exec ./perl: $!";
	    } else {
	      # Parent process here.
	      close WRITE;
	      close WRITE2;
	      print PERL $code;
	      close PERL;
	      { local $/;
	        $output = join '', <READ>;
	        $errors = join '', <READ2>; }
	      close READ;
	      close READ2;
	    }
	  } else {
	    # No fork().  Do it the hard way.
	    my $cmdfile = "tcmd$$";  $cmdfile++ while -e $cmdfile;
	    my $errfile = "terr$$";  $errfile++ while -e $errfile;
	    my @tmpfiles = ($cmdfile, $errfile);
	    open CMD, ">$cmdfile"; print CMD $code; close CMD;
	    my $cmd = (($^O eq 'VMS') ? "MCR $^X"
		       : ($^O eq 'MSWin32') ? '.\perl'
		       : './perl');
	    $cmd .= " -w $cmdfile 2>$errfile";
	    if ($^O eq 'VMS' or $^O eq 'MSWin32') {
	      # Use pipe instead of system so we don't inherit STD* from
	      # this process, and then foul our pipe back to parent by
	      # redirecting output in the child.
	      open PERL,"$cmd |" or die "Can't open pipe: $!\n";
	      { local $/; $output = join '', <PERL> }
	      close PERL;
	    } else {
	      my $outfile = "tout$$";  $outfile++ while -e $outfile;
	      push @tmpfiles, $outfile;
	      system "$cmd >$outfile";
	      { local $/; open IN, $outfile; $output = <IN>; close IN }
	    }
	    if ($?) {
	      printf "not ok: exited with error code %04X\n", $?;
	      $debugging or do { 1 while unlink @tmpfiles };
	      exit;
	    }
	    { local $/; open IN, $errfile; $errors = <IN>; close IN }
	    1 while unlink @tmpfiles;
	  }
	  print $output;
	  print STDERR $errors;
	  if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
	    my $lnum = 0;
	    for $line (split '\n', $code) {
	      printf "%3d:  %s\n", ++$lnum, $line;
	    }
	  }
	  printf "not ok: exited with error code %04X\n", $? if $?;
	  print "-" x 30, "\n" if $debugging;

	}	# End of foreach $within
      }	# End of foreach $where_declared
    }	# End of foreach $inner_type

}
Commit	Line	Data
0a753a76	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
f86702cc	8	BEGIN {
f86702cc	9	chdir 't' if -d 't';
20822f61	10	@INC = '../lib';
f86702cc	11	}
	12
	13	use Config;
	14
354992b1	15	print "1..171\n";
0a753a76	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
3c1f3fdf	133	# test if closures get created in optimized for loops
	134
	135	my %foo;
	136	for my $n ('A'..'E') {
	137	$foo{$n} = sub { $n eq $_[0] };
	138	}
	139
	140	test {
	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
	148	for my $n (0..4) {
	149	$foo[$n] = sub { $n == $_[0] };
	150	}
	151
	152	test {
	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
94f23f41	160	for my $n (0..4) {
	161	$foo[$n] = sub {
	162	# no intervening reference to $n here
	163	sub { $n == $_[0] }
	164	};
	165	}
	166
	167	test {
	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
354992b1	175	{
	176	my $w;
	177	$w = sub {
	178	my ($i) = @_;
	179	test { $i == 10 };
	180	sub { $w };
	181	};
	182	$w->(10);
	183	}
94f23f41	184
0a753a76	185	# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
	186
	187	{
0a753a76	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
	245	DEBUG_INFO
	246
	247	$code .= <<"END_MARK_ONE";
	248
	249	BEGIN { \$SIG{__WARN__} = sub {
	250	my \$msg = \$_[0];
	251	END_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;
256	END_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
277	my \$fs_scalar = 4000;
278	my \@fs_array = (5000, 5100, 5200, 5300);
279	my %fs_hash = 6000..6009;
280
281	END_MARK_THREE
282
283	if ($where_declared eq 'filescope') {
284	# Nothing here
285	} elsif ($where_declared eq 'in_named') {
286	$code .= <<'END';
287	sub outer {
288	my $sub_scalar = 7000;
289	my @sub_array = (8000, 8100, 8200, 8300);
290	my %sub_hash = 9000..9009;
291	END
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;
299	END
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
68dc0745	432	if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') {
f86702cc	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', '-'
0a753a76	447	or die "Can't exec ./perl: $!";
f86702cc	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;
f86702cc	463	my $errfile = "terr$$"; $errfile++ while -e $errfile;
aa689395	464	my @tmpfiles = ($cmdfile, $errfile);
f86702cc	465	open CMD, ">$cmdfile"; print CMD $code; close CMD;
68dc0745	466	my $cmd = (($^O eq 'VMS') ? "MCR $^X"
	467	: ($^O eq 'MSWin32') ? '.\perl'
	468	: './perl');
aa689395	469	$cmd .= " -w $cmdfile 2>$errfile";
68dc0745	470	if ($^O eq 'VMS' or $^O eq 'MSWin32') {
aa689395	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	}
f86702cc	483	if ($?) {
f86702cc	484	printf "not ok: exited with error code %04X\n", $?;
aa689395	485	$debugging or do { 1 while unlink @tmpfiles };
f86702cc	486	exit;
f86702cc	487	}
aa689395	488	{ local $/; open IN, $errfile; $errors = <IN>; close IN }
aa689395	489	1 while unlink @tmpfiles;
0a753a76	490	}
f86702cc	491	print $output;
f86702cc	492	print STDERR $errors;
0a753a76	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	}
f86702cc	499	printf "not ok: exited with error code %04X\n", $? if $?;
f86702cc	500	print "-" x 30, "\n" if $debugging;
0a753a76	501
	502	} # End of foreach $within
	503	} # End of foreach $where_declared
	504	} # End of foreach $inner_type
	505
	506	}
3c1f3fdf	507