This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[patch] rid local_patches warnings
[perl5.git] / ext / Storable / Storable.xs
diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index 1efbc0d..6663998 100644 (file)
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -3,34 +3,56 @@
  */
 
 /*
  */
 
 /*
- * $Id: Storable.xs,v 0.7.1.2 2000/08/14 07:19:27 ram Exp $
+ * $Id: Storable.xs,v 1.0.1.8 2001/03/15 00:20:55 ram Exp $
  *
  *  Copyright (c) 1995-2000, Raphael Manfredi
  *  
  *
  *  Copyright (c) 1995-2000, Raphael Manfredi
  *  
- *  You may redistribute only under the terms of the Artistic License,
- *  as specified in the README file that comes with the distribution.
+ *  You may redistribute only under the same terms as Perl 5, as specified
+ *  in the README file that comes with the distribution.
  *
  * $Log: Storable.xs,v $
  *
  * $Log: Storable.xs,v $
- * Revision 0.7.1.2  2000/08/14 07:19:27  ram
- * patch2: added a refcnt dec in retrieve_tied_key()
+ * Revision 1.0.1.8  2001/03/15 00:20:55  ram
+ * patch11: last version was wrongly compiling with assertions on
  *
  *
- * Revision 0.7.1.1  2000/08/13 20:10:06  ram
- * patch1: was wrongly optimizing for "undef" values in hashes
- * patch1: added support for ref to tied items in hash/array
- * patch1: added overloading support
+ * Revision 1.0.1.7  2001/02/17 12:25:26  ram
+ * patch8: now bless objects ASAP at retrieve time
+ * patch8: added support for blessed ref to tied structures
  *
  *
- * Revision 0.7  2000/08/03 22:04:44  ram
- * Baseline for second beta release.
+ * Revision 1.0.1.6  2001/01/03 09:40:40  ram
+ * patch7: prototype and casting cleanup
+ * patch7: trace offending package when overloading cannot be restored
+ * patch7: made context cleanup safer to avoid dup freeing
+ *
+ * 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
+ *
+ * Revision 1.0.1.3  2000/09/29 19:49:57  ram
+ * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp
+ *
+ * Revision 1.0.1.2  2000/09/28 21:43:10  ram
+ * patch2: perls before 5.004_04 lack newSVpvn
+ *
+ * Revision 1.0.1.1  2000/09/17 16:47:49  ram
+ * patch1: now only taint retrieved data when source was tainted
+ * patch1: added support for UTF-8 strings
+ * patch1: fixed store hook bug: was allocating class id too soon
+ *
+ * Revision 1.0  2000/09/01 19:40:41  ram
+ * Baseline for first official release.
  *
  */
 
 #include <EXTERN.h>
 #include <perl.h>
  *
  */
 
 #include <EXTERN.h>
 #include <perl.h>
-#include <patchlevel.h>                /* Perl's one, needed since 5.6 */
 #include <XSUB.h>
 
 #include <XSUB.h>
 
-/*#define DEBUGME /* Debug mode, turns assertions on as well */
-/*#define DASSERT /* Assertion mode */
+#if 0
+#define DEBUGME /* Debug mode, turns assertions on as well */
+#define DASSERT /* Assertion mode */
+#endif
 
 /*
  * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined
 
 /*
  * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined
@@ -50,6 +72,10 @@
 /*
  * Earlier versions of perl might be used, we can't assume they have the latest!
  */
 /*
  * Earlier versions of perl might be used, we can't assume they have the latest!
  */
+
+#ifndef PERL_VERSION           /* For perls < 5.6 */
+#include <patchlevel.h>
+#define PERL_VERSION PATCHLEVEL
 #ifndef newRV_noinc
 #define newRV_noinc(sv)                ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
 #endif
 #ifndef newRV_noinc
 #define newRV_noinc(sv)                ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
 #endif
@@ -57,19 +83,55 @@
 #define PL_sv_yes      sv_yes
 #define PL_sv_no       sv_no
 #define PL_sv_undef    sv_undef
 #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
+#endif                                         /* PATCHLEVEL <= 4 */
 #ifndef HvSHAREKEYS_off
 #define HvSHAREKEYS_off(hv)    /* Ignore */
 #endif
 #ifndef HvSHAREKEYS_off
 #define HvSHAREKEYS_off(hv)    /* Ignore */
 #endif
+#ifndef AvFILLp                                /* Older perls (<=5.003) lack AvFILLp */
+#define AvFILLp AvFILL
+#endif
+typedef double NV;                     /* Older perls lack the NV type */
+#define        IVdf            "ld"    /* Various printf formats for Perl types */
+#define        UVuf            "lu"
+#define        UVof            "lo"
+#define        UVxf            "lx"
+#define INT2PTR(t,v) (t)(IV)(v)
+#define PTR2UV(v)    (unsigned long)(v)
+#endif                                         /* PERL_VERSION -- perls < 5.6 */
+
+#ifndef NVef                           /* The following were not part of perl 5.6 */
+#if defined(USE_LONG_DOUBLE) && \
+       defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+#define NVef           PERL_PRIeldbl
+#define NVff           PERL_PRIfldbl
+#define NVgf           PERL_PRIgldbl
+#else
+#define        NVef            "e"
+#define        NVff            "f"
+#define        NVgf            "g"
+#endif
+#endif
 
 #ifdef DEBUGME
 
 #ifdef DEBUGME
+
 #ifndef DASSERT
 #define DASSERT
 #endif
 #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)
 #else
 #define TRACEME(x)
-#endif
+#endif /* DEBUGME */
 
 #ifdef DASSERT
 #define ASSERT(x,y)    do {                                                                    \
 
 #ifdef DASSERT
 #define ASSERT(x,y)    do {                                                                    \
@@ -90,7 +152,7 @@
 #define C(x) ((char) (x))      /* For markers with dynamic retrieval handling */
 
 #define SX_OBJECT      C(0)    /* Already stored object */
 #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 */
 #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 */
@@ -99,7 +161,7 @@
 #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_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 */
 #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 */
@@ -112,7 +174,9 @@
 #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_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.
 
 /*
  * Those are only used to retrieve "old" pre-0.6 binary images.
@@ -199,20 +263,28 @@ typedef unsigned long stag_t;     /* Used by pre-0.6 binary format */
 
 #define MY_VERSION "Storable(" XS_VERSION ")"
 
 
 #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 */
     HV *hseen;                 /* which objects have been seen, store time */
 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 */
     HV *hook;                  /* cache for hook methods per class name */
     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 */
     HV *hook;                  /* cache for hook methods per class name */
-    I32 tagnum;                        /* incremented at store time for each seen object */
-    I32 classnum;              /* incremented at store time for each seen classname */
+    IV tagnum;                 /* incremented at store time for each seen object */
+    IV classnum;               /* incremented at store time for each seen classname */
     int netorder;              /* true if network order used */
     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 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 */
     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 */
@@ -234,8 +306,8 @@ typedef struct stcxt {
 #endif /* < perl5.004_68 */
 
 #define dSTCXT_PTR(T,name)                                                     \
 #endif /* < perl5.004_68 */
 
 #define dSTCXT_PTR(T,name)                                                     \
-       T name = (T)(perinterp_sv && SvIOK(perinterp_sv)\
-                               ? SvIVX(perinterp_sv) : NULL)
+       T name = (perinterp_sv && SvIOK(perinterp_sv)   \
+                               ? INT2PTR(T, SvIVX(perinterp_sv)) : (T) 0)
 #define dSTCXT                                                                         \
        dSTCXT_SV;                                                                              \
        dSTCXT_PTR(stcxt_t *, cxt)
 #define dSTCXT                                                                         \
        dSTCXT_SV;                                                                              \
        dSTCXT_PTR(stcxt_t *, cxt)
@@ -243,11 +315,11 @@ typedef struct stcxt {
 #define INIT_STCXT                                                                     \
       dSTCXT;                                                                          \
       Newz(0, cxt, 1, stcxt_t);                                                \
 #define INIT_STCXT                                                                     \
       dSTCXT;                                                                          \
       Newz(0, cxt, 1, stcxt_t);                                                \
-      sv_setiv(perinterp_sv, (IV) cxt)
+      sv_setiv(perinterp_sv, PTR2IV(cxt))
 
 #define SET_STCXT(x) do {                                                      \
        dSTCXT_SV;                                                                              \
 
 #define SET_STCXT(x) do {                                                      \
        dSTCXT_SV;                                                                              \
-       sv_setiv(perinterp_sv, (IV) (x));                               \
+       sv_setiv(perinterp_sv, PTR2IV(x));                              \
 } while (0)
 
 #else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
 } while (0)
 
 #else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
@@ -277,13 +349,44 @@ static stcxt_t *Context_ptr = &Context;
  * but the topmost context stacked.
  */
 
  * 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.
  */
 
 /*
 
 /*
  * End of "thread-safe" related definitions.
  */
 
 /*
+ * LOW_32BITS
+ *
+ * Keep only the low 32 bits of a pointer (used for tags, which are not
+ * really pointers).
+ */
+
+#if PTRSIZE <= 4
+#define LOW_32BITS(x)  ((I32) (x))
+#else
+#define LOW_32BITS(x)  ((I32) ((unsigned long) (x) & 0xffffffffUL))
+#endif
+
+/*
+ * oI, oS, oC
+ *
+ * Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
+ * Used in the WLEN and RLEN macros.
+ */
+
+#if INTSIZE > 4
+#define oI(x)  ((I32 *) ((char *) (x) + 4))
+#define oS(x)  ((x) - 4)
+#define oC(x)  (x = 0)
+#define CRAY_HACK
+#else
+#define oI(x)  (x)
+#define oS(x)  (x)
+#define oC(x)
+#endif
+
+/*
  * key buffer handling
  */
 #define kbuf   (cxt->keybuf).arena
  * key buffer handling
  */
 #define kbuf   (cxt->keybuf).arena
@@ -370,6 +473,16 @@ static stcxt_t *Context_ptr = &Context;
                return (SV *) 0;                        \
 } while (0)
 
                return (SV *) 0;                        \
 } while (0)
 
+#ifdef CRAY_HACK
+#define MBUF_GETINT(x) do {                            \
+       oC(x);                                                          \
+       if ((mptr + 4) <= mend) {                       \
+               memcpy(oI(&x), mptr, 4);                \
+               mptr += 4;                                              \
+       } else                                                          \
+               return (SV *) 0;                                \
+} while (0)
+#else
 #define MBUF_GETINT(x) do {                            \
        if ((mptr + sizeof(int)) <= mend) {     \
                if (int_aligned(mptr))                  \
 #define MBUF_GETINT(x) do {                            \
        if ((mptr + sizeof(int)) <= mend) {     \
                if (int_aligned(mptr))                  \
@@ -380,6 +493,7 @@ static stcxt_t *Context_ptr = &Context;
        } else                                                          \
                return (SV *) 0;                                \
 } while (0)
        } else                                                          \
                return (SV *) 0;                                \
 } while (0)
+#endif
 
 #define MBUF_READ(x,s) do {                    \
        if ((mptr + (s)) <= mend) {             \
 
 #define MBUF_READ(x,s) do {                    \
        if ((mptr + (s)) <= mend) {             \
@@ -408,6 +522,13 @@ static stcxt_t *Context_ptr = &Context;
        }                                                               \
 } while (0)
 
        }                                                               \
 } while (0)
 
+#ifdef CRAY_HACK
+#define MBUF_PUTINT(i) do {                    \
+       MBUF_CHK(4);                                    \
+       memcpy(mptr, oI(&i), 4);                \
+       mptr += 4;                                              \
+} while (0)
+#else
 #define MBUF_PUTINT(i) do {                    \
        MBUF_CHK(sizeof(int));                  \
        if (int_aligned(mptr))                  \
 #define MBUF_PUTINT(i) do {                    \
        MBUF_CHK(sizeof(int));                  \
        if (int_aligned(mptr))                  \
@@ -416,6 +537,7 @@ static stcxt_t *Context_ptr = &Context;
                memcpy(mptr, &i, sizeof(int));  \
        mptr += sizeof(int);                    \
 } while (0)
                memcpy(mptr, &i, sizeof(int));  \
        mptr += sizeof(int);                    \
 } while (0)
+#endif
 
 #define MBUF_WRITE(x,s) do {           \
        MBUF_CHK(s);                                    \
 
 #define MBUF_WRITE(x,s) do {           \
        MBUF_CHK(s);                                    \
@@ -424,19 +546,6 @@ static stcxt_t *Context_ptr = &Context;
 } while (0)
 
 /*
 } while (0)
 
 /*
- * LOW_32BITS
- *
- * Keep only the low 32 bits of a pointer (used for tags, which are not
- * really pointers).
- */
-
-#if PTRSIZE <= 4
-#define LOW_32BITS(x)  ((I32) (x))
-#else
-#define LOW_32BITS(x)  ((I32) ((unsigned long) (x) & 0xffffffffUL))
-#endif
-
-/*
  * Possible return values for sv_type().
  */
 
  * Possible return values for sv_type().
  */
 
@@ -461,12 +570,21 @@ static stcxt_t *Context_ptr = &Context;
 #define SHF_HAS_LIST           0x80
 
 /*
 #define SHF_HAS_LIST           0x80
 
 /*
- * Types for SX_HOOK (2 bits).
+ * Types for SX_HOOK (last 2 bits in flags).
  */
 
 #define SHT_SCALAR                     0
 #define SHT_ARRAY                      1
 #define SHT_HASH                       2
  */
 
 #define SHT_SCALAR                     0
 #define SHT_ARRAY                      1
 #define SHT_HASH                       2
+#define SHT_EXTRA                      3               /* Read extra byte for type */
+
+/*
+ * The following are held in the "extra byte"...
+ */
+
+#define SHT_TSCALAR                    4               /* 4 + 0 -- tied scalar */
+#define SHT_TARRAY                     5               /* 4 + 1 -- tied array */
+#define SHT_THASH                      6               /* 4 + 2 -- tied hash */
 
 /*
  * Before 0.6, the magic string was "perl-store" (binary version number 0).
 
 /*
  * Before 0.6, the magic string was "perl-store" (binary version number 0).
@@ -488,7 +606,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" */
 static char magicstr[] = "pst0";                       /* Used as a magic number */
 
 #define STORABLE_BIN_MAJOR     2                               /* Binary major "version" */
-#define STORABLE_BIN_MINOR     1                               /* Binary minor "version" */
+#define STORABLE_BIN_MINOR     4                               /* Binary minor "version" */
 
 /*
  * Useful store shortcuts...
 
 /*
  * Useful store shortcuts...
@@ -501,28 +619,31 @@ static char magicstr[] = "pst0";                  /* Used as a magic number */
                return -1;                                                      \
 } while (0)
 
                return -1;                                                      \
 } while (0)
 
+#define WRITE_I32(x)   do {                    \
+       ASSERT(sizeof(x) == sizeof(I32), ("writing an I32"));   \
+       if (!cxt->fio)                                          \
+               MBUF_PUTINT(x);                                 \
+       else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
+               return -1;                                      \
+       } while (0)
+
 #ifdef HAS_HTONL
 #define WLEN(x)        do {                            \
        if (cxt->netorder) {                    \
                int y = (int) htonl(x);         \
                if (!cxt->fio)                          \
                        MBUF_PUTINT(y);                 \
 #ifdef HAS_HTONL
 #define WLEN(x)        do {                            \
        if (cxt->netorder) {                    \
                int y = (int) htonl(x);         \
                if (!cxt->fio)                          \
                        MBUF_PUTINT(y);                 \
-               else if (PerlIO_write(cxt->fio, &y, sizeof(y)) != sizeof(y))    \
+               else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \
                        return -1;                              \
        } else {                                                \
                if (!cxt->fio)                          \
                        MBUF_PUTINT(x);                 \
                        return -1;                              \
        } else {                                                \
                if (!cxt->fio)                          \
                        MBUF_PUTINT(x);                 \
-               else if (PerlIO_write(cxt->fio, &x, sizeof(x)) != sizeof(x))    \
+               else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \
                        return -1;                              \
        }                                                               \
 } while (0)
 #else
                        return -1;                              \
        }                                                               \
 } while (0)
 #else
-#define WLEN(x)        do {                            \
-       if (!cxt->fio)                                  \
-               MBUF_PUTINT(x);                         \
-       else if (PerlIO_write(cxt->fio, &x, sizeof(x)) != sizeof(x))    \
-               return -1;                                      \
-       } while (0)
+#define WLEN(x)        WRITE_I32(x)
 #endif
 
 #define WRITE(x,y) do {                                                \
 #endif
 
 #define WRITE(x,y) do {                                                \
@@ -532,20 +653,35 @@ static char magicstr[] = "pst0";                  /* Used as a magic number */
                return -1;                                                      \
        } while (0)
 
                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;       \
        if (len <= LG_SCALAR) {                         \
                unsigned char clen = (unsigned char) len;       \
-               PUTMARK(SX_SCALAR);                             \
+               PUTMARK(small);                                 \
                PUTMARK(clen);                                  \
                if (len)                                                \
                        WRITE(pv, len);                         \
        } else {                                                        \
                PUTMARK(clen);                                  \
                if (len)                                                \
                        WRITE(pv, len);                         \
        } else {                                                        \
-               PUTMARK(SX_LSCALAR);                    \
+               PUTMARK(large);                                 \
                WLEN(len);                                              \
                WRITE(pv, len);                                 \
        }                                                                       \
 } while (0)
 
                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().
  */
 /*
  * Store undef in arrays and hashes without recursing through store().
  */
@@ -564,26 +700,31 @@ static char magicstr[] = "pst0";                  /* Used as a magic number */
 #define GETMARK(x) do {                                                        \
        if (!cxt->fio)                                                          \
                MBUF_GETC(x);                                                   \
 #define GETMARK(x) do {                                                        \
        if (!cxt->fio)                                                          \
                MBUF_GETC(x);                                                   \
-       else if ((x = PerlIO_getc(cxt->fio)) == EOF)    \
+       else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF)      \
                return (SV *) 0;                                                \
 } while (0)
 
                return (SV *) 0;                                                \
 } while (0)
 
-#ifdef HAS_NTOHL
-#define RLEN(x)        do {                                    \
+#define READ_I32(x)    do {                            \
+       ASSERT(sizeof(x) == sizeof(I32), ("reading an I32"));   \
+       oC(x);                                                          \
        if (!cxt->fio)                                          \
                MBUF_GETINT(x);                                 \
        if (!cxt->fio)                                          \
                MBUF_GETINT(x);                                 \
-       else if (PerlIO_read(cxt->fio, &x, sizeof(x)) != sizeof(x))     \
+       else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
                return (SV *) 0;                                \
                return (SV *) 0;                                \
-       if (cxt->netorder)                                      \
-               x = (int) ntohl(x);                             \
 } while (0)
 } while (0)
-#else
+
+#ifdef HAS_NTOHL
 #define RLEN(x)        do {                                    \
 #define RLEN(x)        do {                                    \
+       oC(x);                                                          \
        if (!cxt->fio)                                          \
                MBUF_GETINT(x);                                 \
        if (!cxt->fio)                                          \
                MBUF_GETINT(x);                                 \
-       else if (PerlIO_read(cxt->fio, &x, sizeof(x)) != sizeof(x))     \
+       else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
                return (SV *) 0;                                \
                return (SV *) 0;                                \
+       if (cxt->netorder)                                      \
+               x = (int) ntohl(x);                             \
 } while (0)
 } while (0)
+#else
+#define RLEN(x) READ_I32(x)
 #endif
 
 #define READ(x,y) do {                                         \
 #endif
 
 #define READ(x,y) do {                                         \
@@ -607,14 +748,28 @@ static char magicstr[] = "pst0";                  /* Used as a magic number */
  * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
  * we'll therefore know where it has been retrieved and will be able to
  * share the same reference, as in the original stored memory image.
  * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
  * we'll therefore know where it has been retrieved and will be able to
  * share the same reference, as in the original stored memory image.
+ *
+ * We also need to bless objects ASAP for hooks (which may compute "ref $x"
+ * on the objects given to STORABLE_thaw and expect that to be defined), and
+ * also for overloaded objects (for which we might not find the stash if the
+ * object is not blessed yet--this might occur for overloaded objects that
+ * refer to themselves indirectly: if we blessed upon return from a sub
+ * retrieve(), the SX_OBJECT marker we'd found could not have overloading
+ * restored on it because the underlying object would not be blessed yet!).
+ *
+ * To achieve that, the class name of the last retrieved object is passed down
+ * recursively, and the first SEEN() call for which the class name is not NULL
+ * will bless the object.
  */
  */
-#define SEEN(y) do {                                           \
+#define SEEN(y,c) do {                                         \
        if (!y)                                                                 \
                return (SV *) 0;                                        \
        if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \
                return (SV *) 0;                                        \
        if (!y)                                                                 \
                return (SV *) 0;                                        \
        if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \
                return (SV *) 0;                                        \
-       TRACEME(("aseen(#%d) = 0x%lx (refcnt=%d)", cxt->tagnum-1, \
-               (unsigned long) y, SvREFCNT(y)-1)); \
+       TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \
+                PTR2UV(y), SvREFCNT(y)-1));            \
+       if (c)                                                                  \
+               BLESS((SV *) (y), c);                           \
 } while (0)
 
 /*
 } while (0)
 
 /*
@@ -623,7 +778,7 @@ static char magicstr[] = "pst0";                    /* Used as a magic number */
 #define BLESS(s,p) do {                                        \
        SV *ref;                                                                \
        HV *stash;                                                              \
 #define BLESS(s,p) do {                                        \
        SV *ref;                                                                \
        HV *stash;                                                              \
-       TRACEME(("blessing 0x%lx in %s", (unsigned long) (s), (p))); \
+       TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \
        stash = gv_stashpv((p), TRUE);                  \
        ref = newRV_noinc(s);                                   \
        (void) sv_bless(ref, stash);                    \
        stash = gv_stashpv((p), TRUE);                  \
        ref = newRV_noinc(s);                                   \
        (void) sv_bless(ref, stash);                    \
@@ -632,7 +787,7 @@ static char magicstr[] = "pst0";                    /* Used as a magic number */
 } while (0)
 
 static int store();
 } while (0)
 
 static int store();
-static SV *retrieve();
+static SV *retrieve(stcxt_t *cxt, char *cname);
 
 /*
  * Dynamic dispatching table for SV store.
 
 /*
  * Dynamic dispatching table for SV store.
@@ -645,15 +800,16 @@ static int store_hash(stcxt_t *cxt, HV *hv);
 static int store_tied(stcxt_t *cxt, SV *sv);
 static int store_tied_item(stcxt_t *cxt, SV *sv);
 static int store_other(stcxt_t *cxt, SV *sv);
 static int store_tied(stcxt_t *cxt, SV *sv);
 static int store_tied_item(stcxt_t *cxt, SV *sv);
 static int store_other(stcxt_t *cxt, SV *sv);
-
-static int (*sv_store[])() = {
-       store_ref,                      /* svis_REF */
-       store_scalar,           /* svis_SCALAR */
-       store_array,            /* svis_ARRAY */
-       store_hash,                     /* svis_HASH */
-       store_tied,                     /* svis_TIED */
-       store_tied_item,        /* svis_TIED_ITEM */
-       store_other,            /* svis_OTHER */
+static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
+
+static int (*sv_store[])(stcxt_t *cxt, SV *sv) = {
+       store_ref,                                                                              /* svis_REF */
+       store_scalar,                                                                   /* svis_SCALAR */
+       (int (*)(stcxt_t *cxt, SV *sv)) store_array,    /* svis_ARRAY */
+       (int (*)(stcxt_t *cxt, SV *sv)) store_hash,             /* svis_HASH */
+       store_tied,                                                                             /* svis_TIED */
+       store_tied_item,                                                                /* svis_TIED_ITEM */
+       store_other,                                                                    /* svis_OTHER */
 };
 
 #define SV_STORE(x)    (*sv_store[x])
 };
 
 #define SV_STORE(x)    (*sv_store[x])
@@ -662,22 +818,24 @@ static int (*sv_store[])() = {
  * Dynamic dispatching tables for SV retrieval.
  */
 
  * Dynamic dispatching tables for SV retrieval.
  */
 
-static SV *retrieve_lscalar(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);
-static SV *retrieve_undef(stcxt_t *cxt);
-static SV *retrieve_integer(stcxt_t *cxt);
-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_tied_array(stcxt_t *cxt);
-static SV *retrieve_tied_hash(stcxt_t *cxt);
-static SV *retrieve_tied_scalar(stcxt_t *cxt);
-static SV *retrieve_other(stcxt_t *cxt);
-
-static SV *(*sv_old_retrieve[])() = {
+static SV *retrieve_lscalar(stcxt_t *cxt, char *cname);
+static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname);
+static SV *old_retrieve_array(stcxt_t *cxt, char *cname);
+static SV *old_retrieve_hash(stcxt_t *cxt, char *cname);
+static SV *retrieve_ref(stcxt_t *cxt, char *cname);
+static SV *retrieve_undef(stcxt_t *cxt, char *cname);
+static SV *retrieve_integer(stcxt_t *cxt, char *cname);
+static SV *retrieve_double(stcxt_t *cxt, char *cname);
+static SV *retrieve_byte(stcxt_t *cxt, char *cname);
+static SV *retrieve_netint(stcxt_t *cxt, char *cname);
+static SV *retrieve_scalar(stcxt_t *cxt, char *cname);
+static SV *retrieve_utf8str(stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_array(stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname);
+static SV *retrieve_other(stcxt_t *cxt, char *cname);
+
+static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = {
        0,                      /* SX_OBJECT -- entry unused dynamically */
        retrieve_lscalar,               /* SX_LSCALAR */
        old_retrieve_array,             /* SX_ARRAY -- for pre-0.6 binaries */
        0,                      /* SX_OBJECT -- entry unused dynamically */
        retrieve_lscalar,               /* SX_LSCALAR */
        old_retrieve_array,             /* SX_ARRAY -- for pre-0.6 binaries */
@@ -701,22 +859,24 @@ 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_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 */
 };
 
        retrieve_other,                 /* SX_ERROR */
 };
 
-static SV *retrieve_array(stcxt_t *cxt);
-static SV *retrieve_hash(stcxt_t *cxt);
-static SV *retrieve_sv_undef(stcxt_t *cxt);
-static SV *retrieve_sv_yes(stcxt_t *cxt);
-static SV *retrieve_sv_no(stcxt_t *cxt);
-static SV *retrieve_blessed(stcxt_t *cxt);
-static SV *retrieve_idx_blessed(stcxt_t *cxt);
-static SV *retrieve_hook(stcxt_t *cxt);
-static SV *retrieve_overloaded(stcxt_t *cxt);
-static SV *retrieve_tied_key(stcxt_t *cxt);
-static SV *retrieve_tied_idx(stcxt_t *cxt);
-
-static SV *(*sv_retrieve[])() = {
+static SV *retrieve_array(stcxt_t *cxt, char *cname);
+static SV *retrieve_hash(stcxt_t *cxt, char *cname);
+static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname);
+static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname);
+static SV *retrieve_sv_no(stcxt_t *cxt, char *cname);
+static SV *retrieve_blessed(stcxt_t *cxt, char *cname);
+static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname);
+static SV *retrieve_hook(stcxt_t *cxt, char *cname);
+static SV *retrieve_overloaded(stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_key(stcxt_t *cxt, char *cname);
+static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname);
+
+static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
        0,                      /* SX_OBJECT -- entry unused dynamically */
        retrieve_lscalar,               /* SX_LSCALAR */
        retrieve_array,                 /* SX_ARRAY */
        0,                      /* SX_OBJECT -- entry unused dynamically */
        retrieve_lscalar,               /* SX_LSCALAR */
        retrieve_array,                 /* SX_ARRAY */
@@ -740,13 +900,14 @@ static SV *(*sv_retrieve[])() = {
        retrieve_overloaded,    /* SX_OVERLOAD */
        retrieve_tied_key,              /* SX_TIED_KEY */
        retrieve_tied_idx,              /* SX_TIED_IDX */
        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 */
 };
 
 #define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)])
 
        retrieve_other,                 /* SX_ERROR */
 };
 
 #define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)])
 
-static SV *mbuf2sv();
-static int store_blessed();
+static SV *mbuf2sv(void);
 
 /***
  *** Context management.
 
 /***
  *** Context management.
@@ -757,7 +918,8 @@ static int store_blessed();
  *
  * Called once per "thread" (interpreter) to initialize some global context.
  */
  *
  * Called once per "thread" (interpreter) to initialize some global context.
  */
-static void init_perinterp() {
+static void init_perinterp(void)
+{
     INIT_STCXT;
 
     cxt->netorder = 0;         /* true if network order used */
     INIT_STCXT;
 
     cxt->netorder = 0;         /* true if network order used */
@@ -769,11 +931,11 @@ static void init_perinterp() {
  *
  * Initialize a new store context for real recursion.
  */
  *
  * Initialize a new store context for real recursion.
  */
-static void init_store_context(cxt, f, optype, network_order)
-stcxt_t *cxt;
-PerlIO *f;
-int optype;
-int network_order;
+static void init_store_context(
+       stcxt_t *cxt,
+       PerlIO *f,
+       int optype,
+       int network_order)
 {
        TRACEME(("init_store_context"));
 
 {
        TRACEME(("init_store_context"));
 
@@ -817,7 +979,7 @@ int network_order;
         *
         * It is reported fixed in 5.005, hence the #if.
         */
         *
         * It is reported fixed in 5.005, hence the #if.
         */
-#if PATCHLEVEL < 5
+#if PERL_VERSION >= 5
 #define HBUCKETS       4096                            /* Buckets for %hseen */
        HvMAX(cxt->hseen) = HBUCKETS - 1;       /* keys %hseen = $HBUCKETS; */
 #endif
 #define HBUCKETS       4096                            /* Buckets for %hseen */
        HvMAX(cxt->hseen) = HBUCKETS - 1;       /* keys %hseen = $HBUCKETS; */
 #endif
@@ -832,7 +994,7 @@ int network_order;
 
        cxt->hclass = newHV();                  /* Where seen classnames are stored */
 
 
        cxt->hclass = newHV();                  /* Where seen classnames are stored */
 
-#if PATCHLEVEL < 5
+#if PERL_VERSION >= 5
        HvMAX(cxt->hclass) = HBUCKETS - 1;      /* keys %hclass = $HBUCKETS; */
 #endif
 
        HvMAX(cxt->hclass) = HBUCKETS - 1;      /* keys %hclass = $HBUCKETS; */
 #endif
 
@@ -846,6 +1008,15 @@ int network_order;
         */
 
        cxt->hook = newHV();                    /* Table where hooks are cached */
         */
 
        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 */
 }
 
 /*
 }
 
 /*
@@ -853,8 +1024,7 @@ int network_order;
  *
  * Clean store context by
  */
  *
  * Clean store context by
  */
-static void clean_store_context(cxt)
-stcxt_t *cxt;
+static void clean_store_context(stcxt_t *cxt)
 {
        HE *he;
 
 {
        HE *he;
 
@@ -867,28 +1037,53 @@ stcxt_t *cxt;
         */
 
        hv_iterinit(cxt->hseen);
         */
 
        hv_iterinit(cxt->hseen);
-       while (he = hv_iternext(cxt->hseen))
+       while ((he = hv_iternext(cxt->hseen)))
                HeVAL(he) = &PL_sv_undef;
 
        hv_iterinit(cxt->hclass);
                HeVAL(he) = &PL_sv_undef;
 
        hv_iterinit(cxt->hclass);
-       while (he = hv_iternext(cxt->hclass))
+       while ((he = hv_iternext(cxt->hclass)))
                HeVAL(he) = &PL_sv_undef;
 
        /*
         * And now dispose of them...
                HeVAL(he) = &PL_sv_undef;
 
        /*
         * And now dispose of them...
+        *
+        * The surrounding if() protection has been added because there might be
+        * some cases where this routine is called more than once, during
+        * exceptionnal events.  This was reported by Marc Lehmann when Storable
+        * is executed from mod_perl, and the fix was suggested by him.
+        *              -- RAM, 20/12/2000
         */
 
         */
 
-       hv_undef(cxt->hseen);
-       sv_free((SV *) cxt->hseen);
+       if (cxt->hseen) {
+               HV *hseen = cxt->hseen;
+               cxt->hseen = 0;
+               hv_undef(hseen);
+               sv_free((SV *) hseen);
+       }
 
 
-       hv_undef(cxt->hclass);
-       sv_free((SV *) cxt->hclass);
+       if (cxt->hclass) {
+               HV *hclass = cxt->hclass;
+               cxt->hclass = 0;
+               hv_undef(hclass);
+               sv_free((SV *) hclass);
+       }
 
 
-       hv_undef(cxt->hook);
-       sv_free((SV *) cxt->hook);
+       if (cxt->hook) {
+               HV *hook = cxt->hook;
+               cxt->hook = 0;
+               hv_undef(hook);
+               sv_free((SV *) hook);
+       }
+
+       if (cxt->hook_seen) {
+               AV *hook_seen = cxt->hook_seen;
+               cxt->hook_seen = 0;
+               av_undef(hook_seen);
+               sv_free((SV *) hook_seen);
+       }
 
        cxt->entry = 0;
 
        cxt->entry = 0;
-       cxt->dirty = 0;
+       cxt->s_dirty = 0;
 }
 
 /*
 }
 
 /*
@@ -896,9 +1091,7 @@ stcxt_t *cxt;
  *
  * Initialize a new retrieve context for real recursion.
  */
  *
  * 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"));
 
 {
        TRACEME(("init_retrieve_context"));
 
@@ -927,6 +1120,7 @@ int optype;
        cxt->tagnum = 0;                                /* Have to count objects... */
        cxt->classnum = 0;                              /* ...and class names as well */
        cxt->optype = 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 */
 }
 
        cxt->entry = 1;                                 /* No recursion yet */
 }
 
@@ -935,27 +1129,42 @@ int optype;
  *
  * Clean retrieve context by
  */
  *
  * 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"));
 
        ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
 
 {
        TRACEME(("clean_retrieve_context"));
 
        ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
 
-       av_undef(cxt->aseen);
-       sv_free((SV *) cxt->aseen);
+       if (cxt->aseen) {
+               AV *aseen = cxt->aseen;
+               cxt->aseen = 0;
+               av_undef(aseen);
+               sv_free((SV *) aseen);
+       }
 
 
-       av_undef(cxt->aclass);
-       sv_free((SV *) cxt->aclass);
+       if (cxt->aclass) {
+               AV *aclass = cxt->aclass;
+               cxt->aclass = 0;
+               av_undef(aclass);
+               sv_free((SV *) aclass);
+       }
 
 
-       hv_undef(cxt->hook);
-       sv_free((SV *) cxt->hook);
+       if (cxt->hook) {
+               HV *hook = cxt->hook;
+               cxt->hook = 0;
+               hv_undef(hook);
+               sv_free((SV *) hook);
+       }
 
 
-       if (cxt->hseen)
-               sv_free((SV *) cxt->hseen);             /* optional HV, for backward compat. */
+       if (cxt->hseen) {
+               HV *hseen = cxt->hseen;
+               cxt->hseen = 0;
+               hv_undef(hseen);
+               sv_free((SV *) hseen);          /* optional HV, for backward compat. */
+       }
 
        cxt->entry = 0;
 
        cxt->entry = 0;
-       cxt->dirty = 0;
+       cxt->s_dirty = 0;
 }
 
 /*
 }
 
 /*
@@ -968,12 +1177,14 @@ stcxt_t *cxt;
 {
        TRACEME(("clean_context"));
 
 {
        TRACEME(("clean_context"));
 
-       ASSERT(cxt->dirty, ("dirty context"));
+       ASSERT(cxt->s_dirty, ("dirty context"));
 
        if (cxt->optype & ST_RETRIEVE)
                clean_retrieve_context(cxt);
        else
                clean_store_context(cxt);
 
        if (cxt->optype & ST_RETRIEVE)
                clean_retrieve_context(cxt);
        else
                clean_store_context(cxt);
+
+       ASSERT(!cxt->s_dirty, ("context is clean"));
 }
 
 /*
 }
 
 /*
@@ -989,7 +1200,7 @@ stcxt_t *parent_cxt;
 
        TRACEME(("allocate_context"));
 
 
        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;
 
        Newz(0, cxt, 1, stcxt_t);
        cxt->prev = parent_cxt;
@@ -1011,7 +1222,7 @@ stcxt_t *cxt;
 
        TRACEME(("free_context"));
 
 
        TRACEME(("free_context"));
 
-       ASSERT(!cxt->dirty, ("clean context"));
+       ASSERT(!cxt->s_dirty, ("clean context"));
        ASSERT(prev, ("not freeing root context"));
 
        if (kbuf)
        ASSERT(prev, ("not freeing root context"));
 
        if (kbuf)
@@ -1032,7 +1243,7 @@ stcxt_t *cxt;
  *
  * Tells whether we're in the middle of a store operation.
  */
  *
  * Tells whether we're in the middle of a store operation.
  */
-int is_storing()
+int is_storing(void)
 {
        dSTCXT;
 
 {
        dSTCXT;
 
@@ -1044,7 +1255,7 @@ int is_storing()
  *
  * Tells whether we're in the middle of a retrieve operation.
  */
  *
  * Tells whether we're in the middle of a retrieve operation.
  */
-int is_retrieving()
+int is_retrieving(void)
 {
        dSTCXT;
 
 {
        dSTCXT;
 
@@ -1059,7 +1270,7 @@ int is_retrieving()
  * This is typically out-of-band information that might prove useful
  * to people wishing to convert native to network order data when used.
  */
  * This is typically out-of-band information that might prove useful
  * to people wishing to convert native to network order data when used.
  */
-int last_op_in_netorder()
+int last_op_in_netorder(void)
 {
        dSTCXT;
 
 {
        dSTCXT;
 
@@ -1078,14 +1289,13 @@ int last_op_in_netorder()
  * Returns the routine reference as an SV*, or null if neither the package
  * nor its ancestors know about the method.
  */
  * Returns the routine reference as an SV*, or null if neither the package
  * nor its ancestors know about the method.
  */
-static SV *pkg_fetchmeth(cache, pkg, method)
-HV *cache;
-HV *pkg;
-char *method;
+static SV *pkg_fetchmeth(
+       HV *cache,
+       HV *pkg,
+       char *method)
 {
        GV *gv;
        SV *sv;
 {
        GV *gv;
        SV *sv;
-       SV **svh;
 
        /*
         * The following code is the same as the one performed by UNIVERSAL::can
 
        /*
         * The following code is the same as the one performed by UNIVERSAL::can
@@ -1095,7 +1305,7 @@ char *method;
        gv = gv_fetchmethod_autoload(pkg, method, FALSE);
        if (gv && isGV(gv)) {
                sv = newRV((SV*) GvCV(gv));
        gv = gv_fetchmethod_autoload(pkg, method, FALSE);
        if (gv && isGV(gv)) {
                sv = newRV((SV*) GvCV(gv));
-               TRACEME(("%s->%s: 0x%lx", HvNAME(pkg), method, (unsigned long) sv));
+               TRACEME(("%s->%s: 0x%"UVxf, HvNAME(pkg), method, PTR2UV(sv)));
        } else {
                sv = newSVsv(&PL_sv_undef);
                TRACEME(("%s->%s: not found", HvNAME(pkg), method));
        } else {
                sv = newSVsv(&PL_sv_undef);
                TRACEME(("%s->%s: not found", HvNAME(pkg), method));
@@ -1116,16 +1326,29 @@ char *method;
  *
  * Force cached value to be undef: hook ignored even if present.
  */
  *
  * Force cached value to be undef: hook ignored even if present.
  */
-static void pkg_hide(cache, pkg, method)
-HV *cache;
-HV *pkg;
-char *method;
+static void pkg_hide(
+       HV *cache,
+       HV *pkg,
+       char *method)
 {
        (void) hv_store(cache,
                HvNAME(pkg), strlen(HvNAME(pkg)), newSVsv(&PL_sv_undef), 0);
 }
 
 /*
 {
        (void) hv_store(cache,
                HvNAME(pkg), strlen(HvNAME(pkg)), newSVsv(&PL_sv_undef), 0);
 }
 
 /*
+ * pkg_uncache
+ *
+ * Discard cached value: a whole fetch loop will be retried at next lookup.
+ */
+static void pkg_uncache(
+       HV *cache,
+       HV *pkg,
+       char *method)
+{
+       (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD);
+}
+
+/*
  * pkg_can
  *
  * Our own "UNIVERSAL::can", which caches results.
  * pkg_can
  *
  * Our own "UNIVERSAL::can", which caches results.
@@ -1133,10 +1356,10 @@ char *method;
  * Returns the routine reference as an SV*, or null if the object does not
  * know about the method.
  */
  * Returns the routine reference as an SV*, or null if the object does not
  * know about the method.
  */
-static SV *pkg_can(cache, pkg, method)
-HV *cache;
-HV *pkg;
-char *method;
+static SV *pkg_can(
+       HV *cache,
+       HV *pkg,
+       char *method)
 {
        SV **svh;
        SV *sv;
 {
        SV **svh;
        SV *sv;
@@ -1158,8 +1381,8 @@ char *method;
                        TRACEME(("cached %s->%s: not found", HvNAME(pkg), method));
                        return (SV *) 0;
                } else {
                        TRACEME(("cached %s->%s: not found", HvNAME(pkg), method));
                        return (SV *) 0;
                } else {
-                       TRACEME(("cached %s->%s: 0x%lx", HvNAME(pkg), method,
-                               (unsigned long) sv));
+                       TRACEME(("cached %s->%s: 0x%"UVxf,
+                               HvNAME(pkg), method, PTR2UV(sv)));
                        return sv;
                }
        }
                        return sv;
                }
        }
@@ -1174,12 +1397,12 @@ char *method;
  * Call routine as obj->hook(av) in scalar context.
  * Propagates the single returned value if not called in void context.
  */
  * Call routine as obj->hook(av) in scalar context.
  * Propagates the single returned value if not called in void context.
  */
-static SV *scalar_call(obj, hook, cloning, av, flags)
-SV *obj;
-SV *hook;
-int cloning;
-AV *av;
-I32 flags;
+static SV *scalar_call(
+       SV *obj,
+       SV *hook,
+       int cloning,
+       AV *av,
+       I32 flags)
 {
        dSP;
        int count;
 {
        dSP;
        int count;
@@ -1199,7 +1422,8 @@ I32 flags;
                int i;
                XPUSHs(ary[0]);                                                 /* Frozen string */
                for (i = 1; i < cnt; i++) {
                int i;
                XPUSHs(ary[0]);                                                 /* Frozen string */
                for (i = 1; i < cnt; i++) {
-                       TRACEME(("pushing arg #%d (0x%lx)...", i, (unsigned long) ary[i]));
+                       TRACEME(("pushing arg #%d (0x%"UVxf")...",
+                                i, PTR2UV(ary[i])));
                        XPUSHs(sv_2mortal(newRV(ary[i])));
                }
        }
                        XPUSHs(sv_2mortal(newRV(ary[i])));
                }
        }
@@ -1229,17 +1453,17 @@ I32 flags;
  * Call routine obj->hook(cloning) in list context.
  * Returns the list of returned values in an array.
  */
  * Call routine obj->hook(cloning) in list context.
  * Returns the list of returned values in an array.
  */
-static AV *array_call(obj, hook, cloning)
-SV *obj;
-SV *hook;
-int cloning;
+static AV *array_call(
+       SV *obj,
+       SV *hook,
+       int cloning)
 {
        dSP;
        int count;
        AV *av;
        int i;
 
 {
        dSP;
        int count;
        AV *av;
        int i;
 
-       TRACEME(("arrary_call (cloning=%d), cloning"));
+       TRACEME(("array_call (cloning=%d)", cloning));
 
        ENTER;
        SAVETMPS;
 
        ENTER;
        SAVETMPS;
@@ -1274,11 +1498,11 @@ int cloning;
  *
  * Return true if the class was known, false if the ID was just generated.
  */
  *
  * Return true if the class was known, false if the ID was just generated.
  */
-static int known_class(cxt, name, len, classnum)
-stcxt_t *cxt;
-char *name;            /* Class name */
-int len;               /* Name length */
-I32 *classnum;
+static int known_class(
+       stcxt_t *cxt,
+       char *name,             /* Class name */
+       int len,                /* Name length */
+       I32 *classnum)
 {
        SV **svh;
        HV *hclass = cxt->hclass;
 {
        SV **svh;
        HV *hclass = cxt->hclass;
@@ -1298,11 +1522,10 @@ I32 *classnum;
 
        /*
         * Unknown classname, we need to record it.
 
        /*
         * Unknown classname, we need to record it.
-        * The (IV) cast below is for 64-bit machines, to avoid compiler warnings.
         */
 
        cxt->classnum++;
         */
 
        cxt->classnum++;
-       if (!hv_store(hclass, name, len, (SV*)(IV) cxt->classnum, 0))
+       if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0))
                CROAK(("Unable to record new classname"));
 
        *classnum = cxt->classnum;
                CROAK(("Unable to record new classname"));
 
        *classnum = cxt->classnum;
@@ -1319,11 +1542,9 @@ I32 *classnum;
  * Store a reference.
  * Layout is SX_REF <object> or SX_OVERLOAD <object>.
  */
  * Store a reference.
  * Layout is SX_REF <object> or SX_OVERLOAD <object>.
  */
-static int store_ref(cxt, sv)
-stcxt_t *cxt;
-SV *sv;
+static int store_ref(stcxt_t *cxt, SV *sv)
 {
 {
-       TRACEME(("store_ref (0x%lx)", (unsigned long) sv));
+       TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv)));
 
        /*
         * Follow reference, and check if target is overloaded.
 
        /*
         * Follow reference, and check if target is overloaded.
@@ -1334,7 +1555,7 @@ SV *sv;
        if (SvOBJECT(sv)) {
                HV *stash = (HV *) SvSTASH(sv);
                if (stash && Gv_AMG(stash)) {
        if (SvOBJECT(sv)) {
                HV *stash = (HV *) SvSTASH(sv);
                if (stash && Gv_AMG(stash)) {
-                       TRACEME(("ref (0x%lx) is overloaded", (unsigned long) sv));
+                       TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv)));
                        PUTMARK(SX_OVERLOAD);
                } else
                        PUTMARK(SX_REF);
                        PUTMARK(SX_OVERLOAD);
                } else
                        PUTMARK(SX_REF);
@@ -1355,16 +1576,14 @@ SV *sv;
  * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
  * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
  */
  * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
  * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
  */
-static int store_scalar(cxt, sv)
-stcxt_t *cxt;
-SV *sv;
+static int store_scalar(stcxt_t *cxt, SV *sv)
 {
        IV iv;
        char *pv;
        STRLEN len;
        U32 flags = SvFLAGS(sv);                        /* "cc -O" may put it in register */
 
 {
        IV iv;
        char *pv;
        STRLEN len;
        U32 flags = SvFLAGS(sv);                        /* "cc -O" may put it in register */
 
-       TRACEME(("store_scalar (0x%lx)", (unsigned long) sv));
+       TRACEME(("store_scalar (0x%"UVxf")", PTR2UV(sv)));
 
        /*
         * For efficiency, break the SV encapsulation by peaking at the flags
 
        /*
         * For efficiency, break the SV encapsulation by peaking at the flags
@@ -1377,7 +1596,7 @@ SV *sv;
                        TRACEME(("immortal undef"));
                        PUTMARK(SX_SV_UNDEF);
                } else {
                        TRACEME(("immortal undef"));
                        PUTMARK(SX_SV_UNDEF);
                } else {
-                       TRACEME(("undef at 0x%x", sv));
+                       TRACEME(("undef at 0x%"UVxf, PTR2UV(sv)));
                        PUTMARK(SX_UNDEF);
                }
                return 0;
                        PUTMARK(SX_UNDEF);
                }
                return 0;
@@ -1426,6 +1645,7 @@ SV *sv;
                        goto string;                            /* Share code below */
                }
        } else if (flags & SVp_POK) {           /* SvPOKp(sv) => string */
                        goto string;                            /* Share code below */
                }
        } else if (flags & SVp_POK) {           /* SvPOKp(sv) => string */
+               I32 wlen;                                               /* For 64-bit machines */
                pv = SvPV(sv, len);
 
                /*
                pv = SvPV(sv, len);
 
                /*
@@ -1435,23 +1655,27 @@ SV *sv;
                 */
        string:
 
                 */
        string:
 
-               STORE_SCALAR(pv, len);
-               TRACEME(("ok (scalar 0x%lx '%s', length = %d)",
-                       (unsigned long) sv, SvPVX(sv), len));
+               wlen = (I32) len;                               /* WLEN via STORE_SCALAR expects I32 */
+               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));
 
        } else if (flags & SVp_NOK) {           /* SvNOKp(sv) => double */
 
        } else if (flags & SVp_NOK) {           /* SvNOKp(sv) => double */
-               double nv = SvNV(sv);
+               NV nv = SvNV(sv);
 
                /*
                 * Watch for number being an integer in disguise.
                 */
 
                /*
                 * Watch for number being an integer in disguise.
                 */
-               if (nv == (double) (iv = I_V(nv))) {
-                       TRACEME(("double %lf is actually integer %ld", nv, iv));
+               if (nv == (NV) (iv = I_V(nv))) {
+                       TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv));
                        goto integer;           /* Share code below */
                }
 
                if (cxt->netorder) {
                        goto integer;           /* Share code below */
                }
 
                if (cxt->netorder) {
-                       TRACEME(("double %lf stored as string", nv));
+                       TRACEME(("double %"NVff" stored as string", nv));
                        pv = SvPV(sv, len);
                        goto string;            /* Share code above */
                }
                        pv = SvPV(sv, len);
                        goto string;            /* Share code above */
                }
@@ -1459,7 +1683,7 @@ SV *sv;
                PUTMARK(SX_DOUBLE);
                WRITE(&nv, sizeof(nv));
 
                PUTMARK(SX_DOUBLE);
                WRITE(&nv, sizeof(nv));
 
-               TRACEME(("ok (double 0x%lx, value = %lf)", (unsigned long) sv, nv));
+               TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
 
        } else if (flags & SVp_IOK) {           /* SvIOKp(sv) => integer */
                iv = SvIV(sv);
 
        } else if (flags & SVp_IOK) {           /* SvIOKp(sv) => integer */
                iv = SvIV(sv);
@@ -1480,26 +1704,27 @@ SV *sv;
                        PUTMARK(siv);
                        TRACEME(("small integer stored as %d", siv));
                } else if (cxt->netorder) {
                        PUTMARK(siv);
                        TRACEME(("small integer stored as %d", siv));
                } else if (cxt->netorder) {
-                       int niv;
+                       I32 niv;
 #ifdef HAS_HTONL
 #ifdef HAS_HTONL
-                       niv = (int) htonl(iv);
+                       niv = (I32) htonl(iv);
                        TRACEME(("using network order"));
 #else
                        TRACEME(("using network order"));
 #else
-                       niv = (int) iv;
+                       niv = (I32) iv;
                        TRACEME(("as-is for network order"));
 #endif
                        PUTMARK(SX_NETINT);
                        TRACEME(("as-is for network order"));
 #endif
                        PUTMARK(SX_NETINT);
-                       WRITE(&niv, sizeof(niv));
+                       WRITE_I32(niv);
                } else {
                        PUTMARK(SX_INTEGER);
                        WRITE(&iv, sizeof(iv));
                }
 
                } else {
                        PUTMARK(SX_INTEGER);
                        WRITE(&iv, sizeof(iv));
                }
 
-               TRACEME(("ok (integer 0x%lx, value = %d)", (unsigned long) sv, iv));
+               TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
 
        } else
 
        } else
-               CROAK(("Can't determine type of %s(0x%lx)", sv_reftype(sv, FALSE),
-                       (unsigned long) sv));
+               CROAK(("Can't determine type of %s(0x%"UVxf")",
+                      sv_reftype(sv, FALSE),
+                      PTR2UV(sv)));
 
        return 0;               /* Ok, no recursion on scalars */
 }
 
        return 0;               /* Ok, no recursion on scalars */
 }
@@ -1512,16 +1737,14 @@ SV *sv;
  * Layout is SX_ARRAY <size> followed by each item, in increading index order.
  * Each item is stored as <object>.
  */
  * Layout is SX_ARRAY <size> followed by each item, in increading index order.
  * Each item is stored as <object>.
  */
-static int store_array(cxt, av)
-stcxt_t *cxt;
-AV *av;
+static int store_array(stcxt_t *cxt, AV *av)
 {
        SV **sav;
        I32 len = av_len(av) + 1;
        I32 i;
        int ret;
 
 {
        SV **sav;
        I32 len = av_len(av) + 1;
        I32 i;
        int ret;
 
-       TRACEME(("store_array (0x%lx)", (unsigned long) av));
+       TRACEME(("store_array (0x%"UVxf")", PTR2UV(av)));
 
        /* 
         * Signal array by emitting SX_ARRAY, followed by the array length.
 
        /* 
         * Signal array by emitting SX_ARRAY, followed by the array length.
@@ -1543,7 +1766,7 @@ AV *av;
                        continue;
                }
                TRACEME(("(#%d) item", i));
                        continue;
                }
                TRACEME(("(#%d) item", i));
-               if (ret = store(cxt, *sav))
+               if ((ret = store(cxt, *sav)))
                        return ret;
        }
 
                        return ret;
        }
 
@@ -1559,9 +1782,7 @@ AV *av;
  * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
  */
 static int
  * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
  */
 static int
-sortcmp(a, b)
-const void *a;
-const void *b;
+sortcmp(const void *a, const void *b)
 {
        return sv_cmp(*(SV * const *) a, *(SV * const *) b);
 }
 {
        return sv_cmp(*(SV * const *) a, *(SV * const *) b);
 }
@@ -1577,9 +1798,7 @@ const void *b;
  * Keys are stored as <length> <data>, the <data> section being omitted
  * if length is 0.
  */
  * Keys are stored as <length> <data>, the <data> section being omitted
  * if length is 0.
  */
-static int store_hash(cxt, hv)
-stcxt_t *cxt;
-HV *hv;
+static int store_hash(stcxt_t *cxt, HV *hv)
 {
        I32 len = HvKEYS(hv);
        I32 i;
 {
        I32 len = HvKEYS(hv);
        I32 i;
@@ -1587,7 +1806,7 @@ HV *hv;
        I32 riter;
        HE *eiter;
 
        I32 riter;
        HE *eiter;
 
-       TRACEME(("store_hash (0x%lx)", (unsigned long) hv));
+       TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv)));
 
        /* 
         * Signal hash by emitting SX_HASH, followed by the table length.
 
        /* 
         * Signal hash by emitting SX_HASH, followed by the table length.
@@ -1653,9 +1872,9 @@ HV *hv;
                         * Store value first.
                         */
                        
                         * Store value first.
                         */
                        
-                       TRACEME(("(#%d) value 0x%lx", i, (unsigned long) val));
+                       TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
 
 
-                       if (ret = store(cxt, val))
+                       if ((ret = store(cxt, val)))
                                goto out;
 
                        /*
                                goto out;
 
                        /*
@@ -1699,9 +1918,9 @@ HV *hv;
                         * Store value first.
                         */
 
                         * Store value first.
                         */
 
-                       TRACEME(("(#%d) value 0x%lx", i, (unsigned long) val));
+                       TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
 
 
-                       if (ret = store(cxt, val))
+                       if ((ret = store(cxt, val)))
                                goto out;
 
                        /*
                                goto out;
 
                        /*
@@ -1719,7 +1938,7 @@ HV *hv;
                }
     }
 
                }
     }
 
-       TRACEME(("ok (hash 0x%lx)", (unsigned long) hv));
+       TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv)));
 
 out:
        HvRITER(hv) = riter;            /* Restore hash iterator state */
 
 out:
        HvRITER(hv) = riter;            /* Restore hash iterator state */
@@ -1736,16 +1955,14 @@ out:
  * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
  * <hash object> stands for the serialization of the tied hash.
  */
  * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
  * <hash object> stands for the serialization of the tied hash.
  */
-static int store_tied(cxt, sv)
-stcxt_t *cxt;
-SV *sv;
+static int store_tied(stcxt_t *cxt, SV *sv)
 {
        MAGIC *mg;
        int ret = 0;
        int svt = SvTYPE(sv);
        char mtype = 'P';
 
 {
        MAGIC *mg;
        int ret = 0;
        int svt = SvTYPE(sv);
        char mtype = 'P';
 
-       TRACEME(("store_tied (0x%lx)", (unsigned long) sv));
+       TRACEME(("store_tied (0x%"UVxf")", PTR2UV(sv)));
 
        /*
         * We have a small run-time penalty here because we chose to factorise
 
        /*
         * We have a small run-time penalty here because we chose to factorise
@@ -1786,7 +2003,7 @@ SV *sv;
         * accesses on the retrieved object will indeed call the magic methods...
         */
 
         * accesses on the retrieved object will indeed call the magic methods...
         */
 
-       if (ret = store(cxt, mg->mg_obj))
+       if ((ret = store(cxt, mg->mg_obj)))
                return ret;
 
        TRACEME(("ok (tied)"));
                return ret;
 
        TRACEME(("ok (tied)"));
@@ -1806,14 +2023,12 @@ SV *sv;
  *     SX_TIED_KEY <object> <key>
  *     SX_TIED_IDX <object> <index>
  */
  *     SX_TIED_KEY <object> <key>
  *     SX_TIED_IDX <object> <index>
  */
-static int store_tied_item(cxt, sv)
-stcxt_t *cxt;
-SV *sv;
+static int store_tied_item(stcxt_t *cxt, SV *sv)
 {
        MAGIC *mg;
        int ret;
 
 {
        MAGIC *mg;
        int ret;
 
-       TRACEME(("store_tied_item (0x%lx)", (unsigned long) sv));
+       TRACEME(("store_tied_item (0x%"UVxf")", PTR2UV(sv)));
 
        if (!(mg = mg_find(sv, 'p')))
                CROAK(("No magic 'p' found while storing reference to tied item"));
 
        if (!(mg = mg_find(sv, 'p')))
                CROAK(("No magic 'p' found while storing reference to tied item"));
@@ -1825,26 +2040,23 @@ SV *sv;
        if (mg->mg_ptr) {
                TRACEME(("store_tied_item: storing a ref to a tied hash item"));
                PUTMARK(SX_TIED_KEY);
        if (mg->mg_ptr) {
                TRACEME(("store_tied_item: storing a ref to a tied hash item"));
                PUTMARK(SX_TIED_KEY);
-               TRACEME(("store_tied_item: storing OBJ 0x%lx",
-                       (unsigned long) mg->mg_obj));
+               TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
 
 
-               if (ret = store(cxt, mg->mg_obj))
+               if ((ret = store(cxt, mg->mg_obj)))
                        return ret;
 
                        return ret;
 
-               TRACEME(("store_tied_item: storing PTR 0x%lx",
-                       (unsigned long) mg->mg_ptr));
+               TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
 
 
-               if (ret = store(cxt, (SV *) mg->mg_ptr))
+               if ((ret = store(cxt, (SV *) mg->mg_ptr)))
                        return ret;
        } else {
                I32 idx = mg->mg_len;
 
                TRACEME(("store_tied_item: storing a ref to a tied array item "));
                PUTMARK(SX_TIED_IDX);
                        return ret;
        } else {
                I32 idx = mg->mg_len;
 
                TRACEME(("store_tied_item: storing a ref to a tied array item "));
                PUTMARK(SX_TIED_IDX);
-               TRACEME(("store_tied_item: storing OBJ 0x%lx",
-                       (unsigned long) mg->mg_obj));
+               TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
 
 
-               if (ret = store(cxt, mg->mg_obj))
+               if ((ret = store(cxt, mg->mg_obj)))
                        return ret;
 
                TRACEME(("store_tied_item: storing IDX %d", idx));
                        return ret;
 
                TRACEME(("store_tied_item: storing IDX %d", idx));
@@ -1891,12 +2103,23 @@ SV *sv;
  * that same header being repeated between serialized objects obtained through
  * recursion, until we reach flags indicating no recursion, at which point
  * we know we've resynchronized with a single layout, after <flags>.
  * that same header being repeated between serialized objects obtained through
  * recursion, until we reach flags indicating no recursion, at which point
  * we know we've resynchronized with a single layout, after <flags>.
+ *
+ * When storing a blessed ref to a tied variable, the following format is
+ * used:
+ *
+ *     SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
+ *
+ * The first <flags> indication carries an object of type SHT_EXTRA, and the
+ * real object type is held in the <extra> flag.  At the very end of the
+ * serialization stream, the underlying magic object is serialized, just like
+ * any other tied variable.
  */
  */
-static int store_hook(cxt, sv, type, pkg, hook)
-stcxt_t *cxt;
-SV *sv;
-HV *pkg;
-SV *hook;
+static int store_hook(
+       stcxt_t *cxt,
+       SV *sv,
+       int type,
+       HV *pkg,
+       SV *hook)
 {
        I32 len;
        char *class;
 {
        I32 len;
        char *class;
@@ -1913,6 +2136,8 @@ SV *hook;
        I32 classnum;
        int ret;
        int clone = cxt->optype & ST_CLONE;
        I32 classnum;
        int ret;
        int clone = cxt->optype & ST_CLONE;
+       char mtype = 0;                         /* for blessed ref to tied structures */
+       unsigned char eflags = 0;       /* used when object type is SHT_EXTRA */
 
        TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
 
 
        TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
 
@@ -1930,6 +2155,36 @@ SV *hook;
        case svis_HASH:
                obj_type = SHT_HASH;
                break;
        case svis_HASH:
                obj_type = SHT_HASH;
                break;
+       case svis_TIED:
+               /*
+                * Produced by a blessed ref to a tied data structure, $o in the
+                * following Perl code.
+                *
+                *      my %h;
+                *  tie %h, 'FOO';
+                *      my $o = bless \%h, 'BAR';
+                *
+                * Signal the tie-ing magic by setting the object type as SHT_EXTRA
+                * (since we have only 2 bits in <flags> to store the type), and an
+                * <extra> byte flag will be emitted after the FIRST <flags> in the
+                * stream, carrying what we put in `eflags'.
+                */
+               obj_type = SHT_EXTRA;
+               switch (SvTYPE(sv)) {
+               case SVt_PVHV:
+                       eflags = (unsigned char) SHT_THASH;
+                       mtype = 'P';
+                       break;
+               case SVt_PVAV:
+                       eflags = (unsigned char) SHT_TARRAY;
+                       mtype = 'P';
+                       break;
+               default:
+                       eflags = (unsigned char) SHT_TSCALAR;
+                       mtype = 'q';
+                       break;
+               }
+               break;
        default:
                CROAK(("Unexpected object type (%d) in store_hook()", type));
        }
        default:
                CROAK(("Unexpected object type (%d) in store_hook()", type));
        }
@@ -1982,7 +2237,7 @@ SV *hook;
                pkg_hide(cxt->hook, pkg, "STORABLE_freeze");
 
                ASSERT(!pkg_can(cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
                pkg_hide(cxt->hook, pkg, "STORABLE_freeze");
 
                ASSERT(!pkg_can(cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
-               TRACEME(("Ignoring STORABLE_freeze in class \"%s\"", class));
+               TRACEME(("ignoring STORABLE_freeze in class \"%s\"", class));
 
                return store_blessed(cxt, sv, type, pkg);
        }
 
                return store_blessed(cxt, sv, type, pkg);
        }
@@ -1995,17 +2250,6 @@ SV *hook;
        pv = SvPV(ary[0], len2);
 
        /*
        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.
         *
         * If they returned more than one item, we need to serialize some
         * extra references if not already done.
         *
@@ -2020,22 +2264,24 @@ SV *hook;
 
        for (i = 1; i < count; i++) {
                SV **svh;
 
        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.
                 * Serialize entry if not done already, and get its tag.
                 */
 
 
                /*
                 * Look in hseen and see if we have a tag already.
                 * Serialize entry if not done already, and get its tag.
                 */
 
-               if (svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE))
+               if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
                        goto sv_seen;           /* Avoid moving code too far to the right */
 
                        goto sv_seen;           /* Avoid moving code too far to the right */
 
-               TRACEME(("listed object %d at 0x%lx is unknown",
-                       i-1, (unsigned long) xsv));
+               TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
 
                /*
                 * We need to recurse to store that object and get it to be known
 
                /*
                 * We need to recurse to store that object and get it to be known
@@ -2048,12 +2294,16 @@ SV *hook;
                 * others, in case those would point back at that object.
                 */
 
                 * others, in case those would point back at that object.
                 */
 
-               /* [SX_HOOK] <flags> <object>*/
-               if (!recursed++)
+               /* [SX_HOOK] <flags> [<extra>] <object>*/
+               if (!recursed++) {
                        PUTMARK(SX_HOOK);
                        PUTMARK(SX_HOOK);
-               PUTMARK(flags);
+                       PUTMARK(flags);
+                       if (obj_type == SHT_EXTRA)
+                               PUTMARK(eflags);
+               } else
+                       PUTMARK(flags);
 
 
-               if (ret = store(cxt, xsv))              /* Given by hook for us to store */
+               if ((ret = store(cxt, xsv)))            /* Given by hook for us to store */
                        return ret;
 
                svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
                        return ret;
 
                svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
@@ -2061,14 +2311,53 @@ SV *hook;
                        CROAK(("Could not serialize item #%d from hook in %s", i, class));
 
                /*
                        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:
        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;
                ary[i] = *svh;
-               TRACEME(("listed object %d at 0x%lx is tag #%d",
-                       i-1, (unsigned long) xsv, (I32) *svh));
+               TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf,
+                        i-1, PTR2UV(xsv), PTR2UV(*svh)));
+       }
+
+       /*
+        * 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));
        }
 
        /*
        }
 
        /*
@@ -2096,13 +2385,18 @@ SV *hook;
         * If we recursed, the SX_HOOK has already been emitted.
         */
 
         * If we recursed, the SX_HOOK has already been emitted.
         */
 
-       TRACEME(("SX_HOOK (recursed=%d) flags=0x%x class=%d len=%d len2=%d len3=%d",
-               recursed, flags, classnum, len, len2, count-1));
+       TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
+                       "class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d",
+                recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
 
 
-       /* SX_HOOK <flags> */
-       if (!recursed)
+       /* SX_HOOK <flags> [<extra>] */
+       if (!recursed) {
                PUTMARK(SX_HOOK);
                PUTMARK(SX_HOOK);
-       PUTMARK(flags);
+               PUTMARK(flags);
+               if (obj_type == SHT_EXTRA)
+                       PUTMARK(eflags);
+       } else
+               PUTMARK(flags);
 
        /* <len> <classname> or <index> */
        if (flags & SHF_IDX_CLASSNAME) {
 
        /* <len> <classname> or <index> */
        if (flags & SHF_IDX_CLASSNAME) {
@@ -2123,9 +2417,10 @@ SV *hook;
        }
 
        /* <len2> <frozen-str> */
        }
 
        /* <len2> <frozen-str> */
-       if (flags & SHF_LARGE_STRLEN)
-               WLEN(len2);
-       else {
+       if (flags & SHF_LARGE_STRLEN) {
+               I32 wlen2 = len2;               /* STRLEN might be 8 bytes */
+               WLEN(wlen2);                    /* Must write an I32 for 64-bit machines */
+       } else {
                unsigned char clen = (unsigned char) len2;
                PUTMARK(clen);
        }
                unsigned char clen = (unsigned char) len2;
                PUTMARK(clen);
        }
@@ -2149,7 +2444,7 @@ SV *hook;
 
                for (i = 1; i < count; i++) {
                        I32 tagval = htonl(LOW_32BITS(ary[i]));
 
                for (i = 1; i < count; i++) {
                        I32 tagval = htonl(LOW_32BITS(ary[i]));
-                       WRITE(&tagval, sizeof(I32));
+                       WRITE_I32(tagval);
                        TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
                }
        }
                        TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
                }
        }
@@ -2164,6 +2459,31 @@ SV *hook;
        av_undef(av);
        sv_free((SV *) av);
 
        av_undef(av);
        sv_free((SV *) av);
 
+       /*
+        * If object was tied, need to insert serialization of the magic object.
+        */
+
+       if (obj_type == SHT_EXTRA) {
+               MAGIC *mg;
+
+               if (!(mg = mg_find(sv, mtype))) {
+                       int svt = SvTYPE(sv);
+                       CROAK(("No magic '%c' found while storing ref to tied %s with hook",
+                               mtype, (svt == SVt_PVHV) ? "hash" :
+                                       (svt == SVt_PVAV) ? "array" : "scalar"));
+               }
+
+               TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf,
+                       PTR2UV(mg->mg_obj), PTR2UV(sv)));
+
+               /*
+                * [<magic object>]
+                */
+
+               if ((ret = store(cxt, mg->mg_obj)))
+                       return ret;
+       }
+
        return 0;
 }
 
        return 0;
 }
 
@@ -2191,11 +2511,11 @@ SV *hook;
  * where <index> is the classname index, stored on 0 or 4 bytes depending
  * on the high-order bit in flag (same encoding as above for <len>).
  */
  * where <index> is the classname index, stored on 0 or 4 bytes depending
  * on the high-order bit in flag (same encoding as above for <len>).
  */
-static int store_blessed(cxt, sv, type, pkg)
-stcxt_t *cxt;
-SV *sv;
-int type;
-HV *pkg;
+static int store_blessed(
+       stcxt_t *cxt,
+       SV *sv,
+       int type,
+       HV *pkg)
 {
        SV *hook;
        I32 len;
 {
        SV *hook;
        I32 len;
@@ -2220,8 +2540,8 @@ HV *pkg;
        class = HvNAME(pkg);
        len = strlen(class);
 
        class = HvNAME(pkg);
        len = strlen(class);
 
-       TRACEME(("blessed 0x%lx in %s, no hook: tagged #%d",
-               (unsigned long) sv, class, cxt->tagnum));
+       TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d",
+                PTR2UV(sv), class, cxt->tagnum));
 
        /*
         * Determine whether it is the first time we see that class name (in which
 
        /*
         * Determine whether it is the first time we see that class name (in which
@@ -2272,11 +2592,9 @@ HV *pkg;
  * true value, then don't croak, just warn, and store a placeholder string
  * instead.
  */
  * true value, then don't croak, just warn, and store a placeholder string
  * instead.
  */
-static int store_other(cxt, sv)
-stcxt_t *cxt;
-SV *sv;
+static int store_other(stcxt_t *cxt, SV *sv)
 {
 {
-       STRLEN len;
+       I32 len;
        static char buf[80];
 
        TRACEME(("store_other"));
        static char buf[80];
 
        TRACEME(("store_other"));
@@ -2292,19 +2610,19 @@ SV *sv;
        )
                CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
 
        )
                CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
 
-       warn("Can't store item %s(0x%lx)",
-               sv_reftype(sv, FALSE), (unsigned long) sv);
+       warn("Can't store item %s(0x%"UVxf")",
+               sv_reftype(sv, FALSE), PTR2UV(sv));
 
        /*
         * Store placeholder string as a scalar instead...
         */
 
 
        /*
         * Store placeholder string as a scalar instead...
         */
 
-       (void) sprintf(buf, "You lost %s(0x%lx)\0", sv_reftype(sv, FALSE),
-               (unsigned long) sv);
+       (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE),
+                      PTR2UV(sv), (char)0);
 
        len = strlen(buf);
        STORE_SCALAR(buf, len);
 
        len = strlen(buf);
        STORE_SCALAR(buf, len);
-       TRACEME(("ok (dummy \"%s\", length = %d)", buf, len));
+       TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, len));
 
        return 0;
 }
 
        return 0;
 }
@@ -2321,8 +2639,7 @@ SV *sv;
  * Returns the type of the SV, identified by an integer. That integer
  * may then be used to index the dynamic routine dispatch table.
  */
  * Returns the type of the SV, identified by an integer. That integer
  * may then be used to index the dynamic routine dispatch table.
  */
-static int sv_type(sv)
-SV *sv;
+static int sv_type(SV *sv)
 {
        switch (SvTYPE(sv)) {
        case SVt_NULL:
 {
        switch (SvTYPE(sv)) {
        case SVt_NULL:
@@ -2380,17 +2697,14 @@ SV *sv;
  * object (one for which storage has started -- it may not be over if we have
  * a self-referenced structure). This data set forms a stored <object>.
  */
  * object (one for which storage has started -- it may not be over if we have
  * a self-referenced structure). This data set forms a stored <object>.
  */
-static int store(cxt, sv)
-stcxt_t *cxt;
-SV *sv;
+static int store(stcxt_t *cxt, SV *sv)
 {
        SV **svh;
        int ret;
 {
        SV **svh;
        int ret;
-       SV *tag;
        int type;
        int type;
-    HV *hseen = cxt->hseen;
+       HV *hseen = cxt->hseen;
 
 
-       TRACEME(("store (0x%lx)", (unsigned long) sv));
+       TRACEME(("store (0x%"UVxf")", PTR2UV(sv)));
 
        /*
         * If object has already been stored, do not duplicate data.
 
        /*
         * If object has already been stored, do not duplicate data.
@@ -2408,11 +2722,10 @@ SV *sv;
        if (svh) {
                I32 tagval = htonl(LOW_32BITS(*svh));
 
        if (svh) {
                I32 tagval = htonl(LOW_32BITS(*svh));
 
-               TRACEME(("object 0x%lx seen as #%d",
-                       (unsigned long) sv, ntohl(tagval)));
+               TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval)));
 
                PUTMARK(SX_OBJECT);
 
                PUTMARK(SX_OBJECT);
-               WRITE(&tagval, sizeof(I32));
+               WRITE_I32(tagval);
                return 0;
        }
 
                return 0;
        }
 
@@ -2425,14 +2738,11 @@ SV *sv;
         * means that we must clean up the hash manually afterwards, but gives
         * us a 15% throughput increase.
         *
         * means that we must clean up the hash manually afterwards, but gives
         * us a 15% throughput increase.
         *
-        * The (IV) cast below is for 64-bit machines, to avoid warnings from
-        * the compiler. Please, let me know if it does not work.
-        *              -- RAM, 14/09/1999
         */
 
        cxt->tagnum++;
        if (!hv_store(hseen,
         */
 
        cxt->tagnum++;
        if (!hv_store(hseen,
-                       (char *) &sv, sizeof(sv), (SV*)(IV) cxt->tagnum, 0))
+                       (char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0))
                return -1;
 
        /*
                return -1;
 
        /*
@@ -2442,8 +2752,8 @@ SV *sv;
 
        type = sv_type(sv);
 
 
        type = sv_type(sv);
 
-       TRACEME(("storing 0x%lx tag #%d, type %d...",
-               (unsigned long) sv, cxt->tagnum, type));
+       TRACEME(("storing 0x%"UVxf" tag #%d, type %d...",
+                PTR2UV(sv), cxt->tagnum, type));
 
        if (SvOBJECT(sv)) {
                HV *pkg = SvSTASH(sv);
 
        if (SvOBJECT(sv)) {
                HV *pkg = SvSTASH(sv);
@@ -2451,8 +2761,8 @@ SV *sv;
        } else
                ret = SV_STORE(type)(cxt, sv);
 
        } else
                ret = SV_STORE(type)(cxt, sv);
 
-       TRACEME(("%s (stored 0x%lx, refcnt=%d, %s)",
-               ret ? "FAILED" : "ok", (unsigned long) sv,
+       TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)",
+               ret ? "FAILED" : "ok", PTR2UV(sv),
                SvREFCNT(sv), sv_reftype(sv, FALSE)));
 
        return ret;
                SvREFCNT(sv), sv_reftype(sv, FALSE)));
 
        return ret;
@@ -2469,8 +2779,7 @@ SV *sv;
  * Note that no byte ordering info is emitted when <network> is true, since
  * integers will be emitted in network order in that case.
  */
  * Note that no byte ordering info is emitted when <network> is true, since
  * integers will be emitted in network order in that case.
  */
-static int magic_write(cxt)
-stcxt_t *cxt;
+static int magic_write(stcxt_t *cxt)
 {
        char buf[256];  /* Enough room for 256 hexa digits */
        unsigned char c;
 {
        char buf[256];  /* Enough room for 256 hexa digits */
        unsigned char c;
@@ -2509,10 +2818,12 @@ stcxt_t *cxt;
        PUTMARK((unsigned char) sizeof(int));
        PUTMARK((unsigned char) sizeof(long));
        PUTMARK((unsigned char) sizeof(char *));
        PUTMARK((unsigned char) sizeof(int));
        PUTMARK((unsigned char) sizeof(long));
        PUTMARK((unsigned char) sizeof(char *));
+       PUTMARK((unsigned char) sizeof(NV));
 
 
-       TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d)",
-               (unsigned long) BYTEORDER, (int) c,
-               sizeof(int), sizeof(long), sizeof(char *)));
+       TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
+                (unsigned long) BYTEORDER, (int) c,
+                (int) sizeof(int), (int) sizeof(long),
+                (int) sizeof(char *), (int) sizeof(NV)));
 
        return 0;
 }
 
        return 0;
 }
@@ -2528,12 +2839,12 @@ stcxt_t *cxt;
  * It is required to provide a non-null `res' when the operation type is not
  * dclone() and store() is performed to memory.
  */
  * It is required to provide a non-null `res' when the operation type is not
  * dclone() and store() is performed to memory.
  */
-static int do_store(f, sv, optype, network_order, res)
-PerlIO *f;
-SV *sv;
-int optype;
-int network_order;
-SV **res;
+static int do_store(
+       PerlIO *f,
+       SV *sv,
+       int optype,
+       int network_order,
+       SV **res)
 {
        dSTCXT;
        int status;
 {
        dSTCXT;
        int status;
@@ -2551,7 +2862,7 @@ SV **res;
         * free up memory for them now.
         */
 
         * free up memory for them now.
         */
 
-       if (cxt->dirty)
+       if (cxt->s_dirty)
                clean_context(cxt);
 
        /*
                clean_context(cxt);
 
        /*
@@ -2565,7 +2876,7 @@ SV **res;
        cxt->entry++;
 
        ASSERT(cxt->entry == 1, ("starting new recursion"));
        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
 
        /*
         * Ensure sv is actually a reference. From perl, we called something
@@ -2645,12 +2956,10 @@ SV **res;
  * Store the transitive data closure of given object to disk.
  * Returns 0 on error, a true value otherwise.
  */
  * Store the transitive data closure of given object to disk.
  * Returns 0 on error, a true value otherwise.
  */
-int pstore(f, sv)
-PerlIO *f;
-SV *sv;
+int pstore(PerlIO *f, SV *sv)
 {
        TRACEME(("pstore"));
 {
        TRACEME(("pstore"));
-       return do_store(f, sv, 0, FALSE, (SV**)0);
+       return do_store(f, sv, 0, FALSE, (SV**) 0);
 
 }
 
 
 }
 
@@ -2660,12 +2969,10 @@ SV *sv;
  * Same as pstore(), but network order is used for integers and doubles are
  * emitted as strings.
  */
  * Same as pstore(), but network order is used for integers and doubles are
  * emitted as strings.
  */
-int net_pstore(f, sv)
-PerlIO *f;
-SV *sv;
+int net_pstore(PerlIO *f, SV *sv)
 {
        TRACEME(("net_pstore"));
 {
        TRACEME(("net_pstore"));
-       return do_store(f, sv, 0, TRUE, (SV**)0);
+       return do_store(f, sv, 0, TRUE, (SV**) 0);
 }
 
 /***
 }
 
 /***
@@ -2677,7 +2984,7 @@ SV *sv;
  *
  * Build a new SV out of the content of the internal memory buffer.
  */
  *
  * Build a new SV out of the content of the internal memory buffer.
  */
-static SV *mbuf2sv()
+static SV *mbuf2sv(void)
 {
        dSTCXT;
 
 {
        dSTCXT;
 
@@ -2690,15 +2997,14 @@ static SV *mbuf2sv()
  * Store the transitive data closure of given object to memory.
  * Returns undef on error, a scalar value containing the data otherwise.
  */
  * Store the transitive data closure of given object to memory.
  * Returns undef on error, a scalar value containing the data otherwise.
  */
-SV *mstore(sv)
-SV *sv;
+SV *mstore(SV *sv)
 {
        dSTCXT;
        SV *out;
 
        TRACEME(("mstore"));
 
 {
        dSTCXT;
        SV *out;
 
        TRACEME(("mstore"));
 
-       if (!do_store((PerlIO*)0, sv, 0, FALSE, &out))
+       if (!do_store((PerlIO*) 0, sv, 0, FALSE, &out))
                return &PL_sv_undef;
 
        return out;
                return &PL_sv_undef;
 
        return out;
@@ -2710,15 +3016,14 @@ SV *sv;
  * Same as mstore(), but network order is used for integers and doubles are
  * emitted as strings.
  */
  * Same as mstore(), but network order is used for integers and doubles are
  * emitted as strings.
  */
-SV *net_mstore(sv)
-SV *sv;
+SV *net_mstore(SV *sv)
 {
        dSTCXT;
        SV *out;
 
        TRACEME(("net_mstore"));
 
 {
        dSTCXT;
        SV *out;
 
        TRACEME(("net_mstore"));
 
-       if (!do_store((PerlIO*)0, sv, 0, TRUE, &out))
+       if (!do_store((PerlIO*) 0, sv, 0, TRUE, &out))
                return &PL_sv_undef;
 
        return out;
                return &PL_sv_undef;
 
        return out;
@@ -2734,8 +3039,7 @@ SV *sv;
  * Return an error via croak, since it is not possible that we get here
  * under normal conditions, when facing a file produced via pstore().
  */
  * Return an error via croak, since it is not possible that we get here
  * under normal conditions, when facing a file produced via pstore().
  */
-static SV *retrieve_other(cxt)
-stcxt_t *cxt;
+static SV *retrieve_other(stcxt_t *cxt, char *cname)
 {
        if (
                cxt->ver_major != STORABLE_BIN_MAJOR &&
 {
        if (
                cxt->ver_major != STORABLE_BIN_MAJOR &&
@@ -2760,8 +3064,7 @@ stcxt_t *cxt;
  * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
  * <index> can be coded on either 1 or 5 bytes.
  */
  * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
  * <index> can be coded on either 1 or 5 bytes.
  */
-static SV *retrieve_idx_blessed(cxt)
-stcxt_t *cxt;
+static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname)
 {
        I32 idx;
        char *class;
 {
        I32 idx;
        char *class;
@@ -2769,6 +3072,7 @@ stcxt_t *cxt;
        SV *sv;
 
        TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum));
        SV *sv;
 
        TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum));
+       ASSERT(!cname, ("no bless-into class given here, got %s", cname));
 
        GETMARK(idx);                   /* Index coded on a single char? */
        if (idx & 0x80)
 
        GETMARK(idx);                   /* Index coded on a single char? */
        if (idx & 0x80)
@@ -2780,7 +3084,8 @@ stcxt_t *cxt;
 
        sva = av_fetch(cxt->aclass, idx, FALSE);
        if (!sva)
 
        sva = av_fetch(cxt->aclass, idx, FALSE);
        if (!sva)
-               CROAK(("Class name #%d should have been seen already", idx));
+               CROAK(("Class name #%"IVdf" should have been seen already",
+                       (IV)idx));
 
        class = SvPVX(*sva);    /* We know it's a PV, by construction */
 
 
        class = SvPVX(*sva);    /* We know it's a PV, by construction */
 
@@ -2790,9 +3095,7 @@ stcxt_t *cxt;
         * Retrieve object and bless it.
         */
 
         * Retrieve object and bless it.
         */
 
-       sv = retrieve(cxt);
-       if (sv)
-               BLESS(sv, class);
+       sv = retrieve(cxt, class);      /* First SV which is SEEN will be blessed */
 
        return sv;
 }
 
        return sv;
 }
@@ -2803,8 +3106,7 @@ stcxt_t *cxt;
  * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
  * <len> can be coded on either 1 or 5 bytes.
  */
  * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
  * <len> can be coded on either 1 or 5 bytes.
  */
-static SV *retrieve_blessed(cxt)
-stcxt_t *cxt;
+static SV *retrieve_blessed(stcxt_t *cxt, char *cname)
 {
        I32 len;
        SV *sv;
 {
        I32 len;
        SV *sv;
@@ -2812,6 +3114,7 @@ stcxt_t *cxt;
        char *class = buf;
 
        TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
        char *class = buf;
 
        TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
+       ASSERT(!cname, ("no bless-into class given here, got %s", cname));
 
        /*
         * Decode class name length and read that name.
 
        /*
         * Decode class name length and read that name.
@@ -2833,6 +3136,8 @@ stcxt_t *cxt;
         * It's a new classname, otherwise it would have been an SX_IX_BLESS.
         */
 
         * It's a new classname, otherwise it would have been an SX_IX_BLESS.
         */
 
+       TRACEME(("new class name \"%s\" will bear ID = %d", class, cxt->classnum));
+
        if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
                return (SV *) 0;
 
        if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
                return (SV *) 0;
 
@@ -2840,12 +3145,9 @@ stcxt_t *cxt;
         * Retrieve object and bless it.
         */
 
         * Retrieve object and bless it.
         */
 
-       sv = retrieve(cxt);
-       if (sv) {
-               BLESS(sv, class);
-               if (class != buf)
-                       Safefree(class);
-       }
+       sv = retrieve(cxt, class);      /* First SV which is SEEN will be blessed */
+       if (class != buf)
+               Safefree(class);
 
        return sv;
 }
 
        return sv;
 }
@@ -2859,9 +3161,18 @@ stcxt_t *cxt;
  * When recursion was involved during serialization of the object, there
  * is an unknown amount of serialized objects after the SX_HOOK mark.  Until
  * we reach a <flags> marker with the recursion bit cleared.
  * When recursion was involved during serialization of the object, there
  * is an unknown amount of serialized objects after the SX_HOOK mark.  Until
  * we reach a <flags> marker with the recursion bit cleared.
+ *
+ * If the first <flags> byte contains a type of SHT_EXTRA, then the real type
+ * is held in the <extra> byte, and if the object is tied, the serialized
+ * magic object comes at the very end:
+ *
+ *     SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
+ *
+ * This means the STORABLE_thaw hook will NOT get a tied variable during its
+ * processing (since we won't have seen the magic object by the time the hook
+ * is called).  See comments below for why it was done that way.
  */
  */
-static SV *retrieve_hook(cxt)
-stcxt_t *cxt;
+static SV *retrieve_hook(stcxt_t *cxt, char *cname)
 {
        I32 len;
        char buf[LG_BLESS + 1];         /* Avoid malloc() if possible */
 {
        I32 len;
        char buf[LG_BLESS + 1];         /* Avoid malloc() if possible */
@@ -2875,10 +3186,12 @@ stcxt_t *cxt;
        SV *sv;
        SV *rv;
        int obj_type;
        SV *sv;
        SV *rv;
        int obj_type;
-       I32 classname;
        int clone = cxt->optype & ST_CLONE;
        int clone = cxt->optype & ST_CLONE;
+       char mtype = '\0';
+       unsigned int extra_type = 0;
 
        TRACEME(("retrieve_hook (#%d)", cxt->tagnum));
 
        TRACEME(("retrieve_hook (#%d)", cxt->tagnum));
+       ASSERT(!cname, ("no bless-into class given here, got %s", cname));
 
        /*
         * Read flags, which tell us about the type, and whether we need to recurse.
 
        /*
         * Read flags, which tell us about the type, and whether we need to recurse.
@@ -2905,10 +3218,33 @@ stcxt_t *cxt;
        case SHT_HASH:
                sv = (SV *) newHV();
                break;
        case SHT_HASH:
                sv = (SV *) newHV();
                break;
+       case SHT_EXTRA:
+               /*
+                * Read <extra> flag to know the type of the object.
+                * Record associated magic type for later.
+                */
+               GETMARK(extra_type);
+               switch (extra_type) {
+               case SHT_TSCALAR:
+                       sv = newSV(0);
+                       mtype = 'q';
+                       break;
+               case SHT_TARRAY:
+                       sv = (SV *) newAV();
+                       mtype = 'P';
+                       break;
+               case SHT_THASH:
+                       sv = (SV *) newHV();
+                       mtype = 'P';
+                       break;
+               default:
+                       return retrieve_other(cxt, 0);  /* Let it croak */
+               }
+               break;
        default:
        default:
-               return retrieve_other(cxt);             /* Let it croak */
+               return retrieve_other(cxt, 0);          /* Let it croak */
        }
        }
-       SEEN(sv);
+       SEEN(sv, 0);                                                    /* Don't bless yet */
 
        /*
         * Whilst flags tell us to recurse, do so.
 
        /*
         * Whilst flags tell us to recurse, do so.
@@ -2920,10 +3256,11 @@ stcxt_t *cxt;
 
        while (flags & SHF_NEED_RECURSE) {
                TRACEME(("retrieve_hook recursing..."));
 
        while (flags & SHF_NEED_RECURSE) {
                TRACEME(("retrieve_hook recursing..."));
-               rv = retrieve(cxt);
+               rv = retrieve(cxt, 0);
                if (!rv)
                        return (SV *) 0;
                if (!rv)
                        return (SV *) 0;
-               TRACEME(("retrieve_hook back with rv=0x%lx", (unsigned long) rv));
+               TRACEME(("retrieve_hook back with rv=0x%"UVxf,
+                        PTR2UV(rv)));
                GETMARK(flags);
        }
 
                GETMARK(flags);
        }
 
@@ -2942,7 +3279,8 @@ stcxt_t *cxt;
 
                sva = av_fetch(cxt->aclass, idx, FALSE);
                if (!sva)
 
                sva = av_fetch(cxt->aclass, idx, FALSE);
                if (!sva)
-                       CROAK(("Class name #%d should have been seen already", idx));
+                   CROAK(("Class name #%"IVdf" should have been seen already", 
+                           (IV)idx));
 
                class = SvPVX(*sva);    /* We know it's a PV, by construction */
                TRACEME(("class ID %d => %s", idx, class));
 
                class = SvPVX(*sva);    /* We know it's a PV, by construction */
                TRACEME(("class ID %d => %s", idx, class));
@@ -2998,7 +3336,8 @@ stcxt_t *cxt;
                *SvEND(frozen) = '\0';
        }
        (void) SvPOK_only(frozen);              /* Validates string pointer */
                *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));
 
 
        TRACEME(("frozen string: %d bytes", len2));
 
@@ -3038,11 +3377,11 @@ stcxt_t *cxt;
                        SV **svh;
                        SV *xsv;
 
                        SV **svh;
                        SV *xsv;
 
-                       READ(&tag, sizeof(I32));
+                       READ_I32(tag);
                        tag = ntohl(tag);
                        svh = av_fetch(cxt->aseen, tag, FALSE);
                        if (!svh)
                        tag = ntohl(tag);
                        svh = av_fetch(cxt->aseen, tag, FALSE);
                        if (!svh)
-                               CROAK(("Object #%d should have been retrieved already", tag));
+                               CROAK(("Object #%"IVdf" should have been retrieved already", (IV)tag));
                        xsv = *svh;
                        ary[i] = SvREFCNT_inc(xsv);
                }
                        xsv = *svh;
                        ary[i] = SvREFCNT_inc(xsv);
                }
@@ -3054,8 +3393,37 @@ stcxt_t *cxt;
 
        BLESS(sv, class);
        hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
 
        BLESS(sv, class);
        hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
-       if (!hook)
-               CROAK(("No STORABLE_thaw defined for objects of class %s", class));
+       if (!hook) {
+               /*
+                * Hook not found.  Maybe they did not require the module where this
+                * hook is defined yet?
+                *
+                * If the require below succeeds, we'll be able to find the hook.
+                * Still, it only works reliably when each class is defined in a
+                * file of its own.
+                */
+
+               SV *psv = newSVpvn("require ", 8);
+               sv_catpv(psv, class);
+
+               TRACEME(("No STORABLE_thaw defined for objects of class %s", class));
+               TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv)));
+
+               perl_eval_sv(psv, G_DISCARD);
+               sv_free(psv);
+
+               /*
+                * We cache results of pkg_can, so we need to uncache before attempting
+                * the lookup again.
+                */
+
+               pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+               hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
+
+               if (!hook)
+                       CROAK(("No STORABLE_thaw defined for objects of class %s "
+                                       "(even after a \"require %s;\")", class, class));
+       }
 
        /*
         * If we don't have an `av' yet, prepare one.
 
        /*
         * If we don't have an `av' yet, prepare one.
@@ -3084,8 +3452,8 @@ stcxt_t *cxt;
         * the object itself being already created by the runtime.
         */
 
         * the object itself being already created by the runtime.
         */
 
-       TRACEME(("calling STORABLE_thaw on %s at 0x%lx (%d args)",
-               class, (unsigned long) sv, AvFILLp(av) + 1));
+       TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)",
+                class, PTR2UV(sv), AvFILLp(av) + 1));
 
        rv = newRV(sv);
        (void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD);
 
        rv = newRV(sv);
        (void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD);
@@ -3101,6 +3469,62 @@ stcxt_t *cxt;
        if (!(flags & SHF_IDX_CLASSNAME) && class != buf)
                Safefree(class);
 
        if (!(flags & SHF_IDX_CLASSNAME) && class != buf)
                Safefree(class);
 
+       /*
+        * If we had an <extra> type, then the object was not as simple, and
+        * we need to restore extra magic now.
+        */
+
+       if (!extra_type)
+               return sv;
+
+       TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv)));
+
+       rv = retrieve(cxt, 0);          /* Retrieve <magic object> */
+
+       TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf,
+               PTR2UV(rv), PTR2UV(sv)));
+
+       switch (extra_type) {
+       case SHT_TSCALAR:
+               sv_upgrade(sv, SVt_PVMG);
+               break;
+       case SHT_TARRAY:
+               sv_upgrade(sv, SVt_PVAV);
+               AvREAL_off((AV *)sv);
+               break;
+       case SHT_THASH:
+               sv_upgrade(sv, SVt_PVHV);
+               break;
+       default:
+               CROAK(("Forgot to deal with extra type %d", extra_type));
+               break;
+       }
+
+       /*
+        * Adding the magic only now, well after the STORABLE_thaw hook was called
+        * means the hook cannot know it deals with an object whose variable is
+        * tied.  But this is happening when retrieving $o in the following case:
+        *
+        *      my %h;
+        *  tie %h, 'FOO';
+        *      my $o = bless \%h, 'BAR';
+        *
+        * The 'BAR' class is NOT the one where %h is tied into.  Therefore, as
+        * far as the 'BAR' class is concerned, the fact that %h is not a REAL
+        * hash but a tied one should not matter at all, and remain transparent.
+        * This means the magic must be restored by Storable AFTER the hook is
+        * called.
+        *
+        * That looks very reasonable to me, but then I've come up with this
+        * after a bug report from David Nesting, who was trying to store such
+        * an object and caused Storable to fail.  And unfortunately, it was
+        * also the easiest way to retrofit support for blessed ref to tied objects
+        * into the existing design.  -- RAM, 17/02/2001
+        */
+
+       sv_magic(sv, rv, mtype, Nullch, 0);
+       SvREFCNT_dec(rv);                       /* Undo refcnt inc from sv_magic() */
+
        return sv;
 }
 
        return sv;
 }
 
@@ -3110,8 +3534,7 @@ stcxt_t *cxt;
  * Retrieve reference to some other scalar.
  * Layout is SX_REF <object>, with SX_REF already read.
  */
  * Retrieve reference to some other scalar.
  * Layout is SX_REF <object>, with SX_REF already read.
  */
-static SV *retrieve_ref(cxt)
-stcxt_t *cxt;
+static SV *retrieve_ref(stcxt_t *cxt, char *cname)
 {
        SV *rv;
        SV *sv;
 {
        SV *rv;
        SV *sv;
@@ -3128,8 +3551,8 @@ stcxt_t *cxt;
         */
 
        rv = NEWSV(10002, 0);
         */
 
        rv = NEWSV(10002, 0);
-       SEEN(rv);                               /* Will return if rv is null */
-       sv = retrieve(cxt);             /* Retrieve <object> */
+       SEEN(rv, cname);                /* Will return if rv is null */
+       sv = retrieve(cxt, 0);  /* Retrieve <object> */
        if (!sv)
                return (SV *) 0;        /* Failed */
 
        if (!sv)
                return (SV *) 0;        /* Failed */
 
@@ -3154,7 +3577,7 @@ stcxt_t *cxt;
        SvRV(rv) = sv;                          /* $rv = \$sv */
        SvROK_on(rv);
 
        SvRV(rv) = sv;                          /* $rv = \$sv */
        SvROK_on(rv);
 
-       TRACEME(("ok (retrieve_ref at 0x%lx)", (unsigned long) rv));
+       TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv)));
 
        return rv;
 }
 
        return rv;
 }
@@ -3165,8 +3588,7 @@ stcxt_t *cxt;
  * Retrieve reference to some other scalar with overloading.
  * Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read.
  */
  * Retrieve reference to some other scalar with overloading.
  * Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read.
  */
-static SV *retrieve_overloaded(cxt)
-stcxt_t *cxt;
+static SV *retrieve_overloaded(stcxt_t *cxt, char *cname)
 {
        SV *rv;
        SV *sv;
 {
        SV *rv;
        SV *sv;
@@ -3179,8 +3601,8 @@ stcxt_t *cxt;
         */
 
        rv = NEWSV(10002, 0);
         */
 
        rv = NEWSV(10002, 0);
-       SEEN(rv);                               /* Will return if rv is null */
-       sv = retrieve(cxt);             /* Retrieve <object> */
+       SEEN(rv, cname);                /* Will return if rv is null */
+       sv = retrieve(cxt, 0);  /* Retrieve <object> */
        if (!sv)
                return (SV *) 0;        /* Failed */
 
        if (!sv)
                return (SV *) 0;        /* Failed */
 
@@ -3198,12 +3620,14 @@ stcxt_t *cxt;
 
        stash = (HV *) SvSTASH (sv);
        if (!stash || !Gv_AMG(stash))
 
        stash = (HV *) SvSTASH (sv);
        if (!stash || !Gv_AMG(stash))
-               CROAK(("Cannot restore overloading on %s(0x%lx)", sv_reftype(sv, FALSE),
-                       (unsigned long) sv));
+               CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)",
+                      sv_reftype(sv, FALSE),
+                      PTR2UV(sv),
+                          stash ? HvNAME(stash) : "<unknown>"));
 
        SvAMAGIC_on(rv);
 
 
        SvAMAGIC_on(rv);
 
-       TRACEME(("ok (retrieve_overloaded at 0x%lx)", (unsigned long) rv));
+       TRACEME(("ok (retrieve_overloaded at 0x%"UVxf")", PTR2UV(rv)));
 
        return rv;
 }
 
        return rv;
 }
@@ -3214,8 +3638,7 @@ stcxt_t *cxt;
  * Retrieve tied array
  * Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
  */
  * Retrieve tied array
  * Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
  */
-static SV *retrieve_tied_array(cxt)
-stcxt_t *cxt;
+static SV *retrieve_tied_array(stcxt_t *cxt, char *cname)
 {
        SV *tv;
        SV *sv;
 {
        SV *tv;
        SV *sv;
@@ -3223,8 +3646,8 @@ stcxt_t *cxt;
        TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
        TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
-       SEEN(tv);                                       /* Will return if tv is null */
-       sv = retrieve(cxt);                     /* Retrieve <object> */
+       SEEN(tv, cname);                        /* Will return if tv is null */
+       sv = retrieve(cxt, 0);          /* Retrieve <object> */
        if (!sv)
                return (SV *) 0;                /* Failed */
 
        if (!sv)
                return (SV *) 0;                /* Failed */
 
@@ -3233,7 +3656,7 @@ stcxt_t *cxt;
        sv_magic(tv, sv, 'P', Nullch, 0);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
        sv_magic(tv, sv, 'P', Nullch, 0);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
-       TRACEME(("ok (retrieve_tied_array at 0x%lx)", (unsigned long) tv));
+       TRACEME(("ok (retrieve_tied_array at 0x%"UVxf")", PTR2UV(tv)));
 
        return tv;
 }
 
        return tv;
 }
@@ -3244,8 +3667,7 @@ stcxt_t *cxt;
  * Retrieve tied hash
  * Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read.
  */
  * Retrieve tied hash
  * Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read.
  */
-static SV *retrieve_tied_hash(cxt)
-stcxt_t *cxt;
+static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname)
 {
        SV *tv;
        SV *sv;
 {
        SV *tv;
        SV *sv;
@@ -3253,8 +3675,8 @@ stcxt_t *cxt;
        TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
        TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
-       SEEN(tv);                                       /* Will return if tv is null */
-       sv = retrieve(cxt);                     /* Retrieve <object> */
+       SEEN(tv, cname);                        /* Will return if tv is null */
+       sv = retrieve(cxt, 0);          /* Retrieve <object> */
        if (!sv)
                return (SV *) 0;                /* Failed */
 
        if (!sv)
                return (SV *) 0;                /* Failed */
 
@@ -3262,7 +3684,7 @@ stcxt_t *cxt;
        sv_magic(tv, sv, 'P', Nullch, 0);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
        sv_magic(tv, sv, 'P', Nullch, 0);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
-       TRACEME(("ok (retrieve_tied_hash at 0x%lx)", (unsigned long) tv));
+       TRACEME(("ok (retrieve_tied_hash at 0x%"UVxf")", PTR2UV(tv)));
 
        return tv;
 }
 
        return tv;
 }
@@ -3273,8 +3695,7 @@ stcxt_t *cxt;
  * Retrieve tied scalar
  * Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read.
  */
  * Retrieve tied scalar
  * Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read.
  */
-static SV *retrieve_tied_scalar(cxt)
-stcxt_t *cxt;
+static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname)
 {
        SV *tv;
        SV *sv;
 {
        SV *tv;
        SV *sv;
@@ -3282,8 +3703,8 @@ stcxt_t *cxt;
        TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
        TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
-       SEEN(tv);                                       /* Will return if rv is null */
-       sv = retrieve(cxt);                     /* Retrieve <object> */
+       SEEN(tv, cname);                        /* Will return if rv is null */
+       sv = retrieve(cxt, 0);          /* Retrieve <object> */
        if (!sv)
                return (SV *) 0;                /* Failed */
 
        if (!sv)
                return (SV *) 0;                /* Failed */
 
@@ -3291,7 +3712,7 @@ stcxt_t *cxt;
        sv_magic(tv, sv, 'q', Nullch, 0);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
        sv_magic(tv, sv, 'q', Nullch, 0);
        SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
 
-       TRACEME(("ok (retrieve_tied_scalar at 0x%lx)", (unsigned long) tv));
+       TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv)));
 
        return tv;
 }
 
        return tv;
 }
@@ -3302,8 +3723,7 @@ stcxt_t *cxt;
  * Retrieve reference to value in a tied hash.
  * Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read.
  */
  * Retrieve reference to value in a tied hash.
  * Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read.
  */
-static SV *retrieve_tied_key(cxt)
-stcxt_t *cxt;
+static SV *retrieve_tied_key(stcxt_t *cxt, char *cname)
 {
        SV *tv;
        SV *sv;
 {
        SV *tv;
        SV *sv;
@@ -3312,12 +3732,12 @@ stcxt_t *cxt;
        TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
        TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
-       SEEN(tv);                                       /* Will return if tv is null */
-       sv = retrieve(cxt);                     /* Retrieve <object> */
+       SEEN(tv, cname);                        /* Will return if tv is null */
+       sv = retrieve(cxt, 0);          /* Retrieve <object> */
        if (!sv)
                return (SV *) 0;                /* Failed */
 
        if (!sv)
                return (SV *) 0;                /* Failed */
 
-       key = retrieve(cxt);            /* Retrieve <key> */
+       key = retrieve(cxt, 0);         /* Retrieve <key> */
        if (!key)
                return (SV *) 0;                /* Failed */
 
        if (!key)
                return (SV *) 0;                /* Failed */
 
@@ -3335,8 +3755,7 @@ stcxt_t *cxt;
  * Retrieve reference to value in a tied array.
  * Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read.
  */
  * Retrieve reference to value in a tied array.
  * Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read.
  */
-static SV *retrieve_tied_idx(cxt)
-stcxt_t *cxt;
+static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname)
 {
        SV *tv;
        SV *sv;
 {
        SV *tv;
        SV *sv;
@@ -3345,8 +3764,8 @@ stcxt_t *cxt;
        TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
        TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum));
 
        tv = NEWSV(10002, 0);
-       SEEN(tv);                                       /* Will return if tv is null */
-       sv = retrieve(cxt);                     /* Retrieve <object> */
+       SEEN(tv, cname);                        /* Will return if tv is null */
+       sv = retrieve(cxt, 0);          /* Retrieve <object> */
        if (!sv)
                return (SV *) 0;                /* Failed */
 
        if (!sv)
                return (SV *) 0;                /* Failed */
 
@@ -3369,21 +3788,20 @@ stcxt_t *cxt;
  * The scalar is "long" in that <length> is larger than LG_SCALAR so it
  * was not stored on a single byte.
  */
  * The scalar is "long" in that <length> is larger than LG_SCALAR so it
  * was not stored on a single byte.
  */
-static SV *retrieve_lscalar(cxt)
-stcxt_t *cxt;
+static SV *retrieve_lscalar(stcxt_t *cxt, char *cname)
 {
 {
-       STRLEN len;
+       I32 len;
        SV *sv;
 
        RLEN(len);
        SV *sv;
 
        RLEN(len);
-       TRACEME(("retrieve_lscalar (#%d), len = %d", cxt->tagnum, len));
+       TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, len));
 
        /*
         * Allocate an empty scalar of the suitable length.
         */
 
        sv = NEWSV(10002, len);
 
        /*
         * Allocate an empty scalar of the suitable length.
         */
 
        sv = NEWSV(10002, len);
-       SEEN(sv);                       /* Associate this new scalar with tag "tagnum" */
+       SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
 
        /*
         * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
 
        /*
         * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
@@ -3398,10 +3816,11 @@ 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 */
        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 %d '%s'", len, SvPVX(sv)));
-       TRACEME(("ok (retrieve_lscalar at 0x%lx)", (unsigned long) sv));
+       TRACEME(("large scalar len %"IVdf" '%s'", len, SvPVX(sv)));
+       TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv)));
 
        return sv;
 }
 
        return sv;
 }
@@ -3415,8 +3834,7 @@ stcxt_t *cxt;
  * The scalar is "short" so <length> is single byte. If it is 0, there
  * is no <data> section.
  */
  * The scalar is "short" so <length> is single byte. If it is 0, there
  * is no <data> section.
  */
-static SV *retrieve_scalar(cxt)
-stcxt_t *cxt;
+static SV *retrieve_scalar(stcxt_t *cxt, char *cname)
 {
        int len;
        SV *sv;
 {
        int len;
        SV *sv;
@@ -3429,7 +3847,7 @@ stcxt_t *cxt;
         */
 
        sv = NEWSV(10002, len);
         */
 
        sv = NEWSV(10002, len);
-       SEEN(sv);                       /* Associate this new scalar with tag "tagnum" */
+       SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
 
        /*
         * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
 
        /*
         * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
@@ -3443,7 +3861,7 @@ stcxt_t *cxt;
                sv_upgrade(sv, SVt_PV);
                SvGROW(sv, 1);
                *SvEND(sv) = '\0';                      /* Ensure it's null terminated anyway */
                sv_upgrade(sv, SVt_PV);
                SvGROW(sv, 1);
                *SvEND(sv) = '\0';                      /* Ensure it's null terminated anyway */
-               TRACEME(("ok (retrieve_scalar empty at 0x%lx)", (unsigned long) sv));
+               TRACEME(("ok (retrieve_scalar empty at 0x%"UVxf")", PTR2UV(sv)));
        } else {
                /*
                 * Now, for efficiency reasons, read data directly inside the SV buffer,
        } else {
                /*
                 * Now, for efficiency reasons, read data directly inside the SV buffer,
@@ -3458,9 +3876,48 @@ stcxt_t *cxt;
        }
 
        (void) SvPOK_only(sv);                  /* Validate string pointer */
        }
 
        (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, char *cname)
+{
+       SV *sv;
+
+       TRACEME(("retrieve_utf8str"));
+
+       sv = retrieve_scalar(cxt, cname);
+       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, char *cname)
+{
+       SV *sv;
+
+       TRACEME(("retrieve_lutf8str"));
+
+       sv = retrieve_lscalar(cxt, cname);
+       if (sv)
+               SvUTF8_on(sv);
 
 
-       TRACEME(("ok (retrieve_scalar at 0x%lx)", (unsigned long) sv));
        return sv;
 }
 
        return sv;
 }
 
@@ -3470,8 +3927,7 @@ stcxt_t *cxt;
  * Retrieve defined integer.
  * Layout is SX_INTEGER <data>, whith SX_INTEGER already read.
  */
  * Retrieve defined integer.
  * Layout is SX_INTEGER <data>, whith SX_INTEGER already read.
  */
-static SV *retrieve_integer(cxt)
-stcxt_t *cxt;
+static SV *retrieve_integer(stcxt_t *cxt, char *cname)
 {
        SV *sv;
        IV iv;
 {
        SV *sv;
        IV iv;
@@ -3480,10 +3936,10 @@ stcxt_t *cxt;
 
        READ(&iv, sizeof(iv));
        sv = newSViv(iv);
 
        READ(&iv, sizeof(iv));
        sv = newSViv(iv);
-       SEEN(sv);                       /* Associate this new scalar with tag "tagnum" */
+       SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
 
 
-       TRACEME(("integer %d", iv));
-       TRACEME(("ok (retrieve_integer at 0x%lx)", (unsigned long) sv));
+       TRACEME(("integer %"IVdf, iv));
+       TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv)));
 
        return sv;
 }
 
        return sv;
 }
@@ -3494,15 +3950,14 @@ stcxt_t *cxt;
  * Retrieve defined integer in network order.
  * Layout is SX_NETINT <data>, whith SX_NETINT already read.
  */
  * Retrieve defined integer in network order.
  * Layout is SX_NETINT <data>, whith SX_NETINT already read.
  */
-static SV *retrieve_netint(cxt)
-stcxt_t *cxt;
+static SV *retrieve_netint(stcxt_t *cxt, char *cname)
 {
        SV *sv;
 {
        SV *sv;
-       int iv;
+       I32 iv;
 
        TRACEME(("retrieve_netint (#%d)", cxt->tagnum));
 
 
        TRACEME(("retrieve_netint (#%d)", cxt->tagnum));
 
-       READ(&iv, sizeof(iv));
+       READ_I32(iv);
 #ifdef HAS_NTOHL
        sv = newSViv((int) ntohl(iv));
        TRACEME(("network integer %d", (int) ntohl(iv)));
 #ifdef HAS_NTOHL
        sv = newSViv((int) ntohl(iv));
        TRACEME(("network integer %d", (int) ntohl(iv)));
@@ -3510,9 +3965,9 @@ stcxt_t *cxt;
        sv = newSViv(iv);
        TRACEME(("network integer (as-is) %d", iv));
 #endif
        sv = newSViv(iv);
        TRACEME(("network integer (as-is) %d", iv));
 #endif
-       SEEN(sv);                       /* Associate this new scalar with tag "tagnum" */
+       SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
 
 
-       TRACEME(("ok (retrieve_netint at 0x%lx)", (unsigned long) sv));
+       TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv)));
 
        return sv;
 }
 
        return sv;
 }
@@ -3523,20 +3978,19 @@ stcxt_t *cxt;
  * Retrieve defined double.
  * Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read.
  */
  * Retrieve defined double.
  * Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read.
  */
-static SV *retrieve_double(cxt)
-stcxt_t *cxt;
+static SV *retrieve_double(stcxt_t *cxt, char *cname)
 {
        SV *sv;
 {
        SV *sv;
-       double nv;
+       NV nv;
 
        TRACEME(("retrieve_double (#%d)", cxt->tagnum));
 
        READ(&nv, sizeof(nv));
        sv = newSVnv(nv);
 
        TRACEME(("retrieve_double (#%d)", cxt->tagnum));
 
        READ(&nv, sizeof(nv));
        sv = newSVnv(nv);
-       SEEN(sv);                       /* Associate this new scalar with tag "tagnum" */
+       SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
 
 
-       TRACEME(("double %lf", nv));
-       TRACEME(("ok (retrieve_double at 0x%lx)", (unsigned long) sv));
+       TRACEME(("double %"NVff, nv));
+       TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv)));
 
        return sv;
 }
 
        return sv;
 }
@@ -3547,21 +4001,24 @@ stcxt_t *cxt;
  * Retrieve defined byte (small integer within the [-128, +127] range).
  * Layout is SX_BYTE <data>, whith SX_BYTE already read.
  */
  * Retrieve defined byte (small integer within the [-128, +127] range).
  * Layout is SX_BYTE <data>, whith SX_BYTE already read.
  */
-static SV *retrieve_byte(cxt)
-stcxt_t *cxt;
+static SV *retrieve_byte(stcxt_t *cxt, char *cname)
 {
        SV *sv;
        int siv;
 {
        SV *sv;
        int siv;
+       signed char tmp; /* must use temp var to work around
+                           an AIX compiler bug --H.Merijn Brand */
 
        TRACEME(("retrieve_byte (#%d)", cxt->tagnum));
 
        GETMARK(siv);
        TRACEME(("small integer read as %d", (unsigned char) siv));
 
        TRACEME(("retrieve_byte (#%d)", cxt->tagnum));
 
        GETMARK(siv);
        TRACEME(("small integer read as %d", (unsigned char) siv));
-       sv = newSViv((unsigned char) siv - 128);
-       SEEN(sv);                       /* Associate this new scalar with tag "tagnum" */
+       tmp = ((unsigned char)siv) - 128;
+       sv = newSViv (tmp);
+
+       SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
 
 
-       TRACEME(("byte %d", (unsigned char) siv - 128));
-       TRACEME(("ok (retrieve_byte at 0x%lx)", (unsigned long) sv));
+       TRACEME(("byte %d", tmp));
+       TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv)));
 
        return sv;
 }
 
        return sv;
 }
@@ -3571,15 +4028,14 @@ stcxt_t *cxt;
  *
  * Return the undefined value.
  */
  *
  * Return the undefined value.
  */
-static SV *retrieve_undef(cxt)
-stcxt_t *cxt;
+static SV *retrieve_undef(stcxt_t *cxt, char *cname)
 {
        SV* sv;
 
        TRACEME(("retrieve_undef"));
 
        sv = newSV(0);
 {
        SV* sv;
 
        TRACEME(("retrieve_undef"));
 
        sv = newSV(0);
-       SEEN(sv);
+       SEEN(sv, cname);
 
        return sv;
 }
 
        return sv;
 }
@@ -3589,14 +4045,13 @@ stcxt_t *cxt;
  *
  * Return the immortal undefined value.
  */
  *
  * Return the immortal undefined value.
  */
-static SV *retrieve_sv_undef(cxt)
-stcxt_t *cxt;
+static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname)
 {
        SV *sv = &PL_sv_undef;
 
        TRACEME(("retrieve_sv_undef"));
 
 {
        SV *sv = &PL_sv_undef;
 
        TRACEME(("retrieve_sv_undef"));
 
-       SEEN(sv);
+       SEEN(sv, cname);
        return sv;
 }
 
        return sv;
 }
 
@@ -3605,14 +4060,13 @@ stcxt_t *cxt;
  *
  * Return the immortal yes value.
  */
  *
  * Return the immortal yes value.
  */
-static SV *retrieve_sv_yes(cxt)
-stcxt_t *cxt;
+static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname)
 {
        SV *sv = &PL_sv_yes;
 
        TRACEME(("retrieve_sv_yes"));
 
 {
        SV *sv = &PL_sv_yes;
 
        TRACEME(("retrieve_sv_yes"));
 
-       SEEN(sv);
+       SEEN(sv, cname);
        return sv;
 }
 
        return sv;
 }
 
@@ -3621,14 +4075,13 @@ stcxt_t *cxt;
  *
  * Return the immortal no value.
  */
  *
  * Return the immortal no value.
  */
-static SV *retrieve_sv_no(cxt)
-stcxt_t *cxt;
+static SV *retrieve_sv_no(stcxt_t *cxt, char *cname)
 {
        SV *sv = &PL_sv_no;
 
        TRACEME(("retrieve_sv_no"));
 
 {
        SV *sv = &PL_sv_no;
 
        TRACEME(("retrieve_sv_no"));
 
-       SEEN(sv);
+       SEEN(sv, cname);
        return sv;
 }
 
        return sv;
 }
 
@@ -3641,8 +4094,7 @@ stcxt_t *cxt;
  *
  * When we come here, SX_ARRAY has been read already.
  */
  *
  * When we come here, SX_ARRAY has been read already.
  */
-static SV *retrieve_array(cxt)
-stcxt_t *cxt;
+static SV *retrieve_array(stcxt_t *cxt, char *cname)
 {
        I32 len;
        I32 i;
 {
        I32 len;
        I32 i;
@@ -3658,7 +4110,7 @@ stcxt_t *cxt;
        RLEN(len);
        TRACEME(("size = %d", len));
        av = newAV();
        RLEN(len);
        TRACEME(("size = %d", len));
        av = newAV();
-       SEEN(av);                                       /* Will return if array not allocated nicely */
+       SEEN(av, cname);                        /* Will return if array not allocated nicely */
        if (len)
                av_extend(av, len);
        else
        if (len)
                av_extend(av, len);
        else
@@ -3670,14 +4122,14 @@ stcxt_t *cxt;
 
        for (i = 0; i < len; i++) {
                TRACEME(("(#%d) item", i));
 
        for (i = 0; i < len; i++) {
                TRACEME(("(#%d) item", i));
-               sv = retrieve(cxt);                             /* Retrieve item */
+               sv = retrieve(cxt, 0);                  /* Retrieve item */
                if (!sv)
                        return (SV *) 0;
                if (av_store(av, i, sv) == 0)
                        return (SV *) 0;
        }
 
                if (!sv)
                        return (SV *) 0;
                if (av_store(av, i, sv) == 0)
                        return (SV *) 0;
        }
 
-       TRACEME(("ok (retrieve_array at 0x%lx)", (unsigned long) av));
+       TRACEME(("ok (retrieve_array at 0x%"UVxf")", PTR2UV(av)));
 
        return (SV *) av;
 }
 
        return (SV *) av;
 }
@@ -3693,15 +4145,13 @@ stcxt_t *cxt;
  *
  * When we come here, SX_HASH has been read already.
  */
  *
  * When we come here, SX_HASH has been read already.
  */
-static SV *retrieve_hash(cxt)
-stcxt_t *cxt;
+static SV *retrieve_hash(stcxt_t *cxt, char *cname)
 {
        I32 len;
        I32 size;
        I32 i;
        HV *hv;
        SV *sv;
 {
        I32 len;
        I32 size;
        I32 i;
        HV *hv;
        SV *sv;
-       static SV *sv_h_undef = (SV *) 0;               /* hv_store() bug */
 
        TRACEME(("retrieve_hash (#%d)", cxt->tagnum));
 
 
        TRACEME(("retrieve_hash (#%d)", cxt->tagnum));
 
@@ -3712,7 +4162,7 @@ stcxt_t *cxt;
        RLEN(len);
        TRACEME(("size = %d", len));
        hv = newHV();
        RLEN(len);
        TRACEME(("size = %d", len));
        hv = newHV();
-       SEEN(hv);                       /* Will return if table not allocated properly */
+       SEEN(hv, cname);                /* Will return if table not allocated properly */
        if (len == 0)
                return (SV *) hv;       /* No data follow if table empty */
 
        if (len == 0)
                return (SV *) hv;       /* No data follow if table empty */
 
@@ -3726,7 +4176,7 @@ stcxt_t *cxt;
                 */
 
                TRACEME(("(#%d) value", i));
                 */
 
                TRACEME(("(#%d) value", i));
-               sv = retrieve(cxt);
+               sv = retrieve(cxt, 0);
                if (!sv)
                        return (SV *) 0;
 
                if (!sv)
                        return (SV *) 0;
 
@@ -3752,7 +4202,7 @@ stcxt_t *cxt;
                        return (SV *) 0;
        }
 
                        return (SV *) 0;
        }
 
-       TRACEME(("ok (retrieve_hash at 0x%lx)", (unsigned long) hv));
+       TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv)));
 
        return (SV *) hv;
 }
 
        return (SV *) hv;
 }
@@ -3767,8 +4217,7 @@ stcxt_t *cxt;
  *
  * When we come here, SX_ARRAY has been read already.
  */
  *
  * When we come here, SX_ARRAY has been read already.
  */
-static SV *old_retrieve_array(cxt)
-stcxt_t *cxt;
+static SV *old_retrieve_array(stcxt_t *cxt, char *cname)
 {
        I32 len;
        I32 i;
 {
        I32 len;
        I32 i;
@@ -3785,7 +4234,7 @@ stcxt_t *cxt;
        RLEN(len);
        TRACEME(("size = %d", len));
        av = newAV();
        RLEN(len);
        TRACEME(("size = %d", len));
        av = newAV();
-       SEEN(av);                                       /* Will return if array not allocated nicely */
+       SEEN(av, 0);                            /* Will return if array not allocated nicely */
        if (len)
                av_extend(av, len);
        else
        if (len)
                av_extend(av, len);
        else
@@ -3802,16 +4251,16 @@ stcxt_t *cxt;
                        continue;                       /* av_extend() already filled us with undef */
                }
                if (c != SX_ITEM)
                        continue;                       /* av_extend() already filled us with undef */
                }
                if (c != SX_ITEM)
-                       (void) retrieve_other(0);       /* Will croak out */
+                       (void) retrieve_other((stcxt_t *) 0, 0);        /* Will croak out */
                TRACEME(("(#%d) item", i));
                TRACEME(("(#%d) item", i));
-               sv = retrieve(cxt);                             /* Retrieve item */
+               sv = retrieve(cxt, 0);                                          /* Retrieve item */
                if (!sv)
                        return (SV *) 0;
                if (av_store(av, i, sv) == 0)
                        return (SV *) 0;
        }
 
                if (!sv)
                        return (SV *) 0;
                if (av_store(av, i, sv) == 0)
                        return (SV *) 0;
        }
 
-       TRACEME(("ok (old_retrieve_array at 0x%lx)", (unsigned long) av));
+       TRACEME(("ok (old_retrieve_array at 0x%"UVxf")", PTR2UV(av)));
 
        return (SV *) av;
 }
 
        return (SV *) av;
 }
@@ -3828,14 +4277,13 @@ stcxt_t *cxt;
  *
  * When we come here, SX_HASH has been read already.
  */
  *
  * When we come here, SX_HASH has been read already.
  */
-static SV *old_retrieve_hash(cxt)
-stcxt_t *cxt;
+static SV *old_retrieve_hash(stcxt_t *cxt, char *cname)
 {
        I32 len;
        I32 size;
        I32 i;
        HV *hv;
 {
        I32 len;
        I32 size;
        I32 i;
        HV *hv;
-       SV *sv;
+       SV *sv=NULL;
        int c;
        static SV *sv_h_undef = (SV *) 0;               /* hv_store() bug */
 
        int c;
        static SV *sv_h_undef = (SV *) 0;               /* hv_store() bug */
 
@@ -3848,7 +4296,7 @@ stcxt_t *cxt;
        RLEN(len);
        TRACEME(("size = %d", len));
        hv = newHV();
        RLEN(len);
        TRACEME(("size = %d", len));
        hv = newHV();
-       SEEN(hv);                               /* Will return if table not allocated properly */
+       SEEN(hv, 0);                    /* Will return if table not allocated properly */
        if (len == 0)
                return (SV *) hv;       /* No data follow if table empty */
 
        if (len == 0)
                return (SV *) hv;       /* No data follow if table empty */
 
@@ -3874,11 +4322,11 @@ stcxt_t *cxt;
                        sv = SvREFCNT_inc(sv_h_undef);
                } else if (c == SX_VALUE) {
                        TRACEME(("(#%d) value", i));
                        sv = SvREFCNT_inc(sv_h_undef);
                } else if (c == SX_VALUE) {
                        TRACEME(("(#%d) value", i));
-                       sv = retrieve(cxt);
+                       sv = retrieve(cxt, 0);
                        if (!sv)
                                return (SV *) 0;
                } else
                        if (!sv)
                                return (SV *) 0;
                } else
-                       (void) retrieve_other(0);       /* Will croak out */
+                       (void) retrieve_other((stcxt_t *) 0, 0);        /* Will croak out */
 
                /*
                 * Get key.
 
                /*
                 * Get key.
@@ -3889,7 +4337,7 @@ stcxt_t *cxt;
 
                GETMARK(c);
                if (c != SX_KEY)
 
                GETMARK(c);
                if (c != SX_KEY)
-                       (void) retrieve_other(0);       /* Will croak out */
+                       (void) retrieve_other((stcxt_t *) 0, 0);        /* Will croak out */
                RLEN(size);                                             /* Get key size */
                KBUFCHK(size);                                  /* Grow hash key read pool if needed */
                if (size)
                RLEN(size);                                             /* Get key size */
                KBUFCHK(size);                                  /* Grow hash key read pool if needed */
                if (size)
@@ -3905,7 +4353,7 @@ stcxt_t *cxt;
                        return (SV *) 0;
        }
 
                        return (SV *) 0;
        }
 
-       TRACEME(("ok (retrieve_hash at 0x%lx)", (unsigned long) hv));
+       TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv)));
 
        return (SV *) hv;
 }
 
        return (SV *) hv;
 }
@@ -3925,8 +4373,7 @@ stcxt_t *cxt;
  * Note that there's no byte ordering info emitted when network order was
  * used at store time.
  */
  * Note that there's no byte ordering info emitted when network order was
  * used at store time.
  */
-static SV *magic_check(cxt)
-stcxt_t *cxt;
+static SV *magic_check(stcxt_t *cxt)
 {
        char buf[256];
        char byteorder[256];
 {
        char buf[256];
        char byteorder[256];
@@ -4012,7 +4459,7 @@ magic_ok:
         * information to check.
         */
 
         * information to check.
         */
 
-       if (cxt->netorder = (use_network_order & 0x1))
+       if ((cxt->netorder = (use_network_order & 0x1)))
                return &PL_sv_undef;                    /* No byte ordering info */
 
        sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
                return &PL_sv_undef;                    /* No byte ordering info */
 
        sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
@@ -4035,6 +4482,12 @@ magic_ok:
        if ((int) c != sizeof(char *))
                CROAK(("Pointer integer size is not compatible"));
 
        if ((int) c != sizeof(char *))
                CROAK(("Pointer integer size is not compatible"));
 
+       if (version_major >= 2 && version_minor >= 2) {
+               GETMARK(c);             /* sizeof(NV) */
+               if ((int) c != sizeof(NV))
+                       CROAK(("Double size is not compatible"));
+       }
+
        return &PL_sv_undef;    /* OK */
 }
 
        return &PL_sv_undef;    /* OK */
 }
 
@@ -4045,8 +4498,7 @@ magic_ok:
  * root SV (which may be an AV or an HV for what we care).
  * Returns null if there is a problem.
  */
  * root SV (which may be an AV or an HV for what we care).
  * Returns null if there is a problem.
  */
-static SV *retrieve(cxt)
-stcxt_t *cxt;
+static SV *retrieve(stcxt_t *cxt, char *cname)
 {
        int type;
        SV **svh;
 {
        int type;
        SV **svh;
@@ -4078,7 +4530,7 @@ stcxt_t *cxt;
                        I32 tagn;
                        svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
                        if (!svh)
                        I32 tagn;
                        svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
                        if (!svh)
-                               CROAK(("Old tag 0x%x should have been mapped already", tag));
+                               CROAK(("Old tag 0x%"UVxf" should have been mapped already", (UV)tag));
                        tagn = SvIV(*svh);      /* Mapped tag number computed earlier below */
 
                        /*
                        tagn = SvIV(*svh);      /* Mapped tag number computed earlier below */
 
                        /*
@@ -4087,9 +4539,9 @@ stcxt_t *cxt;
 
                        svh = av_fetch(cxt->aseen, tagn, FALSE);
                        if (!svh)
 
                        svh = av_fetch(cxt->aseen, tagn, FALSE);
                        if (!svh)
-                               CROAK(("Object #%d should have been retrieved already", tagn));
+                               CROAK(("Object #%"IVdf" should have been retrieved already", (IV)tagn));
                        sv = *svh;
                        sv = *svh;
-                       TRACEME(("has retrieved #%d at 0x%lx", tagn, (unsigned long) sv));
+                       TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv)));
                        SvREFCNT_inc(sv);       /* One more reference to this same sv */
                        return sv;                      /* The SV pointer where object was retrieved */
                }
                        SvREFCNT_inc(sv);       /* One more reference to this same sv */
                        return sv;                      /* The SV pointer where object was retrieved */
                }
@@ -4124,13 +4576,14 @@ again:
 
        if (type == SX_OBJECT) {
                I32 tag;
 
        if (type == SX_OBJECT) {
                I32 tag;
-               READ(&tag, sizeof(I32));
+               READ_I32(tag);
                tag = ntohl(tag);
                svh = av_fetch(cxt->aseen, tag, FALSE);
                if (!svh)
                tag = ntohl(tag);
                svh = av_fetch(cxt->aseen, tag, FALSE);
                if (!svh)
-                       CROAK(("Object #%d should have been retrieved already", tag));
+                   CROAK(("Object #%"IVdf" should have been retrieved already",
+                           (IV)tag));
                sv = *svh;
                sv = *svh;
-               TRACEME(("had retrieved #%d at 0x%lx", tag, (unsigned long) sv));
+               TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv)));
                SvREFCNT_inc(sv);       /* One more reference to this same sv */
                return sv;                      /* The SV pointer where object was retrieved */
        }
                SvREFCNT_inc(sv);       /* One more reference to this same sv */
                return sv;                      /* The SV pointer where object was retrieved */
        }
@@ -4141,7 +4594,7 @@ first_time:               /* Will disappear when support for old format is dropped */
         * Okay, first time through for this one.
         */
 
         * Okay, first time through for this one.
         */
 
-       sv = RETRIEVE(cxt, type)(cxt);
+       sv = RETRIEVE(cxt, type)(cxt, cname);
        if (!sv)
                return (SV *) 0;                        /* Failed */
 
        if (!sv)
                return (SV *) 0;                        /* Failed */
 
@@ -4179,7 +4632,7 @@ first_time:               /* Will disappear when support for old format is dropped */
                }
        }
 
                }
        }
 
-       TRACEME(("ok (retrieved 0x%lx, refcnt=%d, %s)", (unsigned long) sv,
+       TRACEME(("ok (retrieved 0x%"UVxf", refcnt=%d, %s)", PTR2UV(sv),
                SvREFCNT(sv) - 1, sv_reftype(sv, FALSE)));
 
        return sv;      /* Ok */
                SvREFCNT(sv) - 1, sv_reftype(sv, FALSE)));
 
        return sv;      /* Ok */
@@ -4191,13 +4644,14 @@ first_time:             /* Will disappear when support for old format is dropped */
  * Retrieve data held in file and return the root object.
  * Common routine for pretrieve and mretrieve.
  */
  * Retrieve data held in file and return the root object.
  * Common routine for pretrieve and mretrieve.
  */
-static SV *do_retrieve(f, in, optype)
-PerlIO *f;
-SV *in;
-int optype;
+static SV *do_retrieve(
+       PerlIO *f,
+       SV *in,
+       int optype)
 {
        dSTCXT;
        SV *sv;
 {
        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));
        struct extendable msave;        /* Where potentially valid mbuf is saved */
 
        TRACEME(("do_retrieve (optype = 0x%x)", optype));
@@ -4220,7 +4674,7 @@ int optype;
         * free up memory for them now.
         */
 
         * free up memory for them now.
         */
 
-       if (cxt->dirty)
+       if (cxt->s_dirty)
                clean_context(cxt);
 
        /*
                clean_context(cxt);
 
        /*
@@ -4234,7 +4688,7 @@ int optype;
        cxt->entry++;
 
        ASSERT(cxt->entry == 1, ("starting new recursion"));
        cxt->entry++;
 
        ASSERT(cxt->entry == 1, ("starting new recursion"));
-       ASSERT(!cxt->dirty, ("clean context"));
+       ASSERT(!cxt->s_dirty, ("clean context"));
 
        /*
         * Prepare context.
 
        /*
         * Prepare context.
@@ -4269,11 +4723,23 @@ int optype;
        TRACEME(("data stored in %s format",
                cxt->netorder ? "net order" : "native"));
 
        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"));
 
 
        ASSERT(is_retrieving(), ("within retrieve operation"));
 
-       sv = retrieve(cxt);             /* Recursively retrieve object, get root SV */
+       sv = retrieve(cxt, 0);          /* Recursively retrieve object, get root SV */
 
        /*
         * Final cleanup.
 
        /*
         * Final cleanup.
@@ -4299,8 +4765,8 @@ int optype;
                return &PL_sv_undef;            /* Something went wrong, return undef */
        }
 
                return &PL_sv_undef;            /* Something went wrong, return undef */
        }
 
-       TRACEME(("retrieve got %s(0x%lx)",
-               sv_reftype(sv, FALSE), (unsigned long) sv));
+       TRACEME(("retrieve got %s(0x%"UVxf")",
+               sv_reftype(sv, FALSE), PTR2UV(sv)));
 
        /*
         * Backward compatibility with Storable-0.5@9 (which we know we
 
        /*
         * Backward compatibility with Storable-0.5@9 (which we know we
@@ -4355,8 +4821,7 @@ int optype;
  *
  * Retrieve data held in file and return the root object, undef on error.
  */
  *
  * Retrieve data held in file and return the root object, undef on error.
  */
-SV *pretrieve(f)
-PerlIO *f;
+SV *pretrieve(PerlIO *f)
 {
        TRACEME(("pretrieve"));
        return do_retrieve(f, Nullsv, 0);
 {
        TRACEME(("pretrieve"));
        return do_retrieve(f, Nullsv, 0);
@@ -4367,11 +4832,10 @@ PerlIO *f;
  *
  * Retrieve data held in scalar and return the root object, undef on error.
  */
  *
  * Retrieve data held in scalar and return the root object, undef on error.
  */
-SV *mretrieve(sv)
-SV *sv;
+SV *mretrieve(SV *sv)
 {
        TRACEME(("mretrieve"));
 {
        TRACEME(("mretrieve"));
-       return do_retrieve((PerlIO*)0, sv, 0);
+       return do_retrieve((PerlIO*) 0, sv, 0);
 }
 
 /***
 }
 
 /***
@@ -4387,8 +4851,7 @@ SV *sv;
  * there. Not that efficient, but it should be faster than doing it from
  * pure perl anyway.
  */
  * there. Not that efficient, but it should be faster than doing it from
  * pure perl anyway.
  */
-SV *dclone(sv)
-SV *sv;
+SV *dclone(SV *sv)
 {
        dSTCXT;
        int size;
 {
        dSTCXT;
        int size;
@@ -4402,7 +4865,7 @@ SV *sv;
         * free up memory for them now.
         */
 
         * free up memory for them now.
         */
 
-       if (cxt->dirty)
+       if (cxt->s_dirty)
                clean_context(cxt);
 
        /*
                clean_context(cxt);
 
        /*
@@ -4410,7 +4873,7 @@ SV *sv;
         * we need to allocate one because we're deep cloning from a hook.
         */
 
         * we need to allocate one because we're deep cloning from a hook.
         */
 
-       if (!do_store((PerlIO*)0, sv, ST_CLONE, FALSE, (SV**)0))
+       if (!do_store((PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0))
                return &PL_sv_undef;                            /* Error during store */
 
        /*
                return &PL_sv_undef;                            /* Error during store */
 
        /*
@@ -4425,16 +4888,25 @@ SV *sv;
         * Now, `cxt' may refer to a new context.
         */
 
         * 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));
        ASSERT(!cxt->entry, ("entry will not cause new context allocation"));
 
        size = MBUF_SIZE();
        TRACEME(("dclone stored %d bytes", size));
-
        MBUF_INIT(size);
        MBUF_INIT(size);
-       out = do_retrieve((PerlIO*)0, Nullsv, ST_CLONE);        /* Will free non-root context */
 
 
-       TRACEME(("dclone returns 0x%lx", (unsigned long) out));
+       /*
+        * 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)));
 
        return out;
 }
 
        return out;
 }
Unnamed repository; edit this file 'description' to name the repository.