Change 19071 by [EMAIL PROTECTED] on 2003/03/26 22:08:16
Better version of change #19069
Subject: [PATCH] Re: [PATCH] Re: [perl #21614] 5.8.0 Unbalanced string table
refcount
From: Nicholas Clark <[EMAIL PROTECTED]>
Date: Wed, 26 Mar 2003 23:01:46 +0000
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/pp_hot.c#310 edit
... //depot/perl/sv.c#646 edit
... //depot/perl/t/op/readline.t#4 edit
Differences ...
==== //depot/perl/pp_hot.c#310 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#309~19064~ Wed Mar 26 11:48:32 2003
+++ perl/pp_hot.c Wed Mar 26 14:08:16 2003
@@ -1509,7 +1509,7 @@
sv_unref(sv);
(void)SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen)
+ if (!tmplen && !SvREADONLY(sv))
Sv_Grow(sv, 80); /* try short-buffering it */
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
==== //depot/perl/sv.c#646 (text) ====
Index: perl/sv.c
--- perl/sv.c#645~19069~ Wed Mar 26 13:14:33 2003
+++ perl/sv.c Wed Mar 26 14:08:16 2003
@@ -1585,15 +1585,8 @@
newlen = 0xFFFF;
#endif
}
- else {
- /* This is annoying, because sv_force_normal_flags will fix the flags,
- recurse into sv_grow to malloc a buffer of SvCUR(sv) + 1, then
- return back to us, only for us to potentially realloc the buffer.
- */
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
+ else
s = SvPVX(sv);
- }
if (newlen > SvLEN(sv)) { /* need more room? */
if (SvLEN(sv) && s) {
@@ -6296,7 +6289,8 @@
I32 rspara = 0;
I32 recsize;
- SV_CHECK_THINKFIRST_COW_DROP(sv);
+ if (SvTHINKFIRST(sv))
+ sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
/* XXX. If you make this PVIV, then copy on write can copy scalars read
from <>.
However, perlbench says it's slower, because the existing swipe code
==== //depot/perl/t/op/readline.t#4 (text) ====
Index: perl/t/op/readline.t
--- perl/t/op/readline.t#3~19069~ Wed Mar 26 13:14:33 2003
+++ perl/t/op/readline.t Wed Mar 26 14:08:16 2003
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 5;
+plan tests => 11;
eval { for (\2) { $_ = <FH> } };
like($@, 'Modification of a read-only value attempted', '[perl #19566]');
@@ -27,3 +27,34 @@
);
is ($result, "end", '[perl #21614] for length ' . length $k);
}
+
+
+foreach my $k ('perl', 'perl'x21) {
+ my $result
+ = runperl (switches => '-l', stdin => ' rules', stderr => 1,
+ prog => "%a = qw($k v); foreach (keys %a) {\$_ .= <>; print}",
+ );
+ is ($result, "$k rules", 'rcatline to shared sv for length ' . length $k);
+}
+
+foreach my $l (1, 82) {
+ my $k = $l;
+ $k = 'k' x $k;
+ my $copy = $k;
+ $k = <DATA>;
+ is ($k, "moo\n", 'catline to COW sv for length ' . length $copy);
+}
+
+
+foreach my $l (1, 21) {
+ my $k = $l;
+ $k = 'perl' x $k;
+ my $perl = $k;
+ $k .= <DATA>;
+ is ($k, "$perl rules\n", 'rcatline to COW sv for length ' . length $perl);
+}
+__DATA__
+moo
+moo
+ rules
+ rules
End of Patch.
