[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.
#
#   Run with -debug for debugging output.

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

use Config;

print "1..181\n";

my $test = 1;
sub test (&) {
  my $ok = &{$_[0]};
  print $ok ? "ok $test\n" : "not ok $test\n";
  printf "# Failed at line %d\n", (caller)[2] unless $ok;
  $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";

	  print <<"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 \$ok = &{\$_[0]};
      print \$ok ? "ok \$test\n" : "not ok \$test\n";
      printf "# Failed at line %d\n", (caller)[2] unless \$ok;
      \$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' and $^O ne 'NetWare') {
	    # 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'
		       : ($^O eq 'MacOS') ? $^X
		       : ($^O eq 'NetWare') ? 'perl'
		       : './perl');
	    $cmd .= " -w $cmdfile 2>$errfile";
	    if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
	      # 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

}

# The following dumps core with perl <= 5.8.0 (bugid 9535) ...
BEGIN { $vanishing_pad = sub { eval $_[0] } }
$some_var = 123;
test { $vanishing_pad->( '$some_var' ) == 123 };

# ... and here's another coredump variant - this time we explicitly
# delete the sub rather than using a BEGIN ...

sub deleteme { $a = sub { eval '$newvar' } }
deleteme();
*deleteme = sub {}; # delete the sub
$newvar = 123; # realloc the SV of the freed CV
test { $a->() == 123 };

# ... and a further coredump variant - the fixup of the anon sub's
# CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to
# survive the outer eval also being freed.

$x = 123;
$a = eval q(
    eval q[
	sub { eval '$x' }
    ]
);
@a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs
test { $a->() == 123 };

# this coredumped on <= 5.8.0 because evaling the closure caused
# an SvFAKE to be added to the outer anon's pad, which was then grown.
my $outer;
sub {
    my $x;
    $x = eval 'sub { $outer }';
    $x->();
    $a = [ 99 ];
    $x->();
}->();
test {1};

# [perl #17605] found that an empty block called in scalar context
# can lead to stack corruption
{
    my $x = "foooobar";
    $x =~ s/o//eg;
    test { $x eq 'fbar' }
}

# DAPM 24-Nov-02
# SvFAKE lexicals should be visible thoughout a function.
# On <= 5.8.0, the third test failed,  eg bugid #18286

{
    my $x = 1;
    sub fake {
		test { sub {eval'$x'}->() == 1 };
	{ $x;	test { sub {eval'$x'}->() == 1 } }
		test { sub {eval'$x'}->() == 1 };
    }
}
fake();

# undefining a sub shouldn't alter visibility of outer lexicals

{
    $x = 1;
    my $x = 2;
    sub tmp { sub { eval '$x' } }
    my $a = tmp();
    undef &tmp;
    test { $a->() == 2 };
}

# handy class: $x = Watch->new(\$foo,'bar')
# causes 'bar' to be appended to $foo when $x is destroyed
sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }


# bugid 1028:
# nested anon subs (and associated lexicals) not freed early enough

sub linger {
    my $x = Watch->new($_[0], '2');
    sub {
	$x;
	my $y;
	sub { $y; };
    };
}
{
    my $watch = '1';
    linger(\$watch);
    test { $watch eq '12' }
}
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	#
a16a9fa3	7	# Run with -debug for debugging output.
0a753a76	8
f86702cc	9	BEGIN {
f86702cc	10	chdir 't' if -d 't';
20822f61	11	@INC = '../lib';
f86702cc	12	}
	13
	14	use Config;
	15
7dafbf52	16	print "1..181\n";
0a753a76	17
	18	my $test = 1;
	19	sub test (&) {
a16a9fa3	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;
0a753a76	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
3c1f3fdf	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
94f23f41	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
354992b1	178	{
	179	my $w;
	180	$w = sub {
	181	my ($i) = @_;
	182	test { $i == 10 };
	183	sub { $w };
	184	};
	185	$w->(10);
	186	}
94f23f41	187
0a753a76	188	# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
	189
	190	{
0a753a76	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
a16a9fa3	240	print <<"DEBUG_INFO" if $debugging;
a16a9fa3	241	# inner_type: $inner_type
0a753a76	242	# where_declared: $where_declared
a16a9fa3	243	# within: $within
	244	# nc_attempt: $nc_attempt
	245	# call_inner: $call_inner
	246	# call_outer: $call_outer
	247	# undef_outer: $undef_outer
0a753a76	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 (&) {
a16a9fa3	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;
0a753a76	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
2986a63f	435	if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
f86702cc	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', '-'
0a753a76	450	or die "Can't exec ./perl: $!";
f86702cc	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;
f86702cc	466	my $errfile = "terr$$"; $errfile++ while -e $errfile;
aa689395	467	my @tmpfiles = ($cmdfile, $errfile);
f86702cc	468	open CMD, ">$cmdfile"; print CMD $code; close CMD;
68dc0745	469	my $cmd = (($^O eq 'VMS') ? "MCR $^X"
68dc0745	470	: ($^O eq 'MSWin32') ? '.\perl'
95e8664e	471	: ($^O eq 'MacOS') ? $^X
2986a63f	472	: ($^O eq 'NetWare') ? 'perl'
68dc0745	473	: './perl');
aa689395	474	$cmd .= " -w $cmdfile 2>$errfile";
2986a63f	475	if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
aa689395	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	}
f86702cc	488	if ($?) {
f86702cc	489	printf "not ok: exited with error code %04X\n", $?;
aa689395	490	$debugging or do { 1 while unlink @tmpfiles };
f86702cc	491	exit;
f86702cc	492	}
aa689395	493	{ local $/; open IN, $errfile; $errors = <IN>; close IN }
aa689395	494	1 while unlink @tmpfiles;
0a753a76	495	}
f86702cc	496	print $output;
f86702cc	497	print STDERR $errors;
0a753a76	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	}
f86702cc	504	printf "not ok: exited with error code %04X\n", $? if $?;
a16a9fa3	505	print '#', "-" x 30, "\n" if $debugging;
0a753a76	506
	507	} # End of foreach $within
	508	} # End of foreach $where_declared
	509	} # End of foreach $inner_type
	510
	511	}
3c1f3fdf	512
7dafbf52	513	# The following dumps core with perl <= 5.8.0 (bugid 9535) ...
2f647fb2	514	BEGIN { $vanishing_pad = sub { eval $_[0] } }
	515	$some_var = 123;
	516	test { $vanishing_pad->( '$some_var' ) == 123 };
f3548bdc	517
7dafbf52	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
f3548bdc	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
e9f19e3c	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	}
ee6cee0c	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
7dafbf52	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	}