From: Abhijit Menon-Sen Date: Sat, 24 Jan 2004 11:03:36 +0000 (+0000) Subject: [patch] make Storable thread-safe X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a8b7ef86e7eea87c1e7ba6a6f9d5d81b5954df00;p=p5sagit%2Fp5-mst-13.2.git [patch] make Storable thread-safe From: Stas Bekman 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 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 Date: Tue, 20 Jan 2004 22:30:15 +1300 Message-Id: <200401202230.15865.sam@vilain.net> p4raw-id: //depot/perl@22205 --- diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index ea038c8..72951dd 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,17 @@ +Sat Jan 24 16:22:32 IST 2004 Abhijit Menon-Sen + + 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 Version 2.09 diff --git a/ext/Storable/MANIFEST b/ext/Storable/MANIFEST index 4dba62b..d9b2d0d 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 e7f9600..19f8834 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 77003aa..5b3868b 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) : "")); @@ -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/t/code.t b/ext/Storable/t/code.t index b66cae7..a409875 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; @@ -282,3 +282,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 0000000..e802839 --- /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 0000000..eddc4bb --- /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; +}