# 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..167\n";
+print "1..171\n";
my $test = 1;
sub test (&) {
- print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
+ my $ok = &{$_[0]};
+ print $ok ? "ok $test\n" : "not ok $test\n";
+ printf "# Failed at line %d\n", (caller)[2] unless $ok;
$test++;
}
&{$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>.
{
$code = "# This is a test script built by t/op/closure.t\n\n";
- $code .= <<"DEBUG_INFO" if $debugging;
-# inner_type: $inner_type
+ 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
+# within: $within
+# nc_attempt: $nc_attempt
+# call_inner: $call_inner
+# call_outer: $call_outer
+# undef_outer: $undef_outer
DEBUG_INFO
$code .= <<"END_MARK_ONE";
{
my \$test = $test;
sub test (&) {
- my \$result = &{\$_[0]};
- print "not " unless \$result;
- print "ok \$test\\n";
+ my \$ok = &{\$_[0]};
+ print \$ok ? "ok \$test\n" : "not ok \$test\n";
+ printf "# Failed at line %d\n", (caller)[2] unless \$ok;
\$test++;
}
}
$test++;
}
- if ($Config{d_fork} and $^O ne 'VMS') {
+ 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
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" : "./perl";
+ 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') {
+ 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.
}
}
printf "not ok: exited with error code %04X\n", $? if $?;
- print "-" x 30, "\n" if $debugging;
+ print '#', "-" x 30, "\n" if $debugging;
} # End of foreach $within
} # End of foreach $where_declared
} # End of foreach $inner_type
}
+