From: Jarkko Hietaniemi Date: Sun, 5 Nov 2000 17:38:46 +0000 (+0000) Subject: Upgrade to Storable 1.0.6, from Raphael Manfredi. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=908268814f02faf4635885d2cb46669bad5bb32b;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Storable 1.0.6, from Raphael Manfredi. p4raw-id: //depot/perl@7560 --- diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index 6b90c74..352e620 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,14 @@ +Sun Nov 5 18:23:48 MET 2000 Raphael Manfredi + +. Description: + + Version 1.0.6. + + Fixed severe "object lost" bug for STORABLE_freeze returns, + when refs to lexicals, taken within the hook, were to be + serialized by Storable. Enhanced the t/recurse.t test to + stress hook a little more with refs to lexicals. + Thu Oct 26 19:14:38 MEST 2000 Raphael Manfredi . Description: diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 5cd06a0..7b46317 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -1,4 +1,4 @@ -;# $Id: Storable.pm,v 1.0.1.5 2000/10/26 17:10:18 ram Exp ram $ +;# $Id: Storable.pm,v 1.0.1.5 2000/10/26 17:10:18 ram Exp $ ;# ;# Copyright (c) 1995-2000, Raphael Manfredi ;# @@ -6,6 +6,9 @@ ;# in the README file that comes with the distribution. ;# ;# $Log: Storable.pm,v $ +;# Revision 1.0.1.6 2000/11/05 17:20:25 ram +;# patch6: increased version number +;# ;# Revision 1.0.1.5 2000/10/26 17:10:18 ram ;# patch5: documented that store() and retrieve() can return undef ;# patch5: added paragraph explaining the auto require for thaw hooks @@ -35,7 +38,7 @@ package Storable; @ISA = qw(Exporter DynaLoader); use AutoLoader; use vars qw($forgive_me $VERSION); -$VERSION = '1.005'; +$VERSION = '1.006'; *AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... # diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index b4066dc..f7c810a 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -3,7 +3,7 @@ */ /* - * $Id: Storable.xs,v 1.0.1.4 2000/10/26 17:11:04 ram Exp ram $ + * $Id: Storable.xs,v 1.0.1.4 2000/10/26 17:11:04 ram Exp $ * * Copyright (c) 1995-2000, Raphael Manfredi * @@ -11,6 +11,9 @@ * in the README file that comes with the distribution. * * $Log: Storable.xs,v $ + * Revision 1.0.1.5 2000/11/05 17:21:24 ram + * patch6: fixed severe "object lost" bug for STORABLE_freeze returns + * * Revision 1.0.1.4 2000/10/26 17:11:04 ram * patch5: auto requires module of blessed ref when STORABLE_thaw misses * @@ -94,14 +97,21 @@ typedef double NV; /* Older perls lack the NV type */ #endif #ifdef DEBUGME -#ifndef DASSERT -#define DASSERT -#endif -#define TRACEME(x) do { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } while (0) +/* + * TRACEME() will only output things when the $Storable::DEBUGME is true. + */ + +#define TRACEME(x) do { \ + if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE))) \ + { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ +} while (0) #else #define TRACEME(x) #endif +#ifndef DASSERT +#define DASSERT +#endif #ifdef DASSERT #define ASSERT(x,y) do { \ if (!(x)) { \ @@ -242,6 +252,7 @@ typedef struct stcxt { int entry; /* flags recursion */ int optype; /* type of traversal operation */ HV *hseen; /* which objects have been seen, store time */ + AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */ AV *aseen; /* which objects have been seen, retrieve time */ HV *hclass; /* which classnames have been seen, store time */ AV *aclass; /* which classnames have been seen, retrieve time */ @@ -953,6 +964,15 @@ static void init_store_context( */ cxt->hook = newHV(); /* Table where hooks are cached */ + + /* + * The `hook_seen' array keeps track of all the SVs returned by + * STORABLE_freeze hooks for us to serialize, so that they are not + * reclaimed until the end of the serialization process. Each SV is + * only stored once, the first time it is seen. + */ + + cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */ } /* @@ -993,6 +1013,9 @@ static void clean_store_context(stcxt_t *cxt) hv_undef(cxt->hook); sv_free((SV *) cxt->hook); + av_undef(cxt->hook_seen); + sv_free((SV *) cxt->hook_seen); + cxt->entry = 0; cxt->s_dirty = 0; } @@ -2116,11 +2139,14 @@ static int store_hook( for (i = 1; i < count; i++) { SV **svh; - SV *xsv = ary[i]; + SV *rsv = ary[i]; + SV *xsv; + AV *av_hook = cxt->hook_seen; - if (!SvROK(xsv)) - CROAK(("Item #%d from hook in %s is not a reference", i, class)); - xsv = SvRV(xsv); /* Follow ref to know what to look for */ + if (!SvROK(rsv)) + CROAK(("Item #%d returned by STORABLE_freeze " + "for %s is not a reference", i, class)); + xsv = SvRV(rsv); /* Follow ref to know what to look for */ /* * Look in hseen and see if we have a tag already. @@ -2156,11 +2182,34 @@ static int store_hook( CROAK(("Could not serialize item #%d from hook in %s", i, class)); /* - * Replace entry with its tag (not a real SV, so no refcnt increment) + * It was the first time we serialized `xsv'. + * + * Keep this SV alive until the end of the serialization: if we + * disposed of it right now by decrementing its refcount, and it was + * a temporary value, some next temporary value allocated during + * another STORABLE_freeze might take its place, and we'd wrongly + * assume that new SV was already serialized, based on its presence + * in cxt->hseen. + * + * Therefore, push it away in cxt->hook_seen. */ + av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv)); + sv_seen: - SvREFCNT_dec(xsv); + /* + * Dispose of the REF they returned. If we saved the `xsv' away + * in the array of returned SVs, that will not cause the underlying + * referenced SV to be reclaimed. + */ + + ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF")); + SvREFCNT_dec(rsv); /* Dispose of reference */ + + /* + * Replace entry with its tag (not a real SV, so no refcnt increment) + */ + ary[i] = *svh; TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf, i-1, PTR2UV(xsv), PTR2UV(*svh))); diff --git a/t/lib/st-recurse.t b/t/lib/st-recurse.t index dcf6d1a..b429747 100644 --- a/t/lib/st-recurse.t +++ b/t/lib/st-recurse.t @@ -1,6 +1,6 @@ #!./perl -# $Id: recurse.t,v 1.0.1.1 2000/09/17 16:48:05 ram Exp $ +# $Id: recurse.t,v 1.0.1.2 2000/11/05 17:22:05 ram Exp ram $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -8,6 +8,10 @@ # in the README file that comes with the distribution. # # $Log: recurse.t,v $ +# Revision 1.0.1.2 2000/11/05 17:22:05 ram +# patch6: stress hook a little more with refs to lexicals +# +# $Log: recurse.t,v $ # Revision 1.0.1.1 2000/09/17 16:48:05 ram # patch1: added test case for store hook bug # @@ -97,15 +101,19 @@ sub make { sub STORABLE_freeze { my $self = shift; - my $t = dclone($self->{sync}); - return ("", [$t, $self->{ext}], $self, $self->{ext}); + my %copy = %$self; + my $r = \%copy; + my $t = dclone($r->{sync}); + return ("", [$t, $self->{ext}], $r, $self, $r->{ext}); } sub STORABLE_thaw { my $self = shift; - my ($cloning, $undef, $a, $obj, $ext) = @_; + my ($cloning, $undef, $a, $r, $obj, $ext) = @_; die "STORABLE_thaw #1" unless $obj eq $self; die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; + die "STORABLE_thaw #3" unless ref $r eq 'HASH'; + die "STORABLE_thaw #4" unless $a->[1] == $r->{ext}; $self->{ok} = $self; ($self->{sync}, $self->{ext}) = @$a; }