develooper Front page | perl.perl5.porters | Postings from March 2003

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

Thread Previous | Thread Next
From:
Nicholas Clark
Date:
March 25, 2003 15:03
Subject:
[PATCH] Re: [perl #21614] 5.8.0 Unbalanced string table refcount
Message ID:
20030325225917.GE284@Bagpuss.unfortu.net
On Tue, Mar 25, 2003 at 09:06:08AM +0000, Nicholas Clark wrote:

> That's for copy on write? That's what I see for copy on write.
> IIRC it's a warning on 5.8.0, an assertion failure on maint, a SEGV on blead

er, I should be more careful. My copy of "maint" had 1 line added; an
assertion.

> Except that I'm trying to test that there's no warning issued for a known
> problem case. So I don't think that putting it in the warnings test is the
> right place.

I think that the appended works. The test fails on 5.8.0 and unpatched blead.
It passes on blead with and without COW. It doubt that the sv.c patch will
apply to maint because the code's been moved around quite a bit.

I'm not convinced that it's the cleanest logic yet. I think that it would
actually be better to move the sv_release_COW() call from
sv_force_normal_flags into sv_grow. (Which is actually back close to 5.8.0)
This way for this case sv_grow gets to call malloc once with the correct
size. Also it means that most third party XS code doesn't need to be aware
of copy on write - if it happens to call SvGROW to ensure that a buffer is
large enough before writing to it, then it would automatically do the
copy.

Nicholas Clark

--- t/op/readline.t.orig	Thu Mar 20 23:53:46 2003
+++ t/op/readline.t	Tue Mar 25 22:17:42 2003
@@ -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]');
@@ -17,4 +17,13 @@ like($@, 'Modification of a read-only va
   close A; $a = 4;
   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);
 }
--- ../s19055/sv.c	Wed Mar 12 12:11:43 2003
+++ sv.c	Tue Mar 25 22:16:49 2003
@@ -1585,8 +1585,15 @@ Perl_sv_grow(pTHX_ register SV *sv, regi
 	    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_ registe
 	    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)

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About