# 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.
-print "1..167\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
+print "1..185\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>.
{
- BEGIN {
- if (-d 't') {
- unshift @INC, "lib"
- } else {
- unshift @INC, '../lib'
- }
- }
use strict;
use vars qw!$test!;
$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";
$code .= <<"END_MARK_TWO" if $nc_attempt;
return if index(\$msg, 'will not stay shared') != -1;
- return if index(\$msg, 'may be unavailable') != -1;
+ return if index(\$msg, 'is not available') != -1;
END_MARK_TWO
$code .= <<"END_MARK_THREE"; # Backwhack a lot!
{
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++;
}
- # 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', '-'
+ 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;
}
- # Parent process here.
- close WRITE;
- close WRITE2;
- print PERL $code;
- close PERL;
- $output = join '', <READ>;
- $errors = join '', <READ2>;
- print $output, $errors;
+ 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 %04lX\n",$? if $?;
- print "-" x 30, $/ if $debugging;
+ 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 };
+}
+
+require './test.pl'; # for runperl()
+
+{
+ # 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 }
+}
+
+
https://perl5.git.perl.org / perl5.git / blobdiff