Re: [perl #21614] 5.8.0 Unbalanced string table refcount

Message-ID: <20030325225917.GE284@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@19069

diff --git a/sv.c b/sv.c
index 4f6d59c..a1b44cf 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1585,8 +1585,15 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
            newlen = 0xFFFF;
 #endif
     }
-    else
+    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);
        s = SvPVX(sv);
+    }
 
     if (newlen > SvLEN(sv)) {          /* need more room? */
        if (SvLEN(sv) && s) {
@@ -4448,11 +4455,11 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
            char *pvx = SvPVX(sv);
            STRLEN len = SvCUR(sv);
             U32 hash   = SvUVX(sv);
+           SvFAKE_off(sv);
+           SvREADONLY_off(sv);
            SvGROW(sv, len + 1);
            Move(pvx,SvPVX(sv),len,char);
            *SvEND(sv) = '\0';
-           SvFAKE_off(sv);
-           SvREADONLY_off(sv);
            unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
        }
        else if (PL_curcop != &PL_compiling)

diff --git a/t/op/readline.t b/t/op/readline.t
index 1bc9ef4..8936022 100644 (file)
--- a/t/op/readline.t
+++ b/t/op/readline.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 3;
+plan tests => 5;
 
 eval { for (\2) { $_ = <FH> } };
 like($@, 'Modification of a read-only value attempted', '[perl #19566]');
@@ -18,3 +18,12 @@ like($@, 'Modification of a read-only value attempted', '[perl #19566]');
   is($a .= <A>, 4, '#21628 - $a .= <A> , A closed');
   unlink "a";
 }
+
+# 82 is chosen to exceed the length for sv_grow in do_readline (80)
+foreach my $k ('k', 'k'x82) {
+  my $result
+    = runperl (switches => '-l', stdin => '', stderr => 1,
+              prog => "%a = qw($k v); \$_ = <> foreach keys %a; print qw(end)",
+             );
+  is ($result, "end", '[perl #21614] for length ' . length $k);
+}