}
use Config;
+require './test.pl'; # for runperl()
-print "1..173\n";
+print "1..188\n";
my $test = 1;
sub test (&) {
$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!
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: $!";
+ exec which_perl(), '-w', '-'
+ or die "Can't exec perl: $!";
} else {
# Parent process here.
close WRITE;
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');
+ 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
}
-# The following dumps core with perl <= 5.8.0
+# 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;
}->();
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 };
+}
+
+
+
+
https://perl5.git.perl.org / perl5.git / blobdiff