5.8.0 Unbalanced string table refcount #6387

p5pRT · 2003-03-19T03:57:20Z

Migrated from rt.perl.org#21614 (status was 'resolved')

Searchable as RT21614$

p5pRT · 2003-03-19T03:57:20Z

From Paul@dyerhouse.com

Hi,

This happened on Perl 5.8.0, RedHat 8.0. Here is a code fragment that
produces the error listed below it:

use IO::File ();
local $/;

foreach (sort keys %altnames) {
my $fh = IO::File->new;
my ($hr_title) = m/(.*)\.txt/;
print("<hr> <h1 align=center> $hr_title </h1>\n");
my $source = join '/', $dir, $_;
$fh->open($source);
while (<$fh>) {
print($_);
}
$fh->close;
}

I have found that I get the error even for one loop. I inserted "last;"
just after the close to test.

If I comment the print($_) statement, I still get the error.

If I comment the "while (<$fh>)" loop entirely, the errors go away!!

Here is the error log:

Unbalanced string table refcount: (1) for "Oracle.txt" during global destruction.

I was able to correct the error by using a lexical variable in the outer
loop, thus avoiding the $_ variable at 2 levels.

my $fh = IO::File->new;

foreach* my $file* (sort keys %altnames) { # insert each file into
an IMG tag
my ($hr_title) = ( $file =~ m/(.*)\.txt/ );
print "<hr><h1 align=center> $hr_title </h1>\n";
unless ($fh->open("$dir/$file")) {
$r->log_error("Couldn't open $dir/$file for reading: $!");
return SERVER_ERROR;
}
while (<$fh>) { # read the text files with IMG tags.
print;
}
$fh->close;
}

p5pRT · 2003-03-20T22:04:20Z

From @rgs

Paul Dyer (via RT) wrote:

This happened on Perl 5.8.0, RedHat 8.0. Here is a code fragment that
produces the error listed below it:

I can't reproduce this. Is your code fragment sufficient ? I don't
see a definition of %altnames.

There have been reports of problems due to UTF8 locales, notably under
RedHat 8.0. What's your locale ? Does the problem run away when you
run your script under the C locale ?

p5pRT · 2003-03-21T12:31:30Z

From Paul@dyerhouse.com

Rafael Garcia-Suarez (via RT) wrote:

Paul Dyer (via RT) wrote:

This happened on Perl 5.8.0, RedHat 8.0. Here is a code fragment that
produces the error listed below it:

I can't reproduce this. Is your code fragment sufficient ? I don't
see a definition of %altnames.

There have been reports of problems due to UTF8 locales, notably under
RedHat 8.0. What's your locale ? Does the problem run away when you
run your script under the C locale ?

Hi,

I'm attaching the whole script. I am running under Apache, ModPerl.
I used the Apache::File and IO::File modules and got the errors on both.

I am using RedHat 8.0 and 7.3 with the same results. I don't know what
the character set is.

Paul

p5pRT · 2003-03-21T12:31:30Z

From Paul@dyerhouse.com

package MyApache::BookPicture;
# ~www/lib/perl/MyApache/BookPicture.pm

use strict;
use warnings;
use Apache::Constants qw(:common);
use DirHandle ();
use Apache::File ();

sub handler {
my $r = shift;

my $dir_uri = $r->dir_config('PictureDir');
unless ($dir_uri) {
$r->log_reason("No PictureDir configured");
return SERVER_ERROR;
}
$dir_uri .= "/" unless $dir_uri =~ m:/$:;

my $subr = $r->lookup_uri($dir_uri);
my $dir = $subr->filename;
# Get list of images in the directory.
my $dh = DirHandle->new($dir);
unless ($dh) {
$r->log_error("Can't read directory $dir: $!");
return SERVER_ERROR;
}

my @files;
my %altnames;
for my $entry ($dh->read) {
# get the file's MIME type
my $rr = $subr->lookup_uri($entry);
my $type = $rr->content_type;
next unless $type and $type =~ m:^text/:;
push @files, $rr->uri;
$altnames{$entry} = $rr->uri;
}
$dh->close;
unless (@files) {
$r->log_error("No image files in directory");
return SERVER_ERROR;
}

$r->content_type('text/html');
$r->send_http_header;
return OK if $r->header_only;

print(<<END);
<HTML>
<HEAD>
<TITLE>books</TITLE>
<STYLE type="text/css">
BODY { background-color: orange }
</STYLE>
</HEAD>
<BODY>

END

my $fh;
foreach (sort keys %altnames) { # insert each file into an IMG tag
my ($hr_title) = m/(.*)\.txt/;
print("<hr><h1 align=center> $hr_title </h1>\n");
my $source = join '/', $dir, $_;
unless ($fh = Apache::File->new($source)) {
$r->log_error("Couldn't open $source for reading: $!");
return SERVER_ERROR;
}
while (<$fh>) { # read the text files with IMG tags.
print ;
}
close $fh;
}
print("");
print('</BODY></HTML>');

return OK;
}

1;
__END__

p5pRT · 2003-03-21T16:55:23Z

From @rgs

Paul Dyer wrote:

I'm attaching the whole script. I am running under Apache, ModPerl.

It's possible that it's a mod_perl problem. The startup/shutdown process of
mod_perl is more complicated than for a standalone perl interpreter.

It's possible also that the problem is not related at all to mod_perl, but
in this case, to fix it, it would be handy to be able to replicate it without
mod_perl.

Anyway, the error you're getting is an (undocumented) internal warning
that occurs on destruction of a perl interpreter. It's probably harmless.

I used the Apache::File and IO::File modules and got the errors on both.

I am using RedHat 8.0 and 7.3 with the same results. I don't know what
the character set is.

The output of the locale command is usually sufficient.

p5pRT · 2003-03-22T17:31:23Z

From @nwc10

On Wed, Mar 19, 2003 at 03:57:21AM -0000, Paul Dyer wrote:

Here is the error log:

Unbalanced string table refcount: (1) for "Oracle.txt" during global destruction.

On Fri, Mar 21, 2003 at 05:52:49PM +0100, Rafael Garcia-Suarez wrote:

Paul Dyer wrote:

I'm attaching the whole script. I am running under Apache, ModPerl.

It's possible that it's a mod_perl problem. The startup/shutdown process of
mod_perl is more complicated than for a standalone perl interpreter.

It's possible also that the problem is not related at all to mod_perl, but
in this case, to fix it, it would be handy to be able to replicate it without
mod_perl.

I'll second that. I can't replicate it here with pure perl - I don't have
modperl or a UTF8 locale.

Anyway, the error you're getting is an (undocumented) internal warning
that occurs on destruction of a perl interpreter. It's probably harmless.

I'm surprised that there is only 1 error line. I thought that unbalanced string
table refcounts usually came in pairs - one was too high, and another was too
low. (effectively a matched set).
I wonder if something in the internals is clearing all the flags in $_ at some
point, rather than correctly undef()ing it. In 5.8 keys will generate a list of
scalars which point directly to the string table used for hash keys
(this is the table that the error message refers to)
In turn, foreach aliases $_ to the items in the list, so $_ is pointing into
the string table. If the internals clear $_ properly, then the string table
reference is tidied up, and everything balances. But if something (I'm
suspicious of the inner foreach) just blasts $_ instead, then the reference
is lost.

I used the Apache::File and IO::File modules and got the errors on both.

I am using RedHat 8.0 and 7.3 with the same results. I don't know what
the character set is.

The output of the locale command is usually sufficient.

the output from perl -V would contain it. (plus a lot of other information)

If you're able to make a test case that doesn't need mod_perl that would be
really useful. I think that the string table reference counts are only checked
on perl compiled with -DDEBUGGING. I presume that the perl you have is, given
that mod_perl is warning. You can check - this perl is suitable:

$ perl5.8.0-32-g -D -e0

EXECUTING...

This perl is not:

$ perl5.8.0 -D -e0
Recompile perl with -DDEBUGGING to use -D switch

Nicholas Clark

p5pRT · 2003-03-23T18:04:58Z

From @nwc10

OK. My suspicions were wrong, in that it's not a UTF8 local issue.
Also I was wrong in my understanding of the string table - the string table
warning occurs independent of -DDEBUGGING

On Sat, Mar 22, 2003 at 10:16:17PM -0600, Paul Dyer wrote:

Here is some feedback, but not yet a test case w/o modperl:

locale
LANG=en_US
LC_CTYPE="en_US"
LC_NUMERIC="en_US"
LC_TIME="en_US"
LC_COLLATE="en_US"
LC_MONETARY="en_US"
LC_MESSAGES="en_US"
LC_PAPER="en_US"
LC_NAME="en_US"
LC_ADDRESS="en_US"
LC_TELEPHONE="en_US"
LC_MEASUREMENT="en_US"
LC_IDENTIFICATION="en_US"
LC_ALL=

perl -D -e0
Recompile perl with -DDEBUGGING to use -D switch

On Sat, Mar 22, 2003 at 10:45:01PM -0600, Paul Dyer wrote:

I am attaching an attempt to reproduce the error w/o modperl. I used
almost the same code, removing all the apache stuff. Sorry, but I don't
get the error. I checked my httpd compile. On this machine, RedHat 8.0,
mod_perl.c is static. On the other RedHat machine, mod_perl.c is a dso
and the character set is en_US.iso885915.
Paul

#!/usr/local/bin/perl -w
# ~www/lib/perl/MyApache/BookPicture.pm

use strict;
use warnings;
use DirHandle ();
use IO::File ();

my $r = shift;

my $dir = "/usr/local/apache/htdocs/mercury/pictures/Books";

\# Get list of images in the directory\.
my $dh = DirHandle\->new\($dir\);
unless \($dh\) \{
print\("Can't read directory $dir&#8203;: $\!"\);
exit 0;
\}

my @&#8203;files;
my %altnames;
for my $entry \($dh\->read\) \{
    next unless \( $entry =~ m/\(\.\*\)\\\.txt/ \);
push @&#8203;files\, $entry;
$altnames\{$entry\} = $entry;
\}
$dh\->close;
unless \(@&#8203;files\) \{
print\("No image files in directory"\);
exit 0;
\}

my $fh;
foreach \(sort keys %altnames\) \{ \# insert each file into an IMG tag
  my \($hr\_title\) = m/\(\.\*\)\\\.txt/;
  print\("\<hr>\<h1 align=center> $hr\_title \</h1>\\n"\);
  my $source = join '/'\, $dir\, $\_;
  unless \($fh = IO&#8203;::File\->new\($source\)\) \{
     print\("Couldn't open $source for reading&#8203;: $\!"\);
     exit 0;
     \}
  while \(\<$fh>\) \{ \# read the text files with IMG tags\.
      print ;
      \}
  close $fh;
  \}
print\("\<\!\-\-\#FOOTER \-\->"\);
print\('\</BODY>\</HTML>'\);

exit 1;

When I run that test code under valgrind (on x86 Debian), with $dir changed
to a directory containing 1 file, Oracle.txt, with 1 line "Hello World" I
see memory access errors:

$ valgrind ./perl -I lib BookPicture.pl
==22221== valgrind-1.0.4, a memory error detector for x86 GNU/Linux.
==22221== Copyright (C) 2000-2002, and GNU GPL'd, by Julian Seward.
==22221== Estimated CPU clock rate is 262 MHz
==22221== For more details, rerun with: -v
==22221==
==22221== Invalid read of size 4
==22221== at 0x808CE25: Perl_pad_allocmy (/home/nick/5.8.0-i-g/op.c:217)
==22221== by 0x807FF08: S_pending_ident (/home/nick/5.8.0-i-g/toke.c:5224)
==22221== by 0x80716CB: Perl_yylex (/home/nick/5.8.0-i-g/toke.c:2201)
==22221== by 0x80894E9: Perl_yyparse (/home/nick/5.8.0-i-g/perly.c:1470)
==22221== Address 0x40BFC510 is 0 bytes after a block of size 1008 alloc'd
==22221== at 0x4003D78E: malloc (vg_clientfuncs.c:100)
==22221== by 0x80B80C8: Perl_safesysmalloc (/home/nick/5.8.0-i-g/util.c:78)
==22221== by 0x80DD3F7: S_more_xpv (/home/nick/5.8.0-i-g/sv.c:740)
==22221== by 0x80DD32D: S_new_xpv (/home/nick/5.8.0-i-g/sv.c:715)
==22221==
==22221== Invalid read of size 4
==22221== at 0x808CE33: Perl_pad_allocmy (/home/nick/5.8.0-i-g/op.c:217)
==22221== by 0x807FF08: S_pending_ident (/home/nick/5.8.0-i-g/toke.c:5224)
==22221== by 0x80716CB: Perl_yylex (/home/nick/5.8.0-i-g/toke.c:2201)
==22221== by 0x80894E9: Perl_yyparse (/home/nick/5.8.0-i-g/perly.c:1470)
==22221== Address 0x40BFC510 is 0 bytes after a block of size 1008 alloc'd
==22221== at 0x4003D78E: malloc (vg_clientfuncs.c:100)
==22221== by 0x80B80C8: Perl_safesysmalloc (/home/nick/5.8.0-i-g/util.c:78)
==22221== by 0x80DD3F7: S_more_xpv (/home/nick/5.8.0-i-g/sv.c:740)
==22221== by 0x80DD32D: S_new_xpv (/home/nick/5.8.0-i-g/sv.c:715)
==22221==
==22221== pthread_mutex_destroy: mutex is still in use
==22221== at 0x40273C90: pthread_error (vg_libpthread.c:275)
==22221== by 0x40274BB4: __pthread_mutex_destroy (vg_libpthread.c:952)
==22221== by 0x403202E9: (within /lib/libc-2.3.1.so)
==22221== by 0x81266C6: Perl_pp_closedir (/home/nick/5.8.0-i-g/pp_sys.c:3925)
<hr><h1 align=center> Oracle </h1>
Hello World
valgrind's libpthread.so: KLUDGED call to: siglongjmp (cleanup handlers are ignored)
valgrind's libpthread.so: KLUDGED call to: pthread_cond_destroy
</BODY></HTML>==22221==
==22221== ERROR SUMMARY: 9 errors from 3 contexts (suppressed: 0 from 0)
==22221== malloc/free: in use at exit: 582286 bytes in 12712 blocks.
==22221== malloc/free: 23363 allocs, 10651 frees, 1128739 bytes allocated.
==22221== For a detailed leak analysis, rerun with: --leak-check=yes
==22221== For counts of detected errors, rerun with: -v

Running with maintperl (5.8.1 to be) or bleadperl (the current development
snapshot) valgrind reports no memory errors. So there does seem to be a bug
in 5.8.0, and it seems to have been fixed for 5.8.1
However, I can't be sure if this illegal memory access is actually the
same bug as you're seeing. I'm a bit confused by all this, because valgrind
seems to be reporting errors in the pad code, and pads have been substantially
reworked for bleadperl, but not maintperl. Hence I'm surprised that the bug
seems to be fixed in both branches, given that the implementation differs.

I don't know if it's possible to run mod_perl under valgrind, to see if these
memory errors correlate with what you see there.

Nicholas Clark

p5pRT · 2003-03-23T21:12:15Z

From @rgs

Nicholas Clark wrote:

I don't know if it's possible to run mod_perl under valgrind, to see if these
memory errors correlate with what you see there.

Run apache in single process mode :

$ valgrind httpd -X

p5pRT · 2003-03-23T21:51:29Z

From @nwc10

On Sun, Mar 23, 2003 at 05:59:59PM +0000, Nicholas Clark wrote:

OK. My suspicions were wrong, in that it's not a UTF8 local issue.
Also I was wrong in my understanding of the string table - the string table
warning occurs independent of -DDEBUGGING

However, I can't be sure if this illegal memory access is actually the
same bug as you're seeing. I'm a bit confused by all this, because valgrind
seems to be reporting errors in the pad code, and pads have been substantially
reworked for bleadperl, but not maintperl. Hence I'm surprised that the bug
seems to be fixed in both branches, given that the implementation differs.

It's probably a different bug you're seeing. I suspect it's the same as this
bug:

$ ./perl -Ilib -lwe '%hash = ("perl"=>"rules"); foreach (sort keys %hash) {while (<>) {}}'
Segmentation fault (core dumped)

(for -DPERL_COPY_ON_WRITE)

I'm not quite sure what the correct fix is. The problem is that
do_readline calls Sv_Grow

tmplen = SvLEN(sv); /* remember if already alloced */
if (!tmplen)
Sv_Grow(sv, 80); /* try short-buffering it */

SvLEN() is 0 for a shared hash key scalar, so the if is true.

sv_grow ends up in this else block:

else {
New(703, s, newlen, char);
if (SvPVX(sv) && SvCUR(sv)) {
Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
}
}
SvPV_set(sv, s);
SvLEN_set(sv, newlen);

and at the end of that the shared hash key scalar:

SV = PVIV(0x812f820) at 0x812f15c
REFCNT = 2
FLAGS = (POK,FAKE,READONLY,pPOK)
UV = 3023084856 (HASH)
PV = 0x812e3a8 "perl"
CUR = 4
LEN = 0

becomes the (incorrect)

SV = PVIV(0x812f820) at 0x812f15c
REFCNT = 2
FLAGS = (POK,FAKE,READONLY,pPOK)
UV = 3023084856 (COW from 0xb4309d38)
PV = 0x8130180 "perl"
CUR = 4
LEN = 80

(FAKE and READONLY should be off)

I'm not sure how to solve this. The correct thing to do would be to call
force_normal from sv_grow (if needed). But force_normal will allocate a
minimally sized buffer using malloc(), only for sv_grow to want to extend it
again. And I'm loathe to duplicate the un-COW logic into sv_grow.

But it would explain how the warning about unbalanced string tables.
(Even for 5.8.0, which can't do copy on write)

Nicholas Clark

p5pRT · 2003-03-24T08:56:45Z

From @iabyn

On Sun, Mar 23, 2003 at 05:59:59PM +0000, Nicholas Clark wrote:

However, I can't be sure if this illegal memory access is actually the
same bug as you're seeing. I'm a bit confused by all this, because valgrind
seems to be reporting errors in the pad code, and pads have been substantially
reworked for bleadperl, but not maintperl. Hence I'm surprised that the bug
seems to be fixed in both branches, given that the implementation differs.

Most of my pad patches have recently been integrated into maintperl.
(Jarkko is either very wise or insane (or both).)

--
Blaming Islam for 911 is like blaming Christianity for Oklahoma City.

p5pRT · 2003-03-24T23:29:06Z

From @nwc10

On Sun, Mar 23, 2003 at 05:59:59PM +0000, Nicholas Clark wrote:

Running with maintperl (5.8.1 to be) or bleadperl (the current development
snapshot) valgrind reports no memory errors. So there does seem to be a bug
in 5.8.0, and it seems to have been fixed for 5.8.1
However, I can't be sure if this illegal memory access is actually the
same bug as you're seeing. I'm a bit confused by all this, because valgrind

It's not. It can be repeated on a debugging 5.8.0 like this:

$ echo | PERL_DESTRUCT_LEVEL=2 perl5.8.0-32-g -lwe '%a= qw(k v); foreach (keys %a) {$_ = <>;}'
Unbalanced string table refcount: (1) for "k" during global destruction.

It's present in maint:

nick@penfold:~/19053-g$ echo | PERL_DESTRUCT_LEVEL=2 ./perl -lwe '%a= qw(k v); foreach (keys %a) {$_ = <>;}'
Assertion !((sv)->sv_flags & 0x00800000) failed: file "pp_hot.c", line 1528 at -e line 1.

It's fixed in blead for the normal case (not copy on write), but not for
copy on write. The code paths in Perl_sv_force_normal_flags are completely
different depending on whether perl is built with copy on write

How does one write a regression test to check for lack of warnings?
Make a new perl and check that STDERR is empty?

Nicholas Clark

p5pRT · 2003-03-25T08:57:05Z

From @rgs

Nicholas Clark <nick@unfortu.net> wrote:

It's fixed in blead for the normal case (not copy on write), but not for
copy on write. The code paths in Perl_sv_force_normal_flags are completely
different depending on whether perl is built with copy on write

It produces a segfault here, not a warning.

#0 0x80df23b in S_sv_release_COW (sv=0x8189604,
pvx=0x8197bf0 "k\r\024@ð\r\024@", cur=1, len=80, hash=2150891594,
after=0x8034004a) at sv.c:4353
4353 SV *current = SV_COW_NEXT_SV(after);

How does one write a regression test to check for lack of warnings?
Make a new perl and check that STDERR is empty?

Adding it to t/lib/warnings/perl should be sufficient ?
the "Unbalanced string table refcount" is marked TODO here.

p5pRT · 2003-03-25T09:06:28Z

From @nwc10

On Tue, Mar 25, 2003 at 09:56:03AM +0100, Rafael Garcia-Suarez wrote:

Nicholas Clark <nick@unfortu.net> wrote:

It's fixed in blead for the normal case (not copy on write), but not for
copy on write. The code paths in Perl_sv_force_normal_flags are completely
different depending on whether perl is built with copy on write

It produces a segfault here, not a warning.

#0 0x80df23b in S_sv_release_COW (sv=0x8189604,
pvx=0x8197bf0 "k\r\024@ð\r\024@", cur=1, len=80, hash=2150891594,
after=0x8034004a) at sv.c:4353
4353 SV *current = SV_COW_NEXT_SV(after);

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
with COW, and seemingly clean on blead without COW. However, I'm not
convinced that it's actually doing the right thing on blead without COW.
I think it's more chance, and down to how sv_grow and related functions
were re-written.

I'll need to think about it some more when I get home.

How does one write a regression test to check for lack of warnings?
Make a new perl and check that STDERR is empty?

Adding it to t/lib/warnings/perl should be sufficient ?
the "Unbalanced string table refcount" is marked TODO here.

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.

It's somewhat difficult to write a correct warnings test for
"Unbalanced string table refcount" given that any that show up are bugs that
need fixing. Unless we deliberately write some XS.

Nicholas Clark

p5pRT · 2003-03-25T23:03:47Z

From @nwc10

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

Inline Patch

--- 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)

p5pRT · 2003-03-26T22:27:40Z

From @rgs

Nicholas Clark wrote:

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.

Anyway, thanks, applied as #19069 to bleadperl.

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.

BTW I notice that SvIsCOW is not documented in perlapi.pod. That's un-nice.

p5pRT · 2003-03-26T23:05:29Z

From @nwc10

On Wed, Mar 26, 2003 at 11:30:05PM +0100, Rafael Garcia-Suarez wrote:

Nicholas Clark wrote:

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.

Anyway, thanks, applied as #19069 to bleadperl.

Oh er erk. I've been working on a better one, which is tested, and I don't
have time to resync to 19069 and then retry. Would it be possible to revert
19069 and apply the appended to blead. The first two hunks (readline.t and
pp_hot.c apply to maint. Without the pp_hot.c fix maint goes:

$ PERL_DESTRUCT_LEVEL=2 ./perl /stuff/blead/19055-g/t/op/readline.t
1..11
ok 1 - [perl \#19566]
ok 2 - \#21628 - $a .= <A> , A eof
ok 3 - \#21628 - $a .= <A> , A closed
not ok 4 - [perl \#21614] for length 1
# Failed at /stuff/blead/19055-g/t/op/readline.t line 28
# got 'endUnbalanced string table refcount: (1) for "k" during global destruction.
# '
# expected 'end'
not ok 5 - [perl \#21614] for length 82
# Failed at /stuff/blead/19055-g/t/op/readline.t line 28
# got 'endUnbalanced string table refcount: (1) for "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk" during global destruction.
# '
# expected 'end'
not ok 6 - rcatline to shared sv for length 4
# Failed at /stuff/blead/19055-g/t/op/readline.t line 37
# got 'perl rulesUnbalanced string table refcount: (1) for "perl" during global destruction.
# '
# expected 'perl rules'
not ok 7 - rcatline to shared sv for length 84
# Failed at /stuff/blead/19055-g/t/op/readline.t line 37
# got 'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rulesUnbalanced string table refcount: (1) for "perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl" during global destruction.
# '
# expected 'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rules'
ok 8 - catline to COW sv for length 1
ok 9 - catline to COW sv for length 82
ok 10 - rcatline to COW sv for length 4
ok 11 - rcatline to COW sv for length 84

Without the patch, blead with COW looks like this:
$ PERL_DESTRUCT_LEVEL=2 ./perl /stuff/blead/19055-g/t/op/readline.t
1..11
ok 1 - [perl \#19566]
ok 2 - \#21628 - $a .= <A> , A eof
ok 3 - \#21628 - $a .= <A> , A closed
Segmentation fault - core dumped
not ok 4 - [perl \#21614] for length 1
# Failed at /stuff/blead/19055-g/t/op/readline.t line 28
# got ''
# expected 'end'
Segmentation fault - core dumped
not ok 5 - [perl \#21614] for length 82
# Failed at /stuff/blead/19055-g/t/op/readline.t line 28
# got ''
# expected 'end'
Segmentation fault - core dumped
not ok 6 - rcatline to shared sv for length 4
# Failed at /stuff/blead/19055-g/t/op/readline.t line 37
# got ''
# expected 'perl rules'
Segmentation fault - core dumped
not ok 7 - rcatline to shared sv for length 84
# Failed at /stuff/blead/19055-g/t/op/readline.t line 37
# got ''
# expected 'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rules'
ok 8 - catline to COW sv for length 1
ok 9 - catline to COW sv for length 82
not ok 10 - rcatline to COW sv for length 4
# Failed at /stuff/blead/19055-g/t/op/readline.t line 54
# got 'catl rules
# '
# expected 'perl rules
# '
not ok 11 - rcatline to COW sv for length 84
# Failed at /stuff/blead/19055-g/t/op/readline.t line 54
# got '# expected \'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rules
# '
# expected 'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rules
# '

)

BTW I notice that SvIsCOW is not documented in perlapi.pod. That's un-nice.

I won't manage that tonight - I'm about to go to bed.

Nicholas Clark

Inline Patch

--- t/op/readline.t.orig	Thu Mar 20 23:53:46 2003
+++ t/op/readline.t	Wed Mar 26 21:28:07 2003
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 3;
+plan tests => 11;
 
 eval { for (\2) { $_ = <FH> } };
 like($@, 'Modification of a read-only value attempted', '[perl #19566]');
@@ -18,3 +18,43 @@ like($@, 'Modification of a read-only va
   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);
+}
+
+
+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
--- pp_hot.c.orig	Thu Mar 20 23:53:46 2003
+++ pp_hot.c	Wed Mar 26 22:08:59 2003
@@ -1509,7 +1509,7 @@ Perl_do_readline(pTHX)
 	    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)) {
--- sv.c.orig	Wed Mar 12 12:11:43 2003
+++ sv.c	Wed Mar 26 22:09:47 2003
@@ -4448,11 +4448,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)
@@ -6289,7 +6289,8 @@ Perl_sv_gets(pTHX_ register SV *sv, regi
     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

p5pRT · 2003-03-26T23:19:18Z

From @rgs

Nicholas Clark wrote:

On Wed, Mar 26, 2003 at 11:30:05PM +0100, Rafael Garcia-Suarez wrote:

Nicholas Clark wrote:

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.

Anyway, thanks, applied as #19069 to bleadperl.

Oh er erk. I've been working on a better one, which is tested, and I don't
have time to resync to 19069 and then retry. Would it be possible to revert
19069 and apply the appended to blead.

Yup, it's possible. Thanks, applied as #19071.

p5pRT · 2003-03-27T22:47:36Z

From @nwc10

On Tue, Mar 25, 2003 at 10:59:17PM +0000, Nicholas Clark wrote:

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.

I can't see a clean way to do this. (which is annoying). It's do-able, but
it looks like it will add two bursts of checking for COW for every call to
SvGROW

On Thu, Mar 27, 2003 at 12:21:39AM +0100, Rafael Garcia-Suarez wrote:

Nicholas Clark wrote:

Oh er erk. I've been working on a better one, which is tested, and I don't
have time to resync to 19069 and then retry. Would it be possible to revert
19069 and apply the appended to blead.

Yup, it's possible. Thanks, applied as #19071.

Thanks

On Wed, Mar 26, 2003 at 11:30:05PM +0100, Rafael Garcia-Suarez wrote:

BTW I notice that SvIsCOW is not documented in perlapi.pod. That's un-nice.

Is this suitable?

Nicholas Clark

Inline Patch

--- sv.h.orig	Tue Mar 11 19:29:28 2003
+++ sv.h	Thu Mar 27 22:28:53 2003
@@ -920,6 +920,14 @@ Like C<SvPV>, but converts sv to byte re
 Guarantees to evaluate sv only once; use the more efficient C<SvPVbyte>
 otherwise.
 
+=for apidoc Am|bool|SvIsCOW|SV* sv
+Returns a boolean indicating whether the SV is Copy-On-Write. (either shared
+hash key scalars, or full Copy On Write scalars if 5.9.0 is configured for
+COW)
+
+=for apidoc Am|bool|SvIsCOW_shared_hash|SV* sv
+Returns a boolean indicating whether the SV is Copy-On-Write shared hash key
+scalar.
 
 =cut
 */

p5pRT · 2003-03-29T21:32:08Z

From @rgs

Nicholas Clark wrote:

BTW I notice that SvIsCOW is not documented in perlapi.pod. That's un-nice.

Is this suitable?

Yes : thanks, applied as #19079.

p5pRT · 2003-03-30T06:52:55Z

@rspier - Status changed from 'new' to 'resolved'

p5pRT closed this as completed Mar 30, 2003

p5pRT added the Severity Low label Oct 18, 2019

Provide feedback

Saved searches

Use saved searches to filter your results more quickly

5.8.0 Unbalanced string table refcount #6387

5.8.0 Unbalanced string table refcount #6387

p5pRT commented Mar 19, 2003

p5pRT commented Mar 19, 2003

p5pRT commented Mar 20, 2003

p5pRT commented Mar 21, 2003

p5pRT commented Mar 21, 2003

p5pRT commented Mar 21, 2003

p5pRT commented Mar 22, 2003

p5pRT commented Mar 23, 2003

p5pRT commented Mar 23, 2003

p5pRT commented Mar 23, 2003

p5pRT commented Mar 24, 2003

p5pRT commented Mar 24, 2003

p5pRT commented Mar 25, 2003

p5pRT commented Mar 25, 2003

p5pRT commented Mar 25, 2003

p5pRT commented Mar 26, 2003

p5pRT commented Mar 26, 2003

p5pRT commented Mar 26, 2003

p5pRT commented Mar 27, 2003

p5pRT commented Mar 29, 2003

p5pRT commented Mar 30, 2003

Navigation Menu

5.8.0 Unbalanced string table refcount #6387

5.8.0 Unbalanced string table refcount #6387

Comments

p5pRT commented Mar 19, 2003

p5pRT commented Mar 19, 2003

From Paul@dyerhouse.com

p5pRT commented Mar 20, 2003

From @rgs

p5pRT commented Mar 21, 2003

From Paul@dyerhouse.com

p5pRT commented Mar 21, 2003

From Paul@dyerhouse.com

p5pRT commented Mar 21, 2003

From @rgs

p5pRT commented Mar 22, 2003

From @nwc10

p5pRT commented Mar 23, 2003

From @nwc10

p5pRT commented Mar 23, 2003

From @rgs

p5pRT commented Mar 23, 2003

From @nwc10

p5pRT commented Mar 24, 2003

From @iabyn

p5pRT commented Mar 24, 2003

From @nwc10

p5pRT commented Mar 25, 2003

From @rgs

p5pRT commented Mar 25, 2003

From @nwc10

p5pRT commented Mar 25, 2003

From @nwc10

p5pRT commented Mar 26, 2003

From @rgs

p5pRT commented Mar 26, 2003

From @nwc10

p5pRT commented Mar 26, 2003

From @rgs

p5pRT commented Mar 27, 2003

From @nwc10

p5pRT commented Mar 29, 2003

From @rgs

p5pRT commented Mar 30, 2003