From: Jarkko Hietaniemi Date: Tue, 3 Oct 2000 11:20:37 +0000 (+0000) Subject: Upgrade to Storable 1.0.3, from Raphael Manfredi. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dd19458bcc107ff5b00bdc811d918a2e32b367ed;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Storable 1.0.3, from Raphael Manfredi. p4raw-id: //depot/perl@7132 --- diff --git a/MANIFEST b/MANIFEST index 19dafa5..de3b320 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1425,6 +1425,7 @@ t/lib/st-dclone.t See if Storable works t/lib/st-dump.pl See if Storable works t/lib/st-forgive.t See if Storable works t/lib/st-freeze.t See if Storable works +t/lib/st-lock.t See if Storable works t/lib/st-overload.t See if Storable works t/lib/st-recurse.t See if Storable works t/lib/st-retrieve.t See if Storable works @@ -1432,6 +1433,7 @@ t/lib/st-store.t See if Storable works t/lib/st-tied.t See if Storable works t/lib/st-tiedhook.t See if Storable works t/lib/st-tieditems.t See if Storable works +t/lib/st-utf8.t See if Storable works t/lib/symbol.t See if Symbol works t/lib/syslfs.t See if large files work for sysio t/lib/syslog.t See if Sys::Syslog works diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index bb24eb7..049ce29 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,48 @@ +Fri Sep 29 21:52:29 MEST 2000 Raphael Manfredi + +. Description: + + Version 1.0.3. + + Avoid using "tainted" and "dirty" since Perl remaps them via + cpp (i.e. #define). This is deeply harmful when threading + is enabled. This concerned both the context structure and + local variable and argument names. Brrr..., scary! + +Thu Sep 28 23:46:39 MEST 2000 Raphael Manfredi + +. Description: + + Version 1.0.2. + + Fixed spelling in README. + + Added lock_store, lock_nstore, and lock_retrieve (advisory locking) + after a proposal from Erik Haugan . + + Perls before 5.004_04 lack newSVpvn, added remapping in XS. + + Fixed stupid typo in the t/utf8.t test. + +Sun Sep 17 18:51:10 MEST 2000 Raphael Manfredi + +. Description: + + Version 1.0.1, binary format 2.3. + + Documented that doubles are stored stringified by nstore(). + + Added Salvador Ortiz Garcia in CREDITS section, He identified + a bug in the store hooks and proposed the right fix: the class + id was allocated too soon. His bug case was also added to + the regression test suite. + + Now only taint retrieved data when source was tainted. A bug + discovered by Marc Lehmann. + + Added support for UTF-8 strings, a contribution of Marc Lehmann. + This is normally only activated in post-5.6 perls. + Thu Aug 31 23:06:06 MEST 2000 Raphael Manfredi First official release Storable 1.0, for inclusion in perl 5.7.0. diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 9960dc8..76c3209 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -20,12 +20,13 @@ package Storable; @ISA = qw(Exporter DynaLoader); freeze nfreeze thaw dclone retrieve_fd + lock_store lock_nstore lock_retrieve ); use AutoLoader; use vars qw($forgive_me $VERSION); -$VERSION = '1.000'; +$VERSION = '1.003'; *AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... # @@ -43,6 +44,22 @@ unless (defined @Log::Agent::EXPORT) { }; } +# +# They might miss :flock in Fcntl +# + +BEGIN { + require Fcntl; + if (exists $Fcntl::EXPORT_TAGS{'flock'}) { + Fcntl->import(':flock'); + } else { + eval q{ + sub LOCK_SH () {1} + sub LOCK_EX () {2} + }; + } +} + sub logcroak; sub retrieve_fd { &fd_retrieve } # Backward compatibility @@ -60,7 +77,7 @@ __END__ # removed. # sub store { - return _store(\&pstore, @_); + return _store(\&pstore, @_, 0); } # @@ -69,19 +86,43 @@ sub store { # Same as store, but in network order. # sub nstore { - return _store(\&net_pstore, @_); + return _store(\&net_pstore, @_, 0); +} + +# +# lock_store +# +# Same as store, but flock the file first (advisory locking). +# +sub lock_store { + return _store(\&pstore, @_, 1); +} + +# +# lock_nstore +# +# Same as nstore, but flock the file first (advisory locking). +# +sub lock_nstore { + return _store(\&net_pstore, @_, 1); } # Internal store to file routine sub _store { my $xsptr = shift; my $self = shift; - my ($file) = @_; + my ($file, $use_locking) = @_; logcroak "not a reference" unless ref($self); - logcroak "too many arguments" unless @_ == 1; # No @foo in arglist + logcroak "too many arguments" unless @_ == 2; # No @foo in arglist local *FILE; open(FILE, ">$file") || logcroak "can't create $file: $!"; binmode FILE; # Archaic systems... + if ($use_locking) { + flock(FILE, LOCK_EX) || + logcroak "can't get exclusive lock on $file: $!"; + truncate FILE, 0; + # Unlocking will happen when FILE is closed + } my $da = $@; # Don't mess if called from exception handler my $ret; # Call C routine nstore or pstore, depending on network order @@ -172,12 +213,30 @@ sub _freeze { # object of that tree. # sub retrieve { - my ($file) = @_; + _retrieve($_[0], 0); +} + +# +# lock_retrieve +# +# Same as retrieve, but with advisory locking. +# +sub lock_retrieve { + _retrieve($_[0], 1); +} + +# Internal retrieve routine +sub _retrieve { + my ($file, $use_locking) = @_; local *FILE; - open(FILE, "$file") || logcroak "can't open $file: $!"; + open(FILE, $file) || logcroak "can't open $file: $!"; binmode FILE; # Archaic systems... my $self; my $da = $@; # Could be from exception handler + if ($use_locking) { + flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!"; + # Unlocking will happen when FILE is closed + } eval { $self = pretrieve(*FILE) }; # Call C routine close(FILE); logcroak $@ if $@ =~ s/\.?\n$/,/; @@ -248,6 +307,12 @@ Storable - persistency for perl data structures # Deep (recursive) cloning $cloneref = dclone($ref); + # Advisory locking + use Storable qw(lock_store lock_nstore lock_retrieve) + lock_store \%table, 'file'; + lock_nstore \%table, 'file'; + $hashref = lock_retrieve('file'); + =head1 DESCRIPTION The Storable package brings persistency to your perl data structures @@ -286,7 +351,9 @@ multiple platforms, or when storing on a socket known to be remotely connected. The routines to call have an initial C prefix for I, as in C and C. At retrieval time, your data will be correctly restored so you don't have to know whether you're restoring -from native or network ordered data. +from native or network ordered data. Double values are stored stringified +to ensure portability as well, at the slight risk of loosing some precision +in the last decimals. When using C, objects are retrieved in sequence, one object (i.e. one recursive tree) per associated C. @@ -321,6 +388,24 @@ Storable provides you with a C interface which does not create that intermediary scalar but instead freezes the structure in some internal memory space and then immediatly thaws it out. +=head1 ADVISORY LOCKING + +The C and C routine are equivalent to C +and C, only they get an exclusive lock on the file before +writing. Likewise, C performs as C, but also +gets a shared lock on the file before reading. + +Like with any advisory locking scheme, the protection only works if +you systematically use C and C. If one +side of your application uses C whilst the other uses C, +you will get no protection at all. + +The internal advisory locking is implemented using Perl's flock() routine. +If your system does not support any form of flock(), or if you share +your files across NFS, you might wish to use other forms of locking by +using modules like LockFile::Simple which lock a file using a filesystem +entry, instead of locking the file descriptor. + =head1 SPEED The heart of Storable is written in C for decent speed. Extra low-level @@ -574,6 +659,19 @@ if you happen to use your numbers as strings between two freezing operations on the same data structures, you will get different results. +When storing doubles in network order, their value is stored as text. +However, you should also not expect non-numeric floating-point values +such as infinity and "not a number" to pass successfully through a +nstore()/retrieve() pair. + +As Storable neither knows nor cares about character sets (although it +does know that characters may be more than eight bits wide), any difference +in the interpretation of character codes between a host and a target +system is your problem. In particular, if host and target use different +code points to represent the characters used in the text representation +of floating-point numbers, you will not be able be able to exchange +floating-point data, even with nstore(). + =head1 CREDITS Thank you to (in chronological order): @@ -588,6 +686,9 @@ Thank you to (in chronological order): Marc Lehmann Justin Banks Jarkko Hietaniemi (AGAIN, as perl 5.7.0 Pumpkin!) + Salvador Ortiz Garcia + Dominic Dunlop + Erik Haugan for their bug reports, suggestions and contributions. diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 9ace909..1c412b5 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -54,7 +54,10 @@ #define PL_sv_yes sv_yes #define PL_sv_no sv_no #define PL_sv_undef sv_undef +#if (SUBVERSION <= 4) /* 5.004_04 has been reported to lack newSVpvn */ +#define newSVpvn newSVpv #endif +#endif /* PATCHLEVEL <= 4 */ #ifndef HvSHAREKEYS_off #define HvSHAREKEYS_off(hv) /* Ignore */ #endif @@ -111,7 +114,7 @@ typedef double NV; /* Older perls lack the NV type */ #define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */ #define SX_OBJECT C(0) /* Already stored object */ -#define SX_LSCALAR C(1) /* Scalar (string) forthcoming (length, data) */ +#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */ #define SX_ARRAY C(2) /* Array forthcominng (size, item list) */ #define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */ #define SX_REF C(4) /* Reference to object forthcoming */ @@ -120,7 +123,7 @@ typedef double NV; /* Older perls lack the NV type */ #define SX_DOUBLE C(7) /* Double forthcoming */ #define SX_BYTE C(8) /* (signed) byte forthcoming */ #define SX_NETINT C(9) /* Integer in network order forthcoming */ -#define SX_SCALAR C(10) /* Scalar (small) forthcoming (length, data) */ +#define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */ #define SX_TIED_ARRAY C(11) /* Tied array forthcoming */ #define SX_TIED_HASH C(12) /* Tied hash forthcoming */ #define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */ @@ -133,7 +136,9 @@ typedef double NV; /* Older perls lack the NV type */ #define SX_OVERLOAD C(20) /* Overloaded reference */ #define SX_TIED_KEY C(21) /* Tied magic key forthcoming */ #define SX_TIED_IDX C(22) /* Tied magic index forthcoming */ -#define SX_ERROR C(23) /* Error */ +#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */ +#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */ +#define SX_ERROR C(25) /* Error */ /* * Those are only used to retrieve "old" pre-0.6 binary images. @@ -220,6 +225,12 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ #define MY_VERSION "Storable(" XS_VERSION ")" +/* + * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include + * files remap tainted and dirty when threading is enabled. That's bad for + * perl to remap such common words. -- RAM, 29/09/00 + */ + typedef struct stcxt { int entry; /* flags recursion */ int optype; /* type of traversal operation */ @@ -231,9 +242,10 @@ typedef struct stcxt { I32 tagnum; /* incremented at store time for each seen object */ I32 classnum; /* incremented at store time for each seen classname */ int netorder; /* true if network order used */ + int s_tainted; /* true if input source is tainted, at retrieve time */ int forgive_me; /* whether to be forgiving... */ int canonical; /* whether to store hashes sorted by key */ - int dirty; /* context is dirty due to CROAK() -- can be cleaned */ + int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */ struct extendable keybuf; /* for hash key retrieval */ struct extendable membuf; /* for memory store/retrieve operations */ PerlIO *fio; /* where I/O are performed, NULL for memory */ @@ -298,7 +310,7 @@ static stcxt_t *Context_ptr = &Context; * but the topmost context stacked. */ -#define CROAK(x) do { cxt->dirty = 1; croak x; } while (0) +#define CROAK(x) do { cxt->s_dirty = 1; croak x; } while (0) /* * End of "thread-safe" related definitions. @@ -546,7 +558,7 @@ static char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ static char magicstr[] = "pst0"; /* Used as a magic number */ #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 2 /* Binary minor "version" */ +#define STORABLE_BIN_MINOR 3 /* Binary minor "version" */ /* * Useful store shortcuts... @@ -593,20 +605,35 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ return -1; \ } while (0) -#define STORE_SCALAR(pv, len) do { \ +#define STORE_PV_LEN(pv, len, small, large) do { \ if (len <= LG_SCALAR) { \ unsigned char clen = (unsigned char) len; \ - PUTMARK(SX_SCALAR); \ + PUTMARK(small); \ PUTMARK(clen); \ if (len) \ WRITE(pv, len); \ } else { \ - PUTMARK(SX_LSCALAR); \ + PUTMARK(large); \ WLEN(len); \ WRITE(pv, len); \ } \ } while (0) +#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) + +/* + * Conditional UTF8 support. + * On non-UTF8 perls, UTF8 strings are returned as normal strings. + * + */ +#ifdef SvUTF8_on +#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR) +#else +#define SvUTF8(sv) 0 +#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl")) +#define SvUTF8_on(sv) CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) +#endif + /* * Store undef in arrays and hashes without recursing through store(). */ @@ -730,6 +757,7 @@ static int (*sv_store[])() = { */ static SV *retrieve_lscalar(stcxt_t *cxt); +static SV *retrieve_lutf8str(stcxt_t *cxt); static SV *old_retrieve_array(stcxt_t *cxt); static SV *old_retrieve_hash(stcxt_t *cxt); static SV *retrieve_ref(stcxt_t *cxt); @@ -739,6 +767,7 @@ static SV *retrieve_double(stcxt_t *cxt); static SV *retrieve_byte(stcxt_t *cxt); static SV *retrieve_netint(stcxt_t *cxt); static SV *retrieve_scalar(stcxt_t *cxt); +static SV *retrieve_utf8str(stcxt_t *cxt); static SV *retrieve_tied_array(stcxt_t *cxt); static SV *retrieve_tied_hash(stcxt_t *cxt); static SV *retrieve_tied_scalar(stcxt_t *cxt); @@ -768,6 +797,8 @@ static SV *(*sv_old_retrieve[])() = { retrieve_other, /* SX_OVERLOADED not supported */ retrieve_other, /* SX_TIED_KEY not supported */ retrieve_other, /* SX_TIED_IDX not supported */ + retrieve_other, /* SX_UTF8STR not supported */ + retrieve_other, /* SX_LUTF8STR not supported */ retrieve_other, /* SX_ERROR */ }; @@ -807,6 +838,8 @@ static SV *(*sv_retrieve[])() = { retrieve_overloaded, /* SX_OVERLOAD */ retrieve_tied_key, /* SX_TIED_KEY */ retrieve_tied_idx, /* SX_TIED_IDX */ + retrieve_utf8str, /* SX_UTF8STR */ + retrieve_lutf8str, /* SX_LUTF8STR */ retrieve_other, /* SX_ERROR */ }; @@ -954,7 +987,7 @@ static void clean_store_context(stcxt_t *cxt) sv_free((SV *) cxt->hook); cxt->entry = 0; - cxt->dirty = 0; + cxt->s_dirty = 0; } /* @@ -962,9 +995,7 @@ static void clean_store_context(stcxt_t *cxt) * * Initialize a new retrieve context for real recursion. */ -static void init_retrieve_context(cxt, optype) -stcxt_t *cxt; -int optype; +static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted) { TRACEME(("init_retrieve_context")); @@ -993,6 +1024,7 @@ int optype; cxt->tagnum = 0; /* Have to count objects... */ cxt->classnum = 0; /* ...and class names as well */ cxt->optype = optype; + cxt->s_tainted = is_tainted; cxt->entry = 1; /* No recursion yet */ } @@ -1001,8 +1033,7 @@ int optype; * * Clean retrieve context by */ -static void clean_retrieve_context(cxt) -stcxt_t *cxt; +static void clean_retrieve_context(stcxt_t *cxt) { TRACEME(("clean_retrieve_context")); @@ -1021,7 +1052,7 @@ stcxt_t *cxt; sv_free((SV *) cxt->hseen); /* optional HV, for backward compat. */ cxt->entry = 0; - cxt->dirty = 0; + cxt->s_dirty = 0; } /* @@ -1034,7 +1065,7 @@ stcxt_t *cxt; { TRACEME(("clean_context")); - ASSERT(cxt->dirty, ("dirty context")); + ASSERT(cxt->s_dirty, ("dirty context")); if (cxt->optype & ST_RETRIEVE) clean_retrieve_context(cxt); @@ -1055,7 +1086,7 @@ stcxt_t *parent_cxt; TRACEME(("allocate_context")); - ASSERT(!parent_cxt->dirty, ("parent context clean")); + ASSERT(!parent_cxt->s_dirty, ("parent context clean")); Newz(0, cxt, 1, stcxt_t); cxt->prev = parent_cxt; @@ -1077,7 +1108,7 @@ stcxt_t *cxt; TRACEME(("free_context")); - ASSERT(!cxt->dirty, ("clean context")); + ASSERT(!cxt->s_dirty, ("clean context")); ASSERT(prev, ("not freeing root context")); if (kbuf) @@ -1499,7 +1530,10 @@ static int store_scalar(stcxt_t *cxt, SV *sv) string: wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ - STORE_SCALAR(pv, wlen); + if (SvUTF8 (sv)) + STORE_UTF8STR(pv, wlen); + else + STORE_SCALAR(pv, wlen); TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")", PTR2UV(sv), SvPVX(sv), (IV)len)); @@ -2048,17 +2082,6 @@ static int store_hook( pv = SvPV(ary[0], len2); /* - * Allocate a class ID if not already done. - */ - - if (!known_class(cxt, class, len, &classnum)) { - TRACEME(("first time we see class %s, ID = %d", class, classnum)); - classnum = -1; /* Mark: we must store classname */ - } else { - TRACEME(("already seen class %s, ID = %d", class, classnum)); - } - - /* * If they returned more than one item, we need to serialize some * extra references if not already done. * @@ -2124,6 +2147,22 @@ static int store_hook( } /* + * Allocate a class ID if not already done. + * + * This needs to be done after the recursion above, since at retrieval + * time, we'll see the inner objects first. Many thanks to + * Salvador Ortiz Garcia who spot that bug and + * proposed the right fix. -- RAM, 15/09/2000 + */ + + if (!known_class(cxt, class, len, &classnum)) { + TRACEME(("first time we see class %s, ID = %d", class, classnum)); + classnum = -1; /* Mark: we must store classname */ + } else { + TRACEME(("already seen class %s, ID = %d", class, classnum)); + } + + /* * Compute leading flags. */ @@ -2597,7 +2636,7 @@ static int do_store( * free up memory for them now. */ - if (cxt->dirty) + if (cxt->s_dirty) clean_context(cxt); /* @@ -2611,7 +2650,7 @@ static int do_store( cxt->entry++; ASSERT(cxt->entry == 1, ("starting new recursion")); - ASSERT(!cxt->dirty, ("clean context")); + ASSERT(!cxt->s_dirty, ("clean context")); /* * Ensure sv is actually a reference. From perl, we called something @@ -3035,7 +3074,8 @@ static SV *retrieve_hook(stcxt_t *cxt) *SvEND(frozen) = '\0'; } (void) SvPOK_only(frozen); /* Validates string pointer */ - SvTAINT(frozen); + if (cxt->s_tainted) /* Is input source tainted? */ + SvTAINT(frozen); TRACEME(("frozen string: %d bytes", len2)); @@ -3429,7 +3469,8 @@ static SV *retrieve_lscalar(stcxt_t *cxt) SvCUR_set(sv, len); /* Record C string length */ *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ (void) SvPOK_only(sv); /* Validate string pointer */ - SvTAINT(sv); /* External data cannot be trusted */ + if (cxt->s_tainted) /* Is input source tainted? */ + SvTAINT(sv); /* External data cannot be trusted */ TRACEME(("large scalar len %"IVdf" '%s'", len, SvPVX(sv))); TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv))); @@ -3488,13 +3529,52 @@ static SV *retrieve_scalar(stcxt_t *cxt) } (void) SvPOK_only(sv); /* Validate string pointer */ - SvTAINT(sv); /* External data cannot be trusted */ + if (cxt->s_tainted) /* Is input source tainted? */ + SvTAINT(sv); /* External data cannot be trusted */ TRACEME(("ok (retrieve_scalar at 0x%"UVxf")", PTR2UV(sv))); return sv; } /* + * retrieve_utf8str + * + * Like retrieve_scalar(), but tag result as utf8. + * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. + */ +static SV *retrieve_utf8str(stcxt_t *cxt) +{ + SV *sv; + + TRACEME(("retrieve_utf8str")); + + sv = retrieve_scalar(cxt); + if (sv) + SvUTF8_on(sv); + + return sv; +} + +/* + * retrieve_lutf8str + * + * Like retrieve_lscalar(), but tag result as utf8. + * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. + */ +static SV *retrieve_lutf8str(stcxt_t *cxt) +{ + SV *sv; + + TRACEME(("retrieve_lutf8str")); + + sv = retrieve_lscalar(cxt); + if (sv) + SvUTF8_on(sv); + + return sv; +} + +/* * retrieve_integer * * Retrieve defined integer. @@ -4220,6 +4300,7 @@ static SV *do_retrieve( { dSTCXT; SV *sv; + int is_tainted; /* Is input source tainted? */ struct extendable msave; /* Where potentially valid mbuf is saved */ TRACEME(("do_retrieve (optype = 0x%x)", optype)); @@ -4242,7 +4323,7 @@ static SV *do_retrieve( * free up memory for them now. */ - if (cxt->dirty) + if (cxt->s_dirty) clean_context(cxt); /* @@ -4256,7 +4337,7 @@ static SV *do_retrieve( cxt->entry++; ASSERT(cxt->entry == 1, ("starting new recursion")); - ASSERT(!cxt->dirty, ("clean context")); + ASSERT(!cxt->s_dirty, ("clean context")); /* * Prepare context. @@ -4291,7 +4372,19 @@ static SV *do_retrieve( TRACEME(("data stored in %s format", cxt->netorder ? "net order" : "native")); - init_retrieve_context(cxt, optype); + /* + * Check whether input source is tainted, so that we don't wrongly + * taint perfectly good values... + * + * We assume file input is always tainted. If both `f' and `in' are + * NULL, then we come from dclone, and tainted is already filled in + * the context. That's a kludge, but the whole dclone() thing is + * already quite a kludge anyway! -- RAM, 15/09/2000. + */ + + is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted); + TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted")); + init_retrieve_context(cxt, optype, is_tainted); ASSERT(is_retrieving(), ("within retrieve operation")); @@ -4421,7 +4514,7 @@ SV *dclone(SV *sv) * free up memory for them now. */ - if (cxt->dirty) + if (cxt->s_dirty) clean_context(cxt); /* @@ -4444,14 +4537,23 @@ SV *dclone(SV *sv) * Now, `cxt' may refer to a new context. */ - ASSERT(!cxt->dirty, ("clean context")); + ASSERT(!cxt->s_dirty, ("clean context")); ASSERT(!cxt->entry, ("entry will not cause new context allocation")); size = MBUF_SIZE(); TRACEME(("dclone stored %d bytes", size)); - MBUF_INIT(size); - out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE); /* Will free non-root context */ + + /* + * Since we're passing do_retrieve() both a NULL file and sv, we need + * to pre-compute the taintedness of the input by setting cxt->tainted + * to whatever state our own input string was. -- RAM, 15/09/2000 + * + * do_retrieve() will free non-root context. + */ + + cxt->s_tainted = SvTAINTED(sv); + out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE); TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out))); diff --git a/t/lib/st-lock.t b/t/lib/st-lock.t new file mode 100644 index 0000000..0bb4a33 --- /dev/null +++ b/t/lib/st-lock.t @@ -0,0 +1,46 @@ +#!./perl + +# $Id: lock.t,v 1.0.1.1 2000/09/28 21:44:06 ram Exp $ +# +# @COPYRIGHT@ +# +# $Log: lock.t,v $ +# Revision 1.0.1.1 2000/09/28 21:44:06 ram +# patch2: created. +# +# + +sub BEGIN { + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } + require 'lib/st-dump.pl'; +} + +sub ok; + +use Storable qw(lock_store lock_retrieve); + +print "1..5\n"; + +@a = ('first', undef, 3, -4, -3.14159, 456, 4.5); + +# +# We're just ensuring things work, we're not validating locking. +# + +ok 1, defined lock_store(\@a, 'store'); +ok 2, $dumped = &dump(\@a); + +$root = lock_retrieve('store'); +ok 3, ref $root eq 'ARRAY'; +ok 4, @a == @$root; +ok 5, &dump($root) eq $dumped; + +unlink 't/store'; + diff --git a/t/lib/st-recurse.t b/t/lib/st-recurse.t index 5bd8e24..dcf6d1a 100644 --- a/t/lib/st-recurse.t +++ b/t/lib/st-recurse.t @@ -1,6 +1,6 @@ #!./perl -# $Id: recurse.t,v 1.0 2000/09/01 19:40:42 ram Exp $ +# $Id: recurse.t,v 1.0.1.1 2000/09/17 16:48:05 ram Exp $ # # 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.1 2000/09/17 16:48:05 ram +# patch1: added test case for store hook bug +# +# $Log: recurse.t,v $ # Revision 1.0 2000/09/01 19:40:42 ram # Baseline for first official release. # @@ -28,7 +32,7 @@ sub ok; use Storable qw(freeze thaw dclone); -print "1..23\n"; +print "1..28\n"; package OBJ_REAL; @@ -181,3 +185,51 @@ ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX; ok 22, !Storable::is_storing; ok 23, !Storable::is_retrieving; + +# +# The following was a test-case that Salvador Ortiz Garcia +# sent me, along with a proposed fix. +# + +package Foo; + +sub new { + my $class = shift; + my $dat = shift; + return bless {dat => $dat}, $class; +} + +package Bar; +sub new { + my $class = shift; + return bless { + a => 'dummy', + b => [ + Foo->new(1), + Foo->new(2), # Second instance of a Foo + ] + }, $class; +} + +sub STORABLE_freeze { + my($self,$clonning) = @_; + return "$self->{a}", $self->{b}; +} + +sub STORABLE_thaw { + my($self,$clonning,$dummy,$o) = @_; + $self->{a} = $dummy; + $self->{b} = $o; +} + +package main; + +my $bar = new Bar; +my $bar2 = thaw freeze $bar; + +ok 24, ref($bar2) eq 'Bar'; +ok 25, ref($bar->{b}[0]) eq 'Foo'; +ok 26, ref($bar->{b}[1]) eq 'Foo'; +ok 27, ref($bar2->{b}[0]) eq 'Foo'; +ok 28, ref($bar2->{b}[1]) eq 'Foo'; + diff --git a/t/lib/st-utf8.t b/t/lib/st-utf8.t new file mode 100644 index 0000000..2160308 --- /dev/null +++ b/t/lib/st-utf8.t @@ -0,0 +1,40 @@ +#!./perl + +# $Id: utf8.t,v 1.0.1.2 2000/09/28 21:44:17 ram Exp $ +# +# @COPYRIGHT@ +# +# $Log: utf8.t,v $ +# Revision 1.0.1.2 2000/09/28 21:44:17 ram +# patch2: fixed stupid typo +# +# Revision 1.0.1.1 2000/09/17 16:48:12 ram +# patch1: created. +# +# + +sub BEGIN { + if ($] < 5.006) { + print "1..0 # Skip: no utf8 support\n"; + exit 0; + } + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } + require 'lib/st-dump.pl'; +} + +sub ok; + +use Storable qw(thaw freeze); + +print "1..1\n"; + +$x = chr(1234); +ok 1, $x eq ${thaw freeze \$x}; +