Change 19850 by [EMAIL PROTECTED] on 2003/06/24 18:49:22
Integrate:
[ 18557]
Subject: [PATCH] Re: [perl #9394] Re: [ID 20020525.002] coredump/ bad free
warning in blead with SIGWARN
From: Nicholas Clark <[EMAIL PROTECTED]>
Date: Tue, 21 Jan 2003 22:27:21 +0000
Message-ID: <[EMAIL PROTECTED]>
[ 19277]
Fix bug #21347 (segfault in UNIVERSAL::AUTOLOAD with qr//)
by adding a dummy destructor method Regexp::DESTROY.
This prevents infinite recursion, since Regexp::DESTROY
is no more autoloaded.
Subject: Re: [perl #21347] segfault in UNIVERSAL::AUTOLOAD
From: Enache Adrian <[EMAIL PROTECTED]>
Date: Wed, 2 Apr 2003 05:02:42 +0300
Message-ID: <[EMAIL PROTECTED]>
[ 19300]
Fix another segfault case (warn called from UNIVERSAL::DESTROY).
Subject: Re: [perl #21347] segfault in UNIVERSAL::AUTOLOAD
From: Enache Adrian <[EMAIL PROTECTED]>
Date: Sun, 20 Apr 2003 02:45:48 +0300
Message-ID: <[EMAIL PROTECTED]>
and
Date: Wed, 2 Apr 2003 07:52:28 +0300
Message-ID: <[EMAIL PROTECTED]>
[ 19729]
Subject: [PATCH] Re: nitpick with \(0..2)
From: Steve Grazzini <[EMAIL PROTECTED]>
Date: Fri, 6 Jun 2003 01:42:59 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 19845]
Test tweaks for VMS from Craig Berry.
[ 19846]
Subject: [perlport.pod] code point of \cU
From: SADAHIRO Tomoyuki <[EMAIL PROTECTED]>
Date: Tue, 24 Jun 2003 01:00:16 +0900
Message-Id: <[EMAIL PROTECTED]>
[ 19848]
Subject: [PATCH] lib/Perldoc.pm patch for Cygwin Bleadperl
From: "Gerrit P. Haase" <[EMAIL PROTECTED]>
Date: Tue, 24 Jun 2003 11:00:34 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 19849]
Subject: [PATCH] Re: [perl #22719] ISA cache problem with blessed stash objects
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Tue, 24 Jun 2003 13:16:18 +0100
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.8/perl/ext/B/t/stash.t#2 integrate
... //depot/maint-5.8/perl/lib/Pod/Perldoc.pm#7 integrate
... //depot/maint-5.8/perl/lib/strict.t#4 integrate
... //depot/maint-5.8/perl/lib/warnings.t#3 integrate
... //depot/maint-5.8/perl/pod/perlport.pod#9 integrate
... //depot/maint-5.8/perl/pp_sys.c#25 integrate
... //depot/maint-5.8/perl/sv.c#54 integrate
... //depot/maint-5.8/perl/t/op/ref.t#4 integrate
... //depot/maint-5.8/perl/universal.c#11 integrate
... //depot/maint-5.8/perl/util.c#24 integrate
Differences ...
==== //depot/maint-5.8/perl/ext/B/t/stash.t#2 (xtext) ====
Index: perl/ext/B/t/stash.t
--- perl/ext/B/t/stash.t#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/ext/B/t/stash.t Tue Jun 24 11:49:22 2003
@@ -66,7 +66,7 @@
$got = "@got";
-my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy Internals
main utf8 warnings";
+my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy Internals
main Regexp utf8 warnings";
{
no strict 'vars';
==== //depot/maint-5.8/perl/lib/Pod/Perldoc.pm#7 (text) ====
Index: perl/lib/Pod/Perldoc.pm
--- perl/lib/Pod/Perldoc.pm#6~18978~ Fri Mar 14 02:52:06 2003
+++ perl/lib/Pod/Perldoc.pm Tue Jun 24 11:49:22 2003
@@ -44,6 +44,7 @@
*IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
*IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
*IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
+ *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
}
$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
@@ -358,7 +359,7 @@
$self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
$self->opt_o_with('text');
- $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
+ $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos || IS_Cygwin
|| !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i);
return;
==== //depot/maint-5.8/perl/lib/strict.t#4 (text) ====
Index: perl/lib/strict.t
--- perl/lib/strict.t#3~18082~ Sun Nov 3 21:38:52 2002
+++ perl/lib/strict.t Tue Jun 24 11:49:22 2003
@@ -36,7 +36,7 @@
undef $/;
-print "1..", @prgs + 4, "\n";
+print "1.." . (@prgs + 4) . "\n";
for (@prgs){
@@ -94,7 +94,7 @@
print STDERR "GOT:\n$results\n";
print "not ";
}
- print "ok ", ++$i, "\n";
+ print "ok " . ++$i . "\n";
foreach (@temps)
{ unlink $_ if $_ }
}
==== //depot/maint-5.8/perl/lib/warnings.t#3 (text) ====
Index: perl/lib/warnings.t
--- perl/lib/warnings.t#2~18080~ Sun Nov 3 21:23:04 2002
+++ perl/lib/warnings.t Tue Jun 24 11:49:22 2003
@@ -59,7 +59,7 @@
undef $/;
-print "1..", scalar(@prgs)-$files, "\n";
+print "1.." . (scalar(@prgs)-$files) . "\n";
for (@prgs){
@@ -182,7 +182,7 @@
print STDERR "GOT:\n$results\n";
print "not ";
}
- print "ok ", ++$i, "\n";
+ print "ok " . ++$i . "\n";
foreach (@temps)
{ unlink $_ if $_ }
foreach (@temp_path)
==== //depot/maint-5.8/perl/pod/perlport.pod#9 (text) ====
Index: perl/pod/perlport.pod
--- perl/pod/perlport.pod#8~19653~ Sun Jun 1 00:35:55 2003
+++ perl/pod/perlport.pod Tue Jun 24 11:49:22 2003
@@ -192,8 +192,8 @@
such as z/OS (OS/390) or OS/400 (using the ILE, the PASE is ASCII-based)
the above material is similar to "Unix" but the code numbers change:
- LF eq \025 eq \x15 eq chr(21) eq CP-1047 21
- LF eq \045 eq \x25 eq \cU eq chr(37) eq CP-0037 37
+ LF eq \025 eq \x15 eq \cU eq chr(21) eq CP-1047 21
+ LF eq \045 eq \x25 eq chr(37) eq CP-0037 37
CR eq \015 eq \x0D eq \cM eq chr(13) eq CP-1047 13
CR eq \015 eq \x0D eq \cM eq chr(13) eq CP-0037 13
==== //depot/maint-5.8/perl/pp_sys.c#25 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c#24~19844~ Sun Jun 22 12:38:58 2003
+++ perl/pp_sys.c Tue Jun 24 11:49:22 2003
@@ -423,7 +423,7 @@
tmpsv = TOPs;
}
tmps = SvPV(tmpsv, len);
- if (!tmps || !len) {
+ if ((!tmps || !len) && PL_errgv) {
SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
==== //depot/maint-5.8/perl/sv.c#54 (text) ====
Index: perl/sv.c
--- perl/sv.c#53~19844~ Sun Jun 22 12:38:58 2003
+++ perl/sv.c Tue Jun 24 11:49:22 2003
@@ -3677,7 +3677,7 @@
if (dtype < SVt_RV)
sv_upgrade(dstr, SVt_RV);
else if (dtype == SVt_PVGV &&
- SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
sstr = SvRV(sstr);
if (sstr == dstr) {
if (GvIMPORTED(dstr) != GVf_IMPORTED
@@ -7837,7 +7837,9 @@
}
SvRV(sv) = 0;
SvROK_off(sv);
- if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
+ /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
+ assigned to as BEGIN {$a = \"Foo"} will fail. */
+ if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
SvREFCNT_dec(rv);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
sv_2mortal(rv); /* Schedule for freeing later */
==== //depot/maint-5.8/perl/t/op/ref.t#4 (xtext) ====
Index: perl/t/op/ref.t
--- perl/t/op/ref.t#3~19732~ Mon Jun 9 13:52:02 2003
+++ perl/t/op/ref.t Tue Jun 24 11:49:22 2003
@@ -5,7 +5,7 @@
@INC = qw(. ../lib);
}
-print "1..63\n";
+print "1..68\n";
require 'test.pl';
@@ -296,32 +296,71 @@
print "not " unless $a == 2;
print "ok 55\n";
-sub x::DESTROY {print "ok ", 55 + shift->[0], "\n"}
-{ my $a1 = bless [4],"x";
- my $a2 = bless [3],"x";
- { my $a3 = bless [2],"x";
- my $a4 = bless [1],"x";
- 567;
+# This test used to coredump. The BEGIN block is important as it causes the
+# op that created the constant reference to be freed. Hence the only
+# reference to the constant string "pass" is in $a. The hack that made
+# sure $a = $a->[1] would work didn't work with references to constants.
+
+my $test = 56;
+
+foreach my $lexical ('', 'my $a; ') {
+ my $expect = "pass\n";
+ my $result = runperl (switches => ['-wl'], stderr => 1,
+ prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
+
+ if ($? == 0 and $result eq $expect) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test # \$? = $?\n";
+ print "# expected ", _qq ($expect), ", got ", _qq ($result), "\n";
}
+ $test++;
}
+sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
+{ my $a1 = bless [3],"x";
+ my $a2 = bless [2],"x";
+ { my $a3 = bless [1],"x";
+ my $a4 = bless [0],"x";
+ 567;
+ }
+}
+$test+=4;
my $result = runperl (switches=>['-l'],
prog=> 'print 1; print qq-*$\*-;print 1;');
my $expect = "1\n*\n*\n1\n";
if ($result eq $expect) {
- print "ok 60\n";
+ print "ok $test\n";
} else {
- print "not ok 60\n";
+ print "not ok $test\n";
foreach ($expect, $result) {
s/\n/\\n/gs;
}
print "# expected \"$expect\", got \"$result\"\n";
}
+# bug #21347
+
+runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
+if ($? != 0) { print "not " };
+print "ok ",++$test," - UNIVERSAL::AUTOLOAD called when freeing qr//\n";
+
+runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
+if ($? != 0) { print "not " };
+print "ok ",++$test," - warn called inside UNIVERSAL::DESTROY\n";
+
+
+# bug #22719
+
+runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
+if ($? != 0) { print "not " };
+print "ok ",++$test," - coredump on typeglob = (SvRV && !SvROK)\n";
+
+
# test global destruction
-my $test = 61;
+++$test;
my $test1 = $test + 1;
my $test2 = $test + 2;
==== //depot/maint-5.8/perl/universal.c#11 (text) ====
Index: perl/universal.c
--- perl/universal.c#10~19791~ Sun Jun 15 10:57:06 2003
+++ perl/universal.c Tue Jun 24 11:49:22 2003
@@ -177,6 +177,7 @@
XS(XS_Internals_SvREFCNT);
XS(XS_Internals_hv_clear_placehold);
XS(XS_PerlIO_get_layers);
+XS(XS_Regexp_DESTROY);
void
Perl_boot_core_UNIVERSAL(pTHX)
@@ -200,6 +201,7 @@
XS_Internals_hv_clear_placehold, file, "\\%");
newXSproto("PerlIO::get_layers",
XS_PerlIO_get_layers, file, "*;@");
+ newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
}
@@ -580,6 +582,11 @@
}
XSRETURN(0);
+}
+
+XS(XS_Regexp_DESTROY)
+{
+
}
XS(XS_PerlIO_get_layers)
End of Patch.
