+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
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
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
use AutoLoader;
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.09';
+$VERSION = '2.10';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
}
}
+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
* 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) \
*/
PUTMARK(SX_CODE);
+ cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */
TRACEME(("size = %d", len));
TRACEME(("code = %s", SvPV_nolen(text)));
/*
* 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>"));
TRACEME(("retrieve_sv_no"));
+ cxt->tagnum--; /* undo the tagnum increment in retrieve_l?scalar */
SEEN(sv, cname);
return sv;
}
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
*/
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;
}
}
FREETMPS;
LEAVE;
+ /* fix up the dummy entry... */
+ av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
- SEEN(sv, cname);
return sv;
#endif
}
gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV);
#endif
+void
+init_perinterp()
+
int
pstore(f,obj)
OutputStream f
}
}
-BEGIN { plan tests => 49 }
+BEGIN { plan tests => 59 }
use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
use Safe;
}
}
+{
+ # 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]));
+ }
+
+}
--- /dev/null
+#!/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";
+}
+
--- /dev/null
+
+# 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;
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff