closure.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
#!./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';
}
use Config;
print "1..171\n";
my $test = 1;
sub test (&) {
$test++;
}
my $i = 1;
sub foo { $i = shift if @_; $i }
# 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 \$result = &{\$_[0]};
print "ok \$test\\n";
\$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
}