#!./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';
}
use Config;
print "1..187\n";
my $test = 1;
sub test (&) {
my $ok = &{$_[0]};
$test++;
}
my $i = 1;
# no closure
test { foo == 1 };
test { foo == 2 };
# closure: lexical outside sub
my $foo = sub {$i = shift if @_; $i };
my $bar = sub {$i = shift if @_; $i };
# did the lexical change?
# did the second closure notice?
# closure: lexical inside sub
sub bar {
my $i = shift;
sub { $i = shift if @_; $i }
}
# 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 };
}
}
my @foo;
my $i = $_;
$foo[$_] = sub {$i = shift if @_; $i };
}
test {
};
for (0 .. 4) {
}
test {
};
sub barf {
my @foo;
my $i = $_;
$foo[$_] = sub {$i = shift if @_; $i };
}
@foo;
}
test {
};
for (0 .. 4) {
}
test {
};
# test if closures get created in optimized for loops
my %foo;
for my $n ('A'..'E') {
}
test {
};
for my $n (0..4) {
$foo[$n] = sub { $n == $_[0] };
}
test {
&{$foo[4]}(4)
};
for my $n (0..4) {
$foo[$n] = sub {
# no intervening reference to $n here
sub { $n == $_[0] }
};
}
test {
};
{
my $w;
$w = sub {
my ($i) = @_;
test { $i == 10 };
sub { $w };
};
$w->(10);
}
# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
{
use strict;
# 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
# And it may be declared at filescope, within a named
# sub, or within an anon sub
# And that, in turn, may be within a foreach loop,
# a naked block, or another named sub
# Here are a number of variables which show what's
# going on, in a way.
$nc_attempt = 0+ # Named closure attempted
$call_inner = 0+ # Need to call &inner
$call_outer = 0+ # Need to call &outer or &$outer
$undef_outer = 0+ # $outer is created but unused
# 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
my \$msg = \$_[0];
print "not ok: got unexpected warning \$msg\\n";
} }
{
my \$test = $test;
sub test (&) {
my \$ok = &{\$_[0]};
\$test++;
}
}
# some of the variables which the closure will access
\$global_scalar = 1000;
%global_hash = 3000..3009;
my \$fs_scalar = 4000;
my %fs_hash = 6000..6009;
# Nothing here
sub outer {
my $sub_scalar = 7000;
my %sub_hash = 9000..9009;
# }
$outer = sub {
my $sub_scalar = 7000;
my %sub_hash = 9000..9009;
# }
} else {
die "What was $where_declared?"
}
$code .= "
my \$foreach = 12000;
my \@list = (10000, 10010);
foreach \$foreach (\@list) {
" # }
} else {
}
@inners = ( qw!global_scalar global_array global_hash! ,
}
} else {
die "What was $inner_type?"
}
# Now to write the body of the test sub
$code .= '{ ++$global_scalar }'
$code .= '{ ++$fs_scalar }'
$code .= '{ ++$sub_scalar }'
$code .= '{ ++$global_array[1] }'
$code .= '{ ++$fs_array[1] }'
$code .= '{ ++$sub_array[1] }'
$code .= '{ ++$global_hash{3002} }'
$code .= '{ ++$fs_hash{6002} }'
$code .= '{ ++$sub_hash{9002} }'
$code .= '{ ++$foreach }'
} else {
die "What was $inner_sub_test?"
}
# Close up
$code .= ';'
}
$sub_test++; # sub name sequence number
} # End of foreach $inner_sub_test
# Close up $within block # {
# Close up $where_declared block
}
# We may need to do something with the sub we just made...
$code .= "&\$outer;\n\n"
}
}
# Now, we can actually prep to run the tests.
# Named closures won't access the expected vars
if ( $nc_attempt and
$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.
#
$expected = 12001
} else {
$expected = 1
}
}
}
# Here's the test:
} else {
}
$test++;
}
# Fork off a new perl to run the tests.
# (This is so we can catch spurious warnings.)
$| = 1; print ""; $| = 0; # flush output before forking
# Child process here. We're going to send errors back
# through the extra pipe.
exec './perl', '-w', '-'
} else {
# Parent process here.
{ local $/;
}
} else {
# No fork(). Do it the hard way.
: './perl');
# 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.
} else {
}
if ($?) {
$debugging or do { 1 while unlink @tmpfiles };
exit;
}
}
print $output;
my $lnum = 0;
}
}
} # 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) ...
$some_var = 123;
# ... and here's another coredump variant - this time we explicitly
# delete the sub rather than using a BEGIN ...
*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;
}
# 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 };
}
}
# undefining a sub shouldn't alter visibility of outer lexicals
{
$x = 1;
my $x = 2;
test { $a->() == 2 };
}
# handy class: $x = Watch->new(\$foo,'bar')
# causes 'bar' to be appended to $foo when $x is destroyed
# bugid 1028:
# nested anon subs (and associated lexicals) not freed early enough
sub linger {
sub {
$x;
my $y;
sub { $y; };
};
}
{
}
# Because change #19637 was not applied to 5.8.1.
$test= 185;
{
# bugid #23265 - this used to coredump during destruction of PL_maincv
# and its children
print T << '__EOF__';
print
sub {$_[0]->(@_)} -> (
sub {
$_[1]
? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->()
: "y"
},
2
)
, "\n"
;
close T;
}
{
# bugid #24914 = used to coredump restoring PL_comppad in the
# savestack, due to the early freeing of the anon closure
'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(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;
{
my $x;
sub newsub {};
}
test { $flag == 1 };
}