[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;
require './test.pl'; # for runperl()

print "1..188\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, 'is not available') != -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 which_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 = tempfile();
	    my $errfile = tempfile();
	    open CMD, ">$cmdfile"; print CMD $code; close CMD;
	    my $cmd = which_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 = tempfile();
	      system "$cmd >$outfile";
	      { local $/; open IN, $outfile; $output = <IN>; close IN }
	    }
	    if ($?) {
	      printf "not ok: exited with error code %04X\n", $?;
	      exit;
	    }
	    { local $/; open IN, $errfile; $errors = <IN>; close IN }
	  }
	  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' }
}

# bugid 10085
# obj not freed early enough

sub linger2 { 
    my $obj = Watch->new($_[0], '2');
    sub { sub { $obj } };
}   
{
    my $watch = '1';
    linger2(\$watch);
    test { $watch eq '12' }
}

# bugid 16302 - named subs didn't capture lexicals on behalf of inner subs

{
    my $x = 1;
    sub f16302 {
	sub {
	    test { defined $x and $x == 1 }
	}->();
    }
}
f16302();

# The presence of an eval should turn cloneless anon subs into clonable
# subs - otherwise the CvOUTSIDE of that sub may be wrong

{
    my %a;
    for my $x (7,11) {
	$a{$x} = sub { $x=$x; sub { eval '$x' } };
    }
    test { $a{7}->()->() + $a{11}->()->() == 18 };
}

{
   # bugid #23265 - this used to coredump during destruction of PL_maincv
   # and its children

    my $progfile = "b23265.pl";
    open(T, ">$progfile") or die "$0: $!\n";
    print T << '__EOF__';
        print
            sub {$_[0]->(@_)} -> (
                sub {
                    $_[1]
                        ?  $_[0]->($_[0], $_[1] - 1) .  sub {"x"}->()
                        : "y"
                },   
                2
            )
            , "\n"
        ;
__EOF__
    close T;
    my $got = runperl(progfile => $progfile);
    test { chomp $got; $got eq "yxx" };
    END { 1 while unlink $progfile }
}

{
    # bugid #24914 = used to coredump restoring PL_comppad in the
    # savestack, due to the early freeing of the anon closure

    my $got = runperl(stderr => 1, prog => 
'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)'
    );
    test { $got eq "ok\n" };
}

# After newsub is redefined outside the BEGIN, it's CvOUTSIDE should point
# to main rather than BEGIN, and BEGIN should be freed.

{
    my $flag = 0;
    sub  X::DESTROY { $flag = 1 }
    {
	my $x;
	BEGIN {$x = \&newsub }
	sub newsub {};
	$x = bless {}, 'X';
    }
    test { $flag == 1 };
}

# don't copy a stale lexical; crate a fresh undef one instead

sub f {
    my $x if $_[0];
    sub { \$x }
}

{
    f(1);
    my $c1= f(0);
    my $c2= f(0);

    my $r1 = $c1->();
    my $r2 = $c2->();
    test { $r1 != $r2 };
}
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;
c8d62b71	15	require './test.pl'; # for runperl()
f86702cc	16
33894c1a	17	print "1..188\n";
0a753a76	18
	19	my $test = 1;
	20	sub test (&) {
a16a9fa3	21	my $ok = &{$_[0]};
	22	print $ok ? "ok $test\n" : "not ok $test\n";
	23	printf "# Failed at line %d\n", (caller)[2] unless $ok;
0a753a76	24	$test++;
	25	}
	26
	27	my $i = 1;
	28	sub foo { $i = shift if @_; $i }
	29
	30	# no closure
	31	test { foo == 1 };
	32	foo(2);
	33	test { foo == 2 };
	34
	35	# closure: lexical outside sub
	36	my $foo = sub {$i = shift if @_; $i };
	37	my $bar = sub {$i = shift if @_; $i };
	38	test {&$foo() == 2 };
	39	&$foo(3);
	40	test {&$foo() == 3 };
	41	# did the lexical change?
	42	test { foo == 3 and $i == 3};
	43	# did the second closure notice?
	44	test {&$bar() == 3 };
	45
	46	# closure: lexical inside sub
	47	sub bar {
	48	my $i = shift;
	49	sub { $i = shift if @_; $i }
	50	}
	51
	52	$foo = bar(4);
	53	$bar = bar(5);
	54	test {&$foo() == 4 };
	55	&$foo(6);
	56	test {&$foo() == 6 };
	57	test {&$bar() == 5 };
	58
	59	# nested closures
	60	sub bizz {
	61	my $i = 7;
	62	if (@_) {
	63	my $i = shift;
	64	sub {$i = shift if @_; $i };
	65	} else {
	66	my $i = $i;
	67	sub {$i = shift if @_; $i };
	68	}
	69	}
	70	$foo = bizz();
	71	$bar = bizz();
	72	test {&$foo() == 7 };
	73	&$foo(8);
	74	test {&$foo() == 8 };
	75	test {&$bar() == 7 };
	76
	77	$foo = bizz(9);
	78	$bar = bizz(10);
	79	test {&$foo(11)-1 == &$bar()};
	80
	81	my @foo;
	82	for (qw(0 1 2 3 4)) {
	83	my $i = $_;
	84	$foo[$_] = sub {$i = shift if @_; $i };
	85	}
	86
	87	test {
88	&{$foo[0]}() == 0 and
89	&{$foo[1]}() == 1 and
90	&{$foo[2]}() == 2 and
91	&{$foo[3]}() == 3 and
92	&{$foo[4]}() == 4
93	};
94
95	for (0 .. 4) {
96	&{$foo[$_]}(4-$_);
97	}
98
99	test {
100	&{$foo[0]}() == 4 and
101	&{$foo[1]}() == 3 and
102	&{$foo[2]}() == 2 and
103	&{$foo[3]}() == 1 and
104	&{$foo[4]}() == 0
105	};
106
107	sub barf {
108	my @foo;
109	for (qw(0 1 2 3 4)) {
110	my $i = $_;
111	$foo[$_] = sub {$i = shift if @_; $i };
112	}
113	@foo;
114	}
115
116	@foo = barf();
117	test {
118	&{$foo[0]}() == 0 and
119	&{$foo[1]}() == 1 and
120	&{$foo[2]}() == 2 and
121	&{$foo[3]}() == 3 and
122	&{$foo[4]}() == 4
123	};
124
125	for (0 .. 4) {
126	&{$foo[$_]}(4-$_);
127	}
128
129	test {
130	&{$foo[0]}() == 4 and
131	&{$foo[1]}() == 3 and
132	&{$foo[2]}() == 2 and
133	&{$foo[3]}() == 1 and
134	&{$foo[4]}() == 0
135	};
136
3c1f3fdf	137	# test if closures get created in optimized for loops
	138
	139	my %foo;
	140	for my $n ('A'..'E') {
	141	$foo{$n} = sub { $n eq $_[0] };
	142	}
	143
	144	test {
	145	&{$foo{A}}('A') and
	146	&{$foo{B}}('B') and
	147	&{$foo{C}}('C') and
	148	&{$foo{D}}('D') and
	149	&{$foo{E}}('E')
	150	};
	151
	152	for my $n (0..4) {
	153	$foo[$n] = sub { $n == $_[0] };
	154	}
	155
	156	test {
	157	&{$foo[0]}(0) and
	158	&{$foo[1]}(1) and
	159	&{$foo[2]}(2) and
	160	&{$foo[3]}(3) and
	161	&{$foo[4]}(4)
	162	};
	163
94f23f41	164	for my $n (0..4) {
	165	$foo[$n] = sub {
	166	# no intervening reference to $n here
	167	sub { $n == $_[0] }
	168	};
	169	}
	170
	171	test {
	172	$foo[0]->()->(0) and
	173	$foo[1]->()->(1) and
	174	$foo[2]->()->(2) and
	175	$foo[3]->()->(3) and
	176	$foo[4]->()->(4)
	177	};
	178
354992b1	179	{
	180	my $w;
	181	$w = sub {
	182	my ($i) = @_;
	183	test { $i == 10 };
	184	sub { $w };
	185	};
	186	$w->(10);
	187	}
94f23f41	188
0a753a76	189	# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
	190
	191	{
0a753a76	192	use strict;
	193
	194	use vars qw!$test!;
	195	my($debugging, %expected, $inner_type, $where_declared, $within);
	196	my($nc_attempt, $call_outer, $call_inner, $undef_outer);
	197	my($code, $inner_sub_test, $expected, $line, $errors, $output);
	198	my(@inners, $sub_test, $pid);
	199	$debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
	200
	201	# The expected values for these tests
	202	%expected = (
	203	'global_scalar' => 1001,
	204	'global_array' => 2101,
	205	'global_hash' => 3004,
	206	'fs_scalar' => 4001,
	207	'fs_array' => 5101,
	208	'fs_hash' => 6004,
	209	'sub_scalar' => 7001,
	210	'sub_array' => 8101,
	211	'sub_hash' => 9004,
	212	'foreach' => 10011,
	213	);
	214
	215	# Our innermost sub is either named or anonymous
	216	for $inner_type (qw!named anon!) {
	217	# And it may be declared at filescope, within a named
	218	# sub, or within an anon sub
	219	for $where_declared (qw!filescope in_named in_anon!) {
	220	# And that, in turn, may be within a foreach loop,
	221	# a naked block, or another named sub
	222	for $within (qw!foreach naked other_sub!) {
	223
	224	# Here are a number of variables which show what's
	225	# going on, in a way.
	226	$nc_attempt = 0+ # Named closure attempted
	227	( ($inner_type eq 'named') \|\|
	228	($within eq 'other_sub') ) ;
	229	$call_inner = 0+ # Need to call &inner
	230	( ($inner_type eq 'anon') &&
	231	($within eq 'other_sub') ) ;
	232	$call_outer = 0+ # Need to call &outer or &$outer
	233	( ($inner_type eq 'anon') &&
	234	($within ne 'other_sub') ) ;
	235	$undef_outer = 0+ # $outer is created but unused
	236	( ($where_declared eq 'in_anon') &&
	237	(not $call_outer) ) ;
	238
	239	$code = "# This is a test script built by t/op/closure.t\n\n";
	240
a16a9fa3	241	print <<"DEBUG_INFO" if $debugging;
a16a9fa3	242	# inner_type: $inner_type
0a753a76	243	# where_declared: $where_declared
a16a9fa3	244	# within: $within
	245	# nc_attempt: $nc_attempt
	246	# call_inner: $call_inner
	247	# call_outer: $call_outer
	248	# undef_outer: $undef_outer
0a753a76	249	DEBUG_INFO
	250
	251	$code .= <<"END_MARK_ONE";
	252
	253	BEGIN { \$SIG{__WARN__} = sub {
	254	my \$msg = \$_[0];
	255	END_MARK_ONE
	256
	257	$code .= <<"END_MARK_TWO" if $nc_attempt;
	258	return if index(\$msg, 'will not stay shared') != -1;
b5c19bd7	259	return if index(\$msg, 'is not available') != -1;
0a753a76	260	END_MARK_TWO
	261
	262	$code .= <<"END_MARK_THREE"; # Backwhack a lot!
	263	print "not ok: got unexpected warning \$msg\\n";
	264	} }
	265
	266	{
	267	my \$test = $test;
	268	sub test (&) {
a16a9fa3	269	my \$ok = &{\$_[0]};
	270	print \$ok ? "ok \$test\n" : "not ok \$test\n";
	271	printf "# Failed at line %d\n", (caller)[2] unless \$ok;
0a753a76	272	\$test++;
	273	}
	274	}
	275
	276	# some of the variables which the closure will access
	277	\$global_scalar = 1000;
	278	\@global_array = (2000, 2100, 2200, 2300);
	279	%global_hash = 3000..3009;
	280
	281	my \$fs_scalar = 4000;
	282	my \@fs_array = (5000, 5100, 5200, 5300);
	283	my %fs_hash = 6000..6009;
	284
	285	END_MARK_THREE
	286
	287	if ($where_declared eq 'filescope') {
	288	# Nothing here
	289	} elsif ($where_declared eq 'in_named') {
	290	$code .= <<'END';
	291	sub outer {
	292	my $sub_scalar = 7000;
	293	my @sub_array = (8000, 8100, 8200, 8300);
	294	my %sub_hash = 9000..9009;
	295	END
	296	# }
	297	} elsif ($where_declared eq 'in_anon') {
	298	$code .= <<'END';
	299	$outer = sub {
	300	my $sub_scalar = 7000;
	301	my @sub_array = (8000, 8100, 8200, 8300);
	302	my %sub_hash = 9000..9009;
	303	END
	304	# }
	305	} else {
	306	die "What was $where_declared?"
	307	}
	308
	309	if ($within eq 'foreach') {
	310	$code .= "
	311	my \$foreach = 12000;
	312	my \@list = (10000, 10010);
	313	foreach \$foreach (\@list) {
	314	" # }
	315	} elsif ($within eq 'naked') {
	316	$code .= " { # naked block\n" # }
	317	} elsif ($within eq 'other_sub') {
	318	$code .= " sub inner_sub {\n" # }
	319	} else {
	320	die "What was $within?"
	321	}
	322
	323	$sub_test = $test;
	324	@inners = ( qw!global_scalar global_array global_hash! ,
	325	qw!fs_scalar fs_array fs_hash! );
	326	push @inners, 'foreach' if $within eq 'foreach';
	327	if ($where_declared ne 'filescope') {
	328	push @inners, qw!sub_scalar sub_array sub_hash!;
	329	}
	330	for $inner_sub_test (@inners) {
	331
	332	if ($inner_type eq 'named') {
	333	$code .= " sub named_$sub_test "
	334	} elsif ($inner_type eq 'anon') {
	335	$code .= " \$anon_$sub_test = sub "
336	} else {
337	die "What was $inner_type?"
338	}
339
340	# Now to write the body of the test sub
341	if ($inner_sub_test eq 'global_scalar') {
342	$code .= '{ ++$global_scalar }'
343	} elsif ($inner_sub_test eq 'fs_scalar') {
344	$code .= '{ ++$fs_scalar }'
345	} elsif ($inner_sub_test eq 'sub_scalar') {
346	$code .= '{ ++$sub_scalar }'
347	} elsif ($inner_sub_test eq 'global_array') {
348	$code .= '{ ++$global_array[1] }'
349	} elsif ($inner_sub_test eq 'fs_array') {
350	$code .= '{ ++$fs_array[1] }'
351	} elsif ($inner_sub_test eq 'sub_array') {
352	$code .= '{ ++$sub_array[1] }'
353	} elsif ($inner_sub_test eq 'global_hash') {
354	$code .= '{ ++$global_hash{3002} }'
355	} elsif ($inner_sub_test eq 'fs_hash') {
356	$code .= '{ ++$fs_hash{6002} }'
357	} elsif ($inner_sub_test eq 'sub_hash') {
358	$code .= '{ ++$sub_hash{9002} }'
359	} elsif ($inner_sub_test eq 'foreach') {
360	$code .= '{ ++$foreach }'
361	} else {
362	die "What was $inner_sub_test?"
363	}
364
365	# Close up
366	if ($inner_type eq 'anon') {
367	$code .= ';'
368	}
369	$code .= "\n";
370	$sub_test++; # sub name sequence number
371
372	} # End of foreach $inner_sub_test
373
374	# Close up $within block # {
375	$code .= " }\n\n";
376
377	# Close up $where_declared block
378	if ($where_declared eq 'in_named') { # {
379	$code .= "}\n\n";
380	} elsif ($where_declared eq 'in_anon') { # {
381	$code .= "};\n\n";
382	}
383
384	# We may need to do something with the sub we just made...
385	$code .= "undef \$outer;\n" if $undef_outer;
386	$code .= "&inner_sub;\n" if $call_inner;
387	if ($call_outer) {
388	if ($where_declared eq 'in_named') {
389	$code .= "&outer;\n\n";
390	} elsif ($where_declared eq 'in_anon') {
391	$code .= "&\$outer;\n\n"
392	}
393	}
394
395	# Now, we can actually prep to run the tests.
396	for $inner_sub_test (@inners) {
397	$expected = $expected{$inner_sub_test} or
398	die "expected $inner_sub_test missing";
399
400	# Named closures won't access the expected vars
401	if ( $nc_attempt and
402	substr($inner_sub_test, 0, 4) eq "sub_" ) {
403	$expected = 1;
404	}
405
406	# If you make a sub within a foreach loop,
407	# what happens if it tries to access the
408	# foreach index variable? If it's a named
409	# sub, it gets the var from "outside" the loop,
410	# but if it's anon, it gets the value to which
411	# the index variable is aliased.
412	#
413	# Of course, if the value was set only
414	# within another sub which was never called,
415	# the value has not been set yet.
416	#
417	if ($inner_sub_test eq 'foreach') {
418	if ($inner_type eq 'named') {
419	if ($call_outer \|\| ($where_declared eq 'filescope')) {
420	$expected = 12001
421	} else {
422	$expected = 1
423	}
424	}
425	}
426
427	# Here's the test:
428	if ($inner_type eq 'anon') {
429	$code .= "test { &\$anon_$test == $expected };\n"
430	} else {
431	$code .= "test { &named_$test == $expected };\n"
432	}
433	$test++;
434	}
435
2986a63f	436	if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
f86702cc	437	# Fork off a new perl to run the tests.
	438	# (This is so we can catch spurious warnings.)
	439	$\| = 1; print ""; $\| = 0; # flush output before forking
	440	pipe READ, WRITE or die "Can't make pipe: $!";
	441	pipe READ2, WRITE2 or die "Can't make second pipe: $!";
	442	die "Can't fork: $!" unless defined($pid = open PERL, "\|-");
	443	unless ($pid) {
	444	# Child process here. We're going to send errors back
	445	# through the extra pipe.
	446	close READ;
	447	close READ2;
	448	open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!";
	449	open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
c8d62b71	450	exec which_perl(), '-w', '-'
c8d62b71	451	or die "Can't exec perl: $!";
f86702cc	452	} else {
	453	# Parent process here.
	454	close WRITE;
	455	close WRITE2;
	456	print PERL $code;
	457	close PERL;
	458	{ local $/;
	459	$output = join '', <READ>;
	460	$errors = join '', <READ2>; }
	461	close READ;
	462	close READ2;
	463	}
	464	} else {
	465	# No fork(). Do it the hard way.
1c25d394	466	my $cmdfile = tempfile();
1c25d394	467	my $errfile = tempfile();
f86702cc	468	open CMD, ">$cmdfile"; print CMD $code; close CMD;
c8d62b71	469	my $cmd = which_perl();
aa689395	470	$cmd .= " -w $cmdfile 2>$errfile";
2986a63f	471	if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
aa689395	472	# Use pipe instead of system so we don't inherit STD* from
	473	# this process, and then foul our pipe back to parent by
	474	# redirecting output in the child.
	475	open PERL,"$cmd \|" or die "Can't open pipe: $!\n";
	476	{ local $/; $output = join '', <PERL> }
	477	close PERL;
	478	} else {
1c25d394	479	my $outfile = tempfile();
aa689395	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", $?;
f86702cc	485	exit;
f86702cc	486	}
aa689395	487	{ local $/; open IN, $errfile; $errors = <IN>; close IN }
0a753a76	488	}
f86702cc	489	print $output;
f86702cc	490	print STDERR $errors;
0a753a76	491	if ($debugging && ($errors \|\| $? \|\| ($output =~ /not ok/))) {
	492	my $lnum = 0;
	493	for $line (split '\n', $code) {
	494	printf "%3d: %s\n", ++$lnum, $line;
	495	}
	496	}
f86702cc	497	printf "not ok: exited with error code %04X\n", $? if $?;
a16a9fa3	498	print '#', "-" x 30, "\n" if $debugging;
0a753a76	499
	500	} # End of foreach $within
	501	} # End of foreach $where_declared
	502	} # End of foreach $inner_type
	503
	504	}
3c1f3fdf	505
7dafbf52	506	# The following dumps core with perl <= 5.8.0 (bugid 9535) ...
2f647fb2	507	BEGIN { $vanishing_pad = sub { eval $_[0] } }
	508	$some_var = 123;
	509	test { $vanishing_pad->( '$some_var' ) == 123 };
f3548bdc	510
7dafbf52	511	# ... and here's another coredump variant - this time we explicitly
	512	# delete the sub rather than using a BEGIN ...
	513
	514	sub deleteme { $a = sub { eval '$newvar' } }
	515	deleteme();
	516	*deleteme = sub {}; # delete the sub
	517	$newvar = 123; # realloc the SV of the freed CV
	518	test { $a->() == 123 };
	519
	520	# ... and a further coredump variant - the fixup of the anon sub's
	521	# CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to
	522	# survive the outer eval also being freed.
	523
	524	$x = 123;
	525	$a = eval q(
	526	eval q[
	527	sub { eval '$x' }
	528	]
	529	);
	530	@a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs
	531	test { $a->() == 123 };
	532
f3548bdc	533	# this coredumped on <= 5.8.0 because evaling the closure caused
	534	# an SvFAKE to be added to the outer anon's pad, which was then grown.
	535	my $outer;
	536	sub {
	537	my $x;
	538	$x = eval 'sub { $outer }';
	539	$x->();
	540	$a = [ 99 ];
	541	$x->();
	542	}->();
	543	test {1};
	544
e9f19e3c	545	# [perl #17605] found that an empty block called in scalar context
	546	# can lead to stack corruption
	547	{
	548	my $x = "foooobar";
	549	$x =~ s/o//eg;
	550	test { $x eq 'fbar' }
	551	}
ee6cee0c	552
	553	# DAPM 24-Nov-02
	554	# SvFAKE lexicals should be visible thoughout a function.
	555	# On <= 5.8.0, the third test failed, eg bugid #18286
	556
	557	{
	558	my $x = 1;
	559	sub fake {
	560	test { sub {eval'$x'}->() == 1 };
	561	{ $x; test { sub {eval'$x'}->() == 1 } }
	562	test { sub {eval'$x'}->() == 1 };
	563	}
	564	}
	565	fake();
	566
7dafbf52	567	# undefining a sub shouldn't alter visibility of outer lexicals
	568
	569	{
	570	$x = 1;
	571	my $x = 2;
	572	sub tmp { sub { eval '$x' } }
	573	my $a = tmp();
	574	undef &tmp;
	575	test { $a->() == 2 };
	576	}
	577
	578	# handy class: $x = Watch->new(\$foo,'bar')
	579	# causes 'bar' to be appended to $foo when $x is destroyed
	580	sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
	581	sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
	582
	583
	584	# bugid 1028:
	585	# nested anon subs (and associated lexicals) not freed early enough
	586
	587	sub linger {
	588	my $x = Watch->new($_[0], '2');
	589	sub {
	590	$x;
	591	my $y;
	592	sub { $y; };
	593	};
	594	}
	595	{
	596	my $watch = '1';
	597	linger(\$watch);
	598	test { $watch eq '12' }
	599	}
b5c19bd7	600
	601	# bugid 10085
	602	# obj not freed early enough
	603
	604	sub linger2 {
	605	my $obj = Watch->new($_[0], '2');
	606	sub { sub { $obj } };
	607	}
	608	{
	609	my $watch = '1';
	610	linger2(\$watch);
	611	test { $watch eq '12' }
	612	}
	613
	614	# bugid 16302 - named subs didn't capture lexicals on behalf of inner subs
	615
	616	{
	617	my $x = 1;
	618	sub f16302 {
	619	sub {
	620	test { defined $x and $x == 1 }
	621	}->();
	622	}
	623	}
	624	f16302();
	625
	626	# The presence of an eval should turn cloneless anon subs into clonable
	627	# subs - otherwise the CvOUTSIDE of that sub may be wrong
	628
	629	{
	630	my %a;
	631	for my $x (7,11) {
	632	$a{$x} = sub { $x=$x; sub { eval '$x' } };
	633	}
	634	test { $a{7}->()->() + $a{11}->()->() == 18 };
	635	}
	636
ed1af28e	637	{
	638	# bugid #23265 - this used to coredump during destruction of PL_maincv
	639	# and its children
	640
	641	my $progfile = "b23265.pl";
	642	open(T, ">$progfile") or die "$0: $!\n";
	643	print T << '__EOF__';
	644	print
	645	sub {$_[0]->(@_)} -> (
	646	sub {
	647	$_[1]
	648	? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->()
	649	: "y"
	650	},
	651	2
	652	)
	653	, "\n"
	654	;
	655	__EOF__
	656	close T;
	657	my $got = runperl(progfile => $progfile);
	658	test { chomp $got; $got eq "yxx" };
	659	END { 1 while unlink $progfile }
	660	}
	661
b36bdeca	662	{
	663	# bugid #24914 = used to coredump restoring PL_comppad in the
	664	# savestack, due to the early freeing of the anon closure
	665
	666	my $got = runperl(stderr => 1, prog =>
af6a4ad1	667	'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)'
b36bdeca	668	);
af6a4ad1	669	test { $got eq "ok\n" };
b36bdeca	670	}
b36bdeca	671
154b970c	672	# After newsub is redefined outside the BEGIN, it's CvOUTSIDE should point
	673	# to main rather than BEGIN, and BEGIN should be freed.
	674
	675	{
	676	my $flag = 0;
	677	sub X::DESTROY { $flag = 1 }
	678	{
	679	my $x;
	680	BEGIN {$x = \&newsub }
	681	sub newsub {};
	682	$x = bless {}, 'X';
	683	}
	684	test { $flag == 1 };
	685	}
	686
33894c1a	687	# don't copy a stale lexical; crate a fresh undef one instead
154b970c	688
33894c1a	689	sub f {
	690	my $x if $_[0];
	691	sub { \$x }
	692	}
	693
	694	{
	695	f(1);
	696	my $c1= f(0);
	697	my $c2= f(0);
	698
	699	my $r1 = $c1->();
	700	my $r2 = $c2->();
	701	test { $r1 != $r2 };
	702	}
154b970c	703
b36bdeca	704
b36bdeca	705
b5c19bd7	706