This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Storable 1.0.3, from Raphael Manfredi.
authorJarkko Hietaniemi <jhi@iki.fi>
Tue, 3 Oct 2000 11:20:37 +0000 (11:20 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Tue, 3 Oct 2000 11:20:37 +0000 (11:20 +0000)
p4raw-id: //depot/perl@7132

MANIFEST
ext/Storable/ChangeLog
ext/Storable/Storable.pm
ext/Storable/Storable.xs
t/lib/st-lock.t [new file with mode: 0644]
t/lib/st-recurse.t
t/lib/st-utf8.t [new file with mode: 0644]

index 19dafa5..de3b320 100644 (file)
--- 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
index bb24eb7..049ce29 100644 (file)
@@ -1,3 +1,48 @@
+Fri Sep 29 21:52:29 MEST 2000   Raphael Manfredi <Raphael_Manfredi@pobox.com>
+
+. 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 <Raphael_Manfredi@pobox.com>
+
+. 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 <erik@solbors.no>.
+
+       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 <Raphael_Manfredi@pobox.com>
+
+. 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 <Raphael_Manfredi@pobox.com>
 
        First official release Storable 1.0, for inclusion in perl 5.7.0.
index 9960dc8..76c3209 100644 (file)
@@ -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<n> prefix for I<network>,
 as in C<nstore> and C<nstore_fd>. 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<fd_retrieve>, objects are retrieved in sequence, one
 object (i.e. one recursive tree) per associated C<store_fd>.
@@ -321,6 +388,24 @@ Storable provides you with a C<dclone> 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<lock_store> and C<lock_nstore> routine are equivalent to C<store>
+and C<nstore>, only they get an exclusive lock on the file before
+writing.  Likewise, C<lock_retrieve> performs as C<retrieve>, 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<lock_store> and C<lock_retrieve>.  If one
+side of your application uses C<store> whilst the other uses C<lock_retrieve>,
+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 <pcg@opengroup.org>
        Justin Banks <justinb@wamnet.com>
        Jarkko Hietaniemi <jhi@iki.fi> (AGAIN, as perl 5.7.0 Pumpkin!)
+       Salvador Ortiz Garcia <sog@msg.com.mx>
+       Dominic Dunlop <domo@computer.org>
+       Erik Haugan <erik@solbors.no>
 
 for their bug reports, suggestions and contributions.
 
index 9ace909..1c412b5 100644 (file)
 #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 <sog@msg.com.mx> 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 (file)
index 0000000..0bb4a33
--- /dev/null
@@ -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';
+
index 5bd8e24..dcf6d1a 100644 (file)
@@ -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 <sog@msg.com.mx>
+# 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 (file)
index 0000000..2160308
--- /dev/null
@@ -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};
+