Integrate:

[ 22205]
Subject: [patch] make Storable thread-safe
From: Stas Bekman <stas@stason.org>
Date: Mon, 19 Jan 2004 00:20:02 -0800
Message-Id: <400B9332.4070106@stason.org>

Subject: Re: Subroutine reference bug in Storable
From: Slaven Rezic <slaven@rezic.de>
Date: 14 Nov 2003 23:22:55 +0100
Message-Id: <874qx6zj28.fsf@vran.herceg.de>

Subject: Re: [perl #25145] [PATCH] Storable segfaults with B::Deparse +
         overload + cyclic structures
From: Sam Vilain <sam@vilain.net>
Date: Tue, 20 Jan 2004 22:30:15 +1300
Message-Id: <200401202230.15865.sam@vilain.net>

[ 22206]
Subject: [PATCH] Storable-2.08/t/code.t
From: Slaven Rezic <slaven@rezic.de>
Date: Sat, 8 Nov 2003 16:26:19 +0100 (CET)
Message-Id: <200311081526.hA8FQJgb011684@vran.herceg.de>

[ 22216]
update MANIFEST for 2 new Storable test files introduced by 22205

[ 22238]
Storable's hints file shouldn't blanket set optimize to -O2 on Linux
Only *drop* optimize to -O2 if it's -O3 on gcc on Linux

[ 22247]
Drop optimization for -O3 *and higher*
p4raw-link: @22247 on //depot/perl: a2059b76e524df362053936d8d5d440b69d59cb2
p4raw-link: @22238 on //depot/perl: deade07f0bde6c2aae1e343d2c3d09fab8fcd7ee
p4raw-link: @22216 on //depot/perl: ec64fef1196a1e300ecd2679312685caf45d2608
p4raw-link: @22206 on //depot/perl: 8578bbeb998c7734d55a4c0df1357285f9ed26ed
p4raw-link: @22205 on //depot/perl: a8b7ef86e7eea87c1e7ba6a6f9d5d81b5954df00

p4raw-id: //depot/maint-5.8/perl@22448
p4raw-branched: from //depot/perl@22447 'branch in'
	ext/Storable/t/just_plain_nasty.t
p4raw-integrated: from //depot/perl@22447 'copy in'
	ext/Storable/Storable.xs (@21088..) ext/Storable/ChangeLog
	(@22050..) ext/Storable/MANIFEST (@22104..)
	ext/Storable/t/code.t (@22205..)
p4raw-integrated: from //depot/perl@22238 'ignore'
	ext/Storable/hints/linux.pl (@20861..)
p4raw-integrated: from //depot/perl@22216 'merge in' MANIFEST
	(@22204..)
p4raw-branched: from //depot/perl@22205 'branch in'
	ext/Storable/t/threads.t
p4raw-integrated: from //depot/perl@22205 'copy in'
	ext/Storable/Storable.pm (@22049..)

9 files changed, 305 insertions, 15 deletions

diff --git a/MANIFEST b/MANIFEST
index 22c688edfa..3a26171fbe 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -662,6 +662,7 @@ ext/Storable/t/forgive.t	See if Storable works
 ext/Storable/t/freeze.t		See if Storable works
 ext/Storable/t/integer.t	See if Storable works
 ext/Storable/t/interwork56.t	Test compatibility kludge for 64bit data under 5.6.x
+ext/Storable/t/just_plain_nasty.t	See if Storable works
 ext/Storable/t/lock.t		See if Storable works
 ext/Storable/t/make_56_interwork.pl	Make test data for interwork56.t
 ext/Storable/t/make_downgrade.pl	Make test data for downgrade.t
@@ -675,6 +676,7 @@ ext/Storable/t/store.t		See if Storable works
 ext/Storable/t/tied_hook.t	See if Storable works
 ext/Storable/t/tied_items.t	See if Storable works
 ext/Storable/t/tied.t		See if Storable works
+ext/Storable/t/threads.t	Does Storable work with threads?
 ext/Storable/t/utf8hash.t	See if Storable works
 ext/Storable/t/utf8.t		See if Storable works
 ext/Sys/Hostname/Hostname.pm	Sys::Hostname extension Perl module
diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog
index ea038c8fa0..72951ddb3a 100644
--- a/ext/Storable/ChangeLog
+++ b/ext/Storable/ChangeLog
@@ -1,3 +1,17 @@
+Sat Jan 24 16:22:32 IST 2004   Abhijit Menon-Sen <ams@wiw.org>
+
+    Version 2.10
+
+        1. Thread safety: Storable::CLONE/init_perlinterp() now create
+           a new Perl context for each new ithread.
+           (From Stas Bekman and Jan Dubois.)
+        2. Fix a tag count mismatch with $Storable::Deparse that caused
+           all back-references after a stored sub to be off-by-N (where
+           N was the number of code references in between).
+           (From Sam Vilain.)
+        3. Prevent CODE references from turning into SCALAR references.
+           (From Slaven Rezic.)
+
 Sat Jan  3 18:49:18 GMT 2004   Nicholas Clark <nick@ccl4.org>
 
     Version 2.09
diff --git a/ext/Storable/MANIFEST b/ext/Storable/MANIFEST
index 4dba62bf07..d9b2d0dc40 100644
--- a/ext/Storable/MANIFEST
+++ b/ext/Storable/MANIFEST
@@ -16,6 +16,7 @@ t/forgive.t		    See if Storable works
 t/freeze.t		    See if Storable works
 t/integer.t		    For "use integer" testing
 t/interwork56.t		    Test combatibility kludge for 64bit data under 5.6.x
+t/just_plain_nasty.t	    Corner case corner.
 t/lock.t		    See if Storable works
 t/make_56_interwork.pl	    Make test data for interwork56.t
 t/make_downgrade.pl	    Make test data for downgrade.t
@@ -29,6 +30,7 @@ t/store.t		    See if Storable works
 t/tied.t		    See if Storable works
 t/tied_hook.t		    See if Storable works
 t/tied_items.t		    See if Storable works
+t/threads.t                 See if Storable works under ithreads
 t/utf8.t		    See if Storable works
 t/utf8hash.t		    See if Storable works
 # t/Test/Builder.pm	    For testing the CPAN release on pre 5.6.2
diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm
index e7f9600cb2..19f8834a26 100644
--- a/ext/Storable/Storable.pm
+++ b/ext/Storable/Storable.pm
@@ -21,7 +21,7 @@ package Storable; @ISA = qw(Exporter DynaLoader);
 use AutoLoader;
 use vars qw($canonical $forgive_me $VERSION);
 
-$VERSION = '2.09';
+$VERSION = '2.10';
 *AUTOLOAD = \&AutoLoader::AUTOLOAD;		# Grrr...
 
 #
@@ -47,6 +47,11 @@ BEGIN {
 	}
 }
 
+sub CLONE {
+    # clone context under threads
+    Storable::init_perinterp();
+}
+
 # Can't Autoload cleanly as this clashes 8.3 with &retrieve
 sub retrieve_fd { &fd_retrieve }		# Backward compatibility
 
diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index 77003aaf76..5b3868b8f7 100644
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -791,6 +791,13 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
  * Useful store shortcuts...
  */
 
+/*
+ * Note that if you put more than one mark for storing a particular
+ * type of thing, *and* in the retrieve_foo() function you mark both
+ * the thingy's you get off with SEEN(), you *must* increase the
+ * tagnum with cxt->tagnum++ along with this macro!
+ *     - samv 20Jan04
+ */
 #define PUTMARK(x) 							\
   STMT_START {								\
 	if (!cxt->fio)							\
@@ -2463,6 +2470,7 @@ static int store_code(stcxt_t *cxt, CV *cv)
 	 */
 
 	PUTMARK(SX_CODE);
+	cxt->tagnum++;   /* necessary, as SX_CODE is a SEEN() candidate */
 	TRACEME(("size = %d", len));
 	TRACEME(("code = %s", SvPV_nolen(text)));
 
@@ -4202,10 +4210,11 @@ static SV *retrieve_overloaded(stcxt_t *cxt, char *cname)
 	/*
 	 * Restore overloading magic.
 	 */
-
-	stash = (HV *) SvSTASH (sv);
-	if (!stash || !Gv_AMG(stash))
-		CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)",
+	if (!SvTYPE(sv)
+	    || !(stash = (HV *) SvSTASH (sv))
+	    || !Gv_AMG(stash))
+		CROAK(("Cannot restore overloading on %s(0x%"UVxf
+		       ") (package %s)",
 		       sv_reftype(sv, FALSE),
 		       PTR2UV(sv),
 			   stash ? HvNAME(stash) : "<unknown>"));
@@ -4695,6 +4704,7 @@ static SV *retrieve_sv_no(stcxt_t *cxt, char *cname)
 
 	TRACEME(("retrieve_sv_no"));
 
+	cxt->tagnum--; /* undo the tagnum increment in retrieve_l?scalar */
 	SEEN(sv, cname);
 	return sv;
 }
@@ -4975,13 +4985,24 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname)
     CROAK(("retrieve_code does not work with perl 5.005 or less\n"));
 #else
 	dSP;
-	int type, count;
+	int type, count, tagnum;
 	SV *cv;
 	SV *sv, *text, *sub;
 
 	TRACEME(("retrieve_code (#%d)", cxt->tagnum));
 
 	/*
+	 *  Insert dummy SV in the aseen array so that we don't screw
+	 *  up the tag numbers.  We would just make the internal
+	 *  scalar an untagged item in the stream, but
+	 *  retrieve_scalar() calls SEEN().  So we just increase the
+	 *  tag number.
+	 */
+	tagnum = cxt->tagnum;
+	sv = newSViv(0);
+	SEEN(sv, cname);
+
+	/*
 	 * Retrieve the source of the code reference
 	 * as a small or large scalar
 	 */
@@ -5023,6 +5044,8 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname)
 			CROAK(("Can't eval, please set $Storable::Eval to a true value"));
 		} else {
 			sv = newSVsv(sub);
+			/* fix up the dummy entry... */
+			av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
 			return sv;
 		}
 	}
@@ -5060,8 +5083,9 @@ static SV *retrieve_code(stcxt_t *cxt, char *cname)
 
 	FREETMPS;
 	LEAVE;
+	/* fix up the dummy entry... */
+	av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
 
-	SEEN(sv, cname);
 	return sv;
 #endif
 }
@@ -5901,6 +5925,9 @@ BOOT:
     gv_fetchpv("Storable::interwork_56_64bit",   GV_ADDMULTI, SVt_PV);
 #endif
 
+void
+init_perinterp()
+
 int
 pstore(f,obj)
 OutputStream	f
diff --git a/ext/Storable/hints/linux.pl b/ext/Storable/hints/linux.pl
index ed80f8466c..0c7d5e35a9 100644
--- a/ext/Storable/hints/linux.pl
+++ b/ext/Storable/hints/linux.pl
@@ -6,5 +6,10 @@
 # 20011002 and 3.3, and in Redhat 7.1 with gcc 3.3.1. The failures
 # happen only for unthreaded builds, threaded builds work okay.
 use Config;
-$self->{OPTIMIZE} = '-O2';
+if ($Config{gccversion}) {
+    my $optimize = $Config{optimize};
+    if ($optimize =~ s/(^| )-O[3-9]( |$)/$1-O2$2/) {
+	$self->{OPTIMIZE} = $optimize;
+    }
+}
 
diff --git a/ext/Storable/t/code.t b/ext/Storable/t/code.t
index b66cae7116..81e8b9037d 100644
--- a/ext/Storable/t/code.t
+++ b/ext/Storable/t/code.t
@@ -38,7 +38,7 @@ BEGIN {
     }
 }
 
-BEGIN { plan tests => 49 }
+BEGIN { plan tests => 59 }
 
 use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
 use Safe;
@@ -118,7 +118,7 @@ ok($thawed->(), "JAPH");
 ######################################################################
 
 eval { $freezed = freeze $obj[4] };
-ok($@ =~ /The result of B::Deparse::coderef2text was empty/);
+ok($@, qr/The result of B::Deparse::coderef2text was empty/);
 
 ######################################################################
 # Test dclone
@@ -162,7 +162,7 @@ ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 	$freezed = freeze $obj[$i];
 	$@ = "";
 	eval { $thawed  = thaw $freezed };
-	ok($@ =~ /Can\'t eval/);
+	ok($@, qr/Can\'t eval/);
     }
 }
 
@@ -172,7 +172,7 @@ ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
     for my $i (0 .. 1) {
 	$@ = "";
 	eval { $freezed = freeze $obj[$i] };
-	ok($@ =~ /Can\'t store CODE items/);
+	ok($@, qr/Can\'t store CODE items/);
     }
 }
 
@@ -184,7 +184,7 @@ ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 	$@ = "";
 	eval { $thawed  = thaw $freezed };
 	ok($@, "");
-	ok($$thawed =~ /^sub/);
+	ok($$thawed, qr/^sub/);
     }
 }
 
@@ -218,7 +218,8 @@ ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 
     $freezed = freeze $obj[0]->[6];
     eval { $thawed = thaw $freezed };
-    ok($@ =~ /trapped/);
+    # The "Code sub ..." error message only appears if Log::Agent is installed
+    ok($@, qr/(trapped|Code sub)/);
 
     if (0) {
 	# Disable or fix this test if the internal representation of Storable
@@ -234,7 +235,7 @@ ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 	substr($freezed, -1, 0, $bad_code);
 	$@ = "";
 	eval { $thawed = thaw $freezed };
-	ok($@ =~ /trapped/);
+	ok($@, qr/(trapped|Code sub)/);
     }
 }
 
@@ -282,3 +283,30 @@ ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
     }
 }
 
+{
+    # Check internal "seen" code
+    my $short_sub = sub { "short sub" }; # for SX_SCALAR
+    # for SX_LSCALAR
+    my $long_sub_code = 'sub { "' . "x"x255 . '" }';
+    my $long_sub = eval $long_sub_code; die $@ if $@;
+    my $sclr = \1;
+
+    local $Storable::Deparse = 1;
+    local $Storable::Eval    = 1;
+
+    for my $sub ($short_sub, $long_sub) {
+	my $res;
+
+	$res = thaw freeze [$sub, $sub];
+	ok(int($res->[0]), int($res->[1]));
+
+	$res = thaw freeze [$sclr, $sub, $sub, $sclr];
+	ok(int($res->[0]), int($res->[3]));
+	ok(int($res->[1]), int($res->[2]));
+
+	$res = thaw freeze [$sub, $sub, $sclr, $sclr];
+	ok(int($res->[0]), int($res->[1]));
+	ok(int($res->[2]), int($res->[3]));
+    }
+
+}
diff --git a/ext/Storable/t/just_plain_nasty.t b/ext/Storable/t/just_plain_nasty.t
new file mode 100644
index 0000000000..e80283970e
--- /dev/null
+++ b/ext/Storable/t/just_plain_nasty.t
@@ -0,0 +1,152 @@
+#!/usr/bin/perl
+
+# This is a test suite to cover all the nasty and horrible data
+# structures that cause bizarre corner cases.
+
+#  Everyone's invited! :-D
+
+sub BEGIN {
+    if ($ENV{PERL_CORE}){
+        chdir('t') if -d 't';
+        @INC = ('.', '../lib');
+    } else {
+        unshift @INC, 't';
+    }
+    require Config; import Config;
+    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+        print "1..0 # Skip: Storable was not built\n";
+        exit 0;
+    }
+}
+
+use strict;
+BEGIN {
+    if (!eval q{
+        use Test;
+        use B::Deparse 0.61;
+        use 5.006;
+        1;
+    }) {
+        print "1..0 # skip: tests only work with B::Deparse 0.61 and at least pe
+rl 5.6.0\n";
+        exit;
+    }
+    require File::Spec;
+    if ($File::Spec::VERSION < 0.8) {
+        print "1..0 # Skip: newer File::Spec needed\n";
+        exit 0;
+    }
+}
+
+use Storable qw(freeze thaw);
+
+#$Storable::DEBUGME = 1;
+BEGIN {
+    plan tests => 34;
+}
+
+{
+    package Banana;
+    use overload   
+	'<=>' => \&compare,
+	    '==' => \&equal,
+		'""' => \&real,
+		fallback => 1;
+    sub compare { return int(rand(3))-1 };
+    sub equal { return 1 if rand(1) > 0.5 }
+    sub real { return "keep it so" }
+}
+
+my (@a);
+
+for my $dbun (1, 0) {  # dbun - don't be utterly nasty - being utterly
+                       # nasty means having a reference to the object
+                       # directly within itself. otherwise it's in the
+                       # second array.
+    my $nasty = [
+		 ($a[0] = bless [ ], "Banana"),
+		 ($a[1] = [ ]),
+		];
+
+    $a[$dbun]->[0] = $a[0];
+
+    ok(ref($nasty), "ARRAY", "Sanity found (now to play with it :->)");
+
+    $Storable::Deparse = $Storable::Deparse = 1;
+    $Storable::Eval = $Storable::Eval = 1;
+
+    headit("circular overload 1 - freeze");
+    my $icicle = freeze $nasty;
+    #print $icicle;   # cat -ve recommended :)
+    headit("circular overload 1 - thaw");
+    my $oh_dear = thaw $icicle;
+    ok(ref($oh_dear), "ARRAY", "dclone - circular overload");
+    ok($oh_dear->[0], "keep it so", "amagic ok 1");
+    ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
+
+    headit("closure dclone - freeze");
+    $icicle = freeze sub { "two" };
+    #print $icicle;
+    headit("closure dclone - thaw");
+    my $sub2 = thaw $icicle;
+    ok($sub2->(), "two", "closures getting dcloned OK");
+
+    headit("circular overload, after closure - freeze");
+    #use Data::Dumper;
+    #print Dumper $nasty;
+    $icicle = freeze $nasty;
+    #print $icicle;
+    headit("circular overload, after closure - thaw");
+    $oh_dear = thaw $icicle;
+    ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
+    ok($oh_dear->[0], "keep it so", "amagic ok 1");
+    ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
+
+    push @{$nasty}, sub { print "Goodbye, cruel world.\n" };
+    headit("closure freeze AFTER circular overload");
+    #print Dumper $nasty;
+    $icicle = freeze $nasty;
+    #print $icicle;
+    headit("circular thaw AFTER circular overload");
+    $oh_dear = thaw $icicle;
+    ok(ref($oh_dear), "ARRAY", "dclone - before a closure dclone");
+    ok($oh_dear->[0], "keep it so", "amagic ok 1");
+    ok($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2");
+
+    @{$nasty} = @{$nasty}[0, 2, 1];
+    headit("closure freeze BETWEEN circular overload");
+    #print Dumper $nasty;
+    $icicle = freeze $nasty;
+    #print $icicle;
+    headit("circular thaw BETWEEN circular overload");
+    $oh_dear = thaw $icicle;
+    ok(ref($oh_dear), "ARRAY", "dclone - between a closure dclone");
+    ok($oh_dear->[0], "keep it so", "amagic ok 1");
+    ok($oh_dear->[$dbun?2:0]->[0], "keep it so", "amagic ok 2");
+
+    @{$nasty} = @{$nasty}[1, 0, 2];
+    headit("closure freeze BEFORE circular overload");
+    #print Dumper $nasty;
+    $icicle = freeze $nasty;
+    #print $icicle;
+    headit("circular thaw BEFORE circular overload");
+    $oh_dear = thaw $icicle;
+    ok(ref($oh_dear), "ARRAY", "dclone - after a closure dclone");
+    ok($oh_dear->[1], "keep it so", "amagic ok 1");
+    ok($oh_dear->[$dbun+1]->[0], "keep it so", "amagic ok 2");
+}
+
+sub headit {
+
+    return;  # comment out to get headings - useful for scanning
+             # output with $Storable::DEBUGME = 1
+
+    my $title = shift;
+
+    my $size_left = (66 - length($title)) >> 1;
+    my $size_right = (67 - length($title)) >> 1;
+
+    print "# ".("-" x $size_left). " $title "
+	.("-" x $size_right)."\n";
+}
+
diff --git a/ext/Storable/t/threads.t b/ext/Storable/t/threads.t
new file mode 100644
index 0000000000..eddc4bbcae
--- /dev/null
+++ b/ext/Storable/t/threads.t
@@ -0,0 +1,55 @@
+
+# as of 2.09 on win32 Storable w/threads dies with "free to wrong
+# pool" since it uses the same context for different threads. since
+# win32 perl implementation allocates a different memory pool for each
+# thread using the a memory pool from one thread to allocate memory
+# for another thread makes win32 perl very unhappy
+#
+# but the problem exists everywhere, not only on win32 perl , it's
+# just hard to catch it deterministically - since the same context is
+# used if two or more threads happen to change the state of the
+# context in the middle of the operation, and those operations aren't
+# atomic per thread, bad things including data loss and corrupted data
+# can happen.
+#
+# this has been solved in 2.10 by adding a Storable::CLONE which calls
+# Storable::init_perinterp() to create a new context for each new
+# thread when it starts
+
+sub BEGIN {
+    if ($ENV{PERL_CORE}){
+	chdir('t') if -d 't';
+	@INC = ('.', '../lib');
+    } else {
+	unshift @INC, 't';
+    }
+    require Config; import Config;
+    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+        print "1..0 # Skip: Storable was not built\n";
+        exit 0;
+    }
+    unless ($Config{'useithreads'} and eval { require threads; 1 }) {
+        print "1..0 # Skip: no threads\n";
+        exit 0;
+    }
+}
+
+use Test::More;
+
+use strict;
+
+use threads;
+use Storable qw(nfreeze);
+
+plan tests => 2;
+
+threads->new(\&sub1);
+
+$_->join() for threads->list();
+
+ok 1;
+
+sub sub1 {
+    nfreeze {};
+    ok 1;
+}