ext/Storable/Storable.xs

   1 /*
   2  * Store and retrieve mechanism.
   3  */
   4
   5 /*
   6  * $Id: Storable.xs,v 1.0.1.10 2001/08/28 21:52:14 ram Exp $
   7  *
   8  *  Copyright (c) 1995-2000, Raphael Manfredi
   9  *
  10  *  You may redistribute only under the same terms as Perl 5, as specified
  11  *  in the README file that comes with the distribution.
  12  *
  13  * $Log: Storable.xs,v $
  14  * Revision 1.0.1.10  2001/08/28 21:52:14  ram
  15  * patch13: removed spurious debugging messages
  16  *
  17  * Revision 1.0.1.9  2001/07/01 11:25:02  ram
  18  * patch12: fixed memory corruption on croaks during thaw()
  19  * patch12: made code compile cleanly with -Wall (Jarkko Hietaniemi)
  20  * patch12: changed tagnum and classnum from I32 to IV in context
  21  *
  22  * Revision 1.0.1.8  2001/03/15 00:20:55  ram
  23  * patch11: last version was wrongly compiling with assertions on
  24  *
  25  * Revision 1.0.1.7  2001/02/17 12:25:26  ram
  26  * patch8: now bless objects ASAP at retrieve time
  27  * patch8: added support for blessed ref to tied structures
  28  *
  29  * Revision 1.0.1.6  2001/01/03 09:40:40  ram
  30  * patch7: prototype and casting cleanup
  31  * patch7: trace offending package when overloading cannot be restored
  32  * patch7: made context cleanup safer to avoid dup freeing
  33  *
  34  * Revision 1.0.1.5  2000/11/05 17:21:24  ram
  35  * patch6: fixed severe "object lost" bug for STORABLE_freeze returns
  36  *
  37  * Revision 1.0.1.4  2000/10/26 17:11:04  ram
  38  * patch5: auto requires module of blessed ref when STORABLE_thaw misses
  39  *
  40  * Revision 1.0.1.3  2000/09/29 19:49:57  ram
  41  * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp
  42  *
  43  * Revision 1.0.1.2  2000/09/28 21:43:10  ram
  44  * patch2: perls before 5.004_04 lack newSVpvn
  45  *
  46  * Revision 1.0.1.1  2000/09/17 16:47:49  ram
  47  * patch1: now only taint retrieved data when source was tainted
  48  * patch1: added support for UTF-8 strings
  49  * patch1: fixed store hook bug: was allocating class id too soon
  50  *
  51  * Revision 1.0  2000/09/01 19:40:41  ram
  52  * Baseline for first official release.
  53  *
  54  */
  55
  56 #include <EXTERN.h>
  57 #include <perl.h>
  58 #include <patchlevel.h>         /* Perl's one, needed since 5.6 */
  59 #include <XSUB.h>
  60
  61 #ifndef NETWARE
  62 #if 0
  63 #define DEBUGME /* Debug mode, turns assertions on as well */
  64 #define DASSERT /* Assertion mode */
  65 #endif
  66 #else   /* NETWARE */
  67 #if 0   /* On NetWare USE_PERLIO is not used */
  68 #define DEBUGME /* Debug mode, turns assertions on as well */
  69 #define DASSERT /* Assertion mode */
  70 #endif
  71 #endif
  72
  73 /*
  74  * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined
  75  * Provide them with the necessary defines so they can build with pre-5.004.
  76  */
  77 #ifndef USE_PERLIO
  78 #ifndef PERLIO_IS_STDIO
  79 #define PerlIO FILE
  80 #define PerlIO_getc(x) getc(x)
  81 #define PerlIO_putc(f,x) putc(x,f)
  82 #define PerlIO_read(x,y,z) fread(y,1,z,x)
  83 #define PerlIO_write(x,y,z) fwrite(y,1,z,x)
  84 #define PerlIO_stdoutf printf
  85 #endif  /* PERLIO_IS_STDIO */
  86 #endif  /* USE_PERLIO */
  87
  88 /*
  89  * Earlier versions of perl might be used, we can't assume they have the latest!
  90  */
  91
  92 #ifndef PERL_VERSION            /* For perls < 5.6 */
  93 #define PERL_VERSION PATCHLEVEL
  94 #ifndef newRV_noinc
  95 #define newRV_noinc(sv)         ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
  96 #endif
  97 #if (PATCHLEVEL <= 4)           /* Older perls (<= 5.004) lack PL_ namespace */
  98 #define PL_sv_yes       sv_yes
  99 #define PL_sv_no        sv_no
 100 #define PL_sv_undef     sv_undef
 101 #if (SUBVERSION <= 4)           /* 5.004_04 has been reported to lack newSVpvn */
 102 #define newSVpvn newSVpv
 103 #endif
 104 #endif                                          /* PATCHLEVEL <= 4 */
 105 #ifndef HvSHAREKEYS_off
 106 #define HvSHAREKEYS_off(hv)     /* Ignore */
 107 #endif
 108 #ifndef AvFILLp                         /* Older perls (<=5.003) lack AvFILLp */
 109 #define AvFILLp AvFILL
 110 #endif
 111 typedef double NV;                      /* Older perls lack the NV type */
 112 #define IVdf            "ld"    /* Various printf formats for Perl types */
 113 #define UVuf            "lu"
 114 #define UVof            "lo"
 115 #define UVxf            "lx"
 116 #define INT2PTR(t,v) (t)(IV)(v)
 117 #define PTR2UV(v)    (unsigned long)(v)
 118 #endif                                          /* PERL_VERSION -- perls < 5.6 */
 119
 120 #ifndef NVef                            /* The following were not part of perl 5.6 */
 121 #if defined(USE_LONG_DOUBLE) && \
 122         defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
 123 #define NVef            PERL_PRIeldbl
 124 #define NVff            PERL_PRIfldbl
 125 #define NVgf            PERL_PRIgldbl
 126 #else
 127 #define NVef            "e"
 128 #define NVff            "f"
 129 #define NVgf            "g"
 130 #endif
 131 #endif
 132
 133 #ifdef DEBUGME
 134
 135 #ifndef DASSERT
 136 #define DASSERT
 137 #endif
 138
 139 /*
 140  * TRACEME() will only output things when the $Storable::DEBUGME is true.
 141  */
 142
 143 #define TRACEME(x)      do {                                                                    \
 144         if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE)))     \
 145                 { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); }                     \
 146 } while (0)
 147 #else
 148 #define TRACEME(x)
 149 #endif  /* DEBUGME */
 150
 151 #ifdef DASSERT
 152 #define ASSERT(x,y)     do {                                                                    \
 153         if (!(x)) {                                                                                             \
 154                 PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ",     \
 155                         __FILE__, __LINE__);                                                    \
 156                 PerlIO_stdoutf y; PerlIO_stdoutf("\n");                         \
 157         }                                                                                                               \
 158 } while (0)
 159 #else
 160 #define ASSERT(x,y)
 161 #endif
 162
 163 /*
 164  * Type markers.
 165  */
 166
 167 #define C(x) ((char) (x))       /* For markers with dynamic retrieval handling */
 168
 169 #define SX_OBJECT       C(0)    /* Already stored object */
 170 #define SX_LSCALAR      C(1)    /* Scalar (large binary) follows (length, data) */
 171 #define SX_ARRAY        C(2)    /* Array forthcominng (size, item list) */
 172 #define SX_HASH         C(3)    /* Hash forthcoming (size, key/value pair list) */
 173 #define SX_REF          C(4)    /* Reference to object forthcoming */
 174 #define SX_UNDEF        C(5)    /* Undefined scalar */
 175 #define SX_INTEGER      C(6)    /* Integer forthcoming */
 176 #define SX_DOUBLE       C(7)    /* Double forthcoming */
 177 #define SX_BYTE         C(8)    /* (signed) byte forthcoming */
 178 #define SX_NETINT       C(9)    /* Integer in network order forthcoming */
 179 #define SX_SCALAR       C(10)   /* Scalar (binary, small) follows (length, data) */
 180 #define SX_TIED_ARRAY  C(11)  /* Tied array forthcoming */
 181 #define SX_TIED_HASH   C(12)  /* Tied hash forthcoming */
 182 #define SX_TIED_SCALAR C(13)  /* Tied scalar forthcoming */
 183 #define SX_SV_UNDEF     C(14)   /* Perl's immortal PL_sv_undef */
 184 #define SX_SV_YES       C(15)   /* Perl's immortal PL_sv_yes */
 185 #define SX_SV_NO        C(16)   /* Perl's immortal PL_sv_no */
 186 #define SX_BLESS        C(17)   /* Object is blessed */
 187 #define SX_IX_BLESS     C(18)   /* Object is blessed, classname given by index */
 188 #define SX_HOOK         C(19)   /* Stored via hook, user-defined */
 189 #define SX_OVERLOAD     C(20)   /* Overloaded reference */
 190 #define SX_TIED_KEY C(21)   /* Tied magic key forthcoming */
 191 #define SX_TIED_IDX C(22)   /* Tied magic index forthcoming */
 192 #define SX_UTF8STR      C(23)   /* UTF-8 string forthcoming (small) */
 193 #define SX_LUTF8STR     C(24)   /* UTF-8 string forthcoming (large) */
 194 #define SX_FLAG_HASH    C(25)   /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
 195 #define SX_ERROR        C(26)   /* Error */
 196
 197 /*
 198  * Those are only used to retrieve "old" pre-0.6 binary images.
 199  */
 200 #define SX_ITEM         'i'             /* An array item introducer */
 201 #define SX_IT_UNDEF     'I'             /* Undefined array item */
 202 #define SX_KEY          'k'             /* A hash key introducer */
 203 #define SX_VALUE        'v'             /* A hash value introducer */
 204 #define SX_VL_UNDEF     'V'             /* Undefined hash value */
 205
 206 /*
 207  * Those are only used to retrieve "old" pre-0.7 binary images
 208  */
 209
 210 #define SX_CLASS        'b'             /* Object is blessed, class name length <255 */
 211 #define SX_LG_CLASS 'B'         /* Object is blessed, class name length >255 */
 212 #define SX_STORED       'X'             /* End of object */
 213
 214 /*
 215  * Limits between short/long length representation.
 216  */
 217
 218 #define LG_SCALAR       255             /* Large scalar length limit */
 219 #define LG_BLESS        127             /* Large classname bless limit */
 220
 221 /*
 222  * Operation types
 223  */
 224
 225 #define ST_STORE        0x1             /* Store operation */
 226 #define ST_RETRIEVE     0x2             /* Retrieval operation */
 227 #define ST_CLONE        0x4             /* Deep cloning operation */
 228
 229 /*
 230  * The following structure is used for hash table key retrieval. Since, when
 231  * retrieving objects, we'll be facing blessed hash references, it's best
 232  * to pre-allocate that buffer once and resize it as the need arises, never
 233  * freeing it (keys will be saved away someplace else anyway, so even large
 234  * keys are not enough a motivation to reclaim that space).
 235  *
 236  * This structure is also used for memory store/retrieve operations which
 237  * happen in a fixed place before being malloc'ed elsewhere if persistency
 238  * is required. Hence the aptr pointer.
 239  */
 240 struct extendable {
 241         char *arena;            /* Will hold hash key strings, resized as needed */
 242         STRLEN asiz;            /* Size of aforementionned buffer */
 243         char *aptr;                     /* Arena pointer, for in-place read/write ops */
 244         char *aend;                     /* First invalid address */
 245 };
 246
 247 /*
 248  * At store time:
 249  * A hash table records the objects which have already been stored.
 250  * Those are referred to as SX_OBJECT in the file, and their "tag" (i.e.
 251  * an arbitrary sequence number) is used to identify them.
 252  *
 253  * At retrieve time:
 254  * An array table records the objects which have already been retrieved,
 255  * as seen by the tag determind by counting the objects themselves. The
 256  * reference to that retrieved object is kept in the table, and is returned
 257  * when an SX_OBJECT is found bearing that same tag.
 258  *
 259  * The same processing is used to record "classname" for blessed objects:
 260  * indexing by a hash at store time, and via an array at retrieve time.
 261  */
 262
 263 typedef unsigned long stag_t;   /* Used by pre-0.6 binary format */
 264
 265 /*
 266  * The following "thread-safe" related defines were contributed by
 267  * Murray Nesbitt <murray@activestate.com> and integrated by RAM, who
 268  * only renamed things a little bit to ensure consistency with surrounding
 269  * code.        -- RAM, 14/09/1999
 270  *
 271  * The original patch suffered from the fact that the stcxt_t structure
 272  * was global.  Murray tried to minimize the impact on the code as much as
 273  * possible.
 274  *
 275  * Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks
 276  * on objects.  Therefore, the notion of context needs to be generalized,
 277  * threading or not.
 278  */
 279
 280 #define MY_VERSION "Storable(" XS_VERSION ")"
 281
 282
 283 /*
 284  * Conditional UTF8 support.
 285  *
 286  */
 287 #ifdef SvUTF8_on
 288 #define STORE_UTF8STR(pv, len)  STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
 289 #define HAS_UTF8_SCALARS
 290 #ifdef HeKUTF8
 291 #define HAS_UTF8_HASHES
 292 #define HAS_UTF8_ALL
 293 #else
 294 /* 5.6 perl has utf8 scalars but not hashes */
 295 #endif
 296 #else
 297 #define SvUTF8(sv) 0
 298 #define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
 299 #endif
 300 #ifndef HAS_UTF8_ALL
 301 #define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
 302 #endif
 303
 304 #ifdef HvPLACEHOLDERS
 305 #define HAS_RESTRICTED_HASHES
 306 #else
 307 #define HVhek_PLACEHOLD 0x200
 308 #define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash"))
 309 #endif
 310
 311 #ifdef HvHASKFLAGS
 312 #define HAS_HASH_KEY_FLAGS
 313 #endif
 314
 315 /*
 316  * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
 317  * files remap tainted and dirty when threading is enabled.  That's bad for
 318  * perl to remap such common words.     -- RAM, 29/09/00
 319  */
 320
 321 typedef struct stcxt {
 322         int entry;                      /* flags recursion */
 323         int optype;                     /* type of traversal operation */
 324         HV *hseen;                      /* which objects have been seen, store time */
 325         AV *hook_seen;          /* which SVs were returned by STORABLE_freeze() */
 326         AV *aseen;                      /* which objects have been seen, retrieve time */
 327         HV *hclass;                     /* which classnames have been seen, store time */
 328         AV *aclass;                     /* which classnames have been seen, retrieve time */
 329         HV *hook;                       /* cache for hook methods per class name */
 330         IV tagnum;                      /* incremented at store time for each seen object */
 331         IV classnum;            /* incremented at store time for each seen classname */
 332         int netorder;           /* true if network order used */
 333         int s_tainted;          /* true if input source is tainted, at retrieve time */
 334         int forgive_me;         /* whether to be forgiving... */
 335         int canonical;          /* whether to store hashes sorted by key */
 336 #ifndef HAS_RESTRICTED_HASHES
 337         int derestrict;         /* whether to downgrade restrcted hashes */
 338 #endif
 339 #ifndef HAS_UTF8_ALL
 340         int use_bytes;         /* whether to bytes-ify utf8 */
 341 #endif
 342         int accept_future_minor; /* croak immediately on future minor versions?  */
 343         int s_dirty;            /* context is dirty due to CROAK() -- can be cleaned */
 344         int membuf_ro;          /* true means membuf is read-only and msaved is rw */
 345         struct extendable keybuf;       /* for hash key retrieval */
 346         struct extendable membuf;       /* for memory store/retrieve operations */
 347         struct extendable msaved;       /* where potentially valid mbuf is saved */
 348         PerlIO *fio;            /* where I/O are performed, NULL for memory */
 349         int ver_major;          /* major of version for retrieved object */
 350         int ver_minor;          /* minor of version for retrieved object */
 351         SV *(**retrieve_vtbl)();        /* retrieve dispatch table */
 352         struct stcxt *prev;     /* contexts chained backwards in real recursion */
 353 } stcxt_t;
 354
 355 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
 356
 357 #if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
 358 #define dSTCXT_SV                                                                       \
 359         SV *perinterp_sv = perl_get_sv(MY_VERSION, FALSE)
 360 #else   /* >= perl5.004_68 */
 361 #define dSTCXT_SV                                                                       \
 362         SV *perinterp_sv = *hv_fetch(PL_modglobal,              \
 363                 MY_VERSION, sizeof(MY_VERSION)-1, TRUE)
 364 #endif  /* < perl5.004_68 */
 365
 366 #define dSTCXT_PTR(T,name)                                                      \
 367         T name = ((perinterp_sv && SvIOK(perinterp_sv)  \
 368                                 ? INT2PTR(T, SvIVX(perinterp_sv)) : (T) 0))
 369 #define dSTCXT                                                                          \
 370         dSTCXT_SV;                                                                              \
 371         dSTCXT_PTR(stcxt_t *, cxt)
 372
 373 #define INIT_STCXT                                                                      \
 374       dSTCXT;                                                                           \
 375       Newz(0, cxt, 1, stcxt_t);                                         \
 376       sv_setiv(perinterp_sv, PTR2IV(cxt))
 377
 378 #define SET_STCXT(x) do {                                                       \
 379         dSTCXT_SV;                                                                              \
 380         sv_setiv(perinterp_sv, PTR2IV(x));                              \
 381 } while (0)
 382
 383 #else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
 384
 385 static stcxt_t Context;
 386 static stcxt_t *Context_ptr = &Context;
 387 #define dSTCXT                  stcxt_t *cxt = Context_ptr
 388 #define INIT_STCXT              dSTCXT
 389 #define SET_STCXT(x)    Context_ptr = x
 390
 391 #endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */
 392
 393 /*
 394  * KNOWN BUG:
 395  *   Croaking implies a memory leak, since we don't use setjmp/longjmp
 396  *   to catch the exit and free memory used during store or retrieve
 397  *   operations.  This is not too difficult to fix, but I need to understand
 398  *   how Perl does it, and croaking is exceptional anyway, so I lack the
 399  *   motivation to do it.
 400  *
 401  * The current workaround is to mark the context as dirty when croaking,
 402  * so that data structures can be freed whenever we renter Storable code
 403  * (but only *then*: it's a workaround, not a fix).
 404  *
 405  * This is also imperfect, because we don't really know how far they trapped
 406  * the croak(), and when we were recursing, we won't be able to clean anything
 407  * but the topmost context stacked.
 408  */
 409
 410 #define CROAK(x)        do { cxt->s_dirty = 1; croak x; } while (0)
 411
 412 /*
 413  * End of "thread-safe" related definitions.
 414  */
 415
 416 /*
 417  * LOW_32BITS
 418  *
 419  * Keep only the low 32 bits of a pointer (used for tags, which are not
 420  * really pointers).
 421  */
 422
 423 #if PTRSIZE <= 4
 424 #define LOW_32BITS(x)   ((I32) (x))
 425 #else
 426 #define LOW_32BITS(x)   ((I32) ((unsigned long) (x) & 0xffffffffUL))
 427 #endif
 428
 429 /*
 430  * oI, oS, oC
 431  *
 432  * Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
 433  * Used in the WLEN and RLEN macros.
 434  */
 435
 436 #if INTSIZE > 4
 437 #define oI(x)   ((I32 *) ((char *) (x) + 4))
 438 #define oS(x)   ((x) - 4)
 439 #define oC(x)   (x = 0)
 440 #define CRAY_HACK
 441 #else
 442 #define oI(x)   (x)
 443 #define oS(x)   (x)
 444 #define oC(x)
 445 #endif
 446
 447 /*
 448  * key buffer handling
 449  */
 450 #define kbuf    (cxt->keybuf).arena
 451 #define ksiz    (cxt->keybuf).asiz
 452 #define KBUFINIT() do {                                 \
 453         if (!kbuf) {                                            \
 454                 TRACEME(("** allocating kbuf of 128 bytes")); \
 455                 New(10003, kbuf, 128, char);    \
 456                 ksiz = 128;                                             \
 457         }                                                                       \
 458 } while (0)
 459 #define KBUFCHK(x) do {                 \
 460         if (x >= ksiz) {                        \
 461                 TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \
 462                 Renew(kbuf, x+1, char); \
 463                 ksiz = x+1;                             \
 464         }                                                       \
 465 } while (0)
 466
 467 /*
 468  * memory buffer handling
 469  */
 470 #define mbase   (cxt->membuf).arena
 471 #define msiz    (cxt->membuf).asiz
 472 #define mptr    (cxt->membuf).aptr
 473 #define mend    (cxt->membuf).aend
 474
 475 #define MGROW   (1 << 13)
 476 #define MMASK   (MGROW - 1)
 477
 478 #define round_mgrow(x)  \
 479         ((unsigned long) (((unsigned long) (x) + MMASK) & ~MMASK))
 480 #define trunc_int(x)    \
 481         ((unsigned long) ((unsigned long) (x) & ~(sizeof(int)-1)))
 482 #define int_aligned(x)  \
 483         ((unsigned long) (x) == trunc_int(x))
 484
 485 #define MBUF_INIT(x) do {                               \
 486         if (!mbase) {                                           \
 487                 TRACEME(("** allocating mbase of %d bytes", MGROW)); \
 488                 New(10003, mbase, MGROW, char); \
 489                 msiz = MGROW;                                   \
 490         }                                                                       \
 491         mptr = mbase;                                           \
 492         if (x)                                                          \
 493                 mend = mbase + x;                               \
 494         else                                                            \
 495                 mend = mbase + msiz;                    \
 496 } while (0)
 497
 498 #define MBUF_TRUNC(x)   mptr = mbase + x
 499 #define MBUF_SIZE()             (mptr - mbase)
 500
 501 /*
 502  * MBUF_SAVE_AND_LOAD
 503  * MBUF_RESTORE
 504  *
 505  * Those macros are used in do_retrieve() to save the current memory
 506  * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
 507  * data from a string.
 508  */
 509 #define MBUF_SAVE_AND_LOAD(in) do {             \
 510         ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \
 511         cxt->membuf_ro = 1;                                     \
 512         TRACEME(("saving mbuf"));                       \
 513         StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \
 514         MBUF_LOAD(in);                                          \
 515 } while (0)
 516
 517 #define MBUF_RESTORE() do {                             \
 518         ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
 519         cxt->membuf_ro = 0;                                     \
 520         TRACEME(("restoring mbuf"));            \
 521         StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
 522 } while (0)
 523
 524 /*
 525  * Use SvPOKp(), because SvPOK() fails on tainted scalars.
 526  * See store_scalar() for other usage of this workaround.
 527  */
 528 #define MBUF_LOAD(v) do {                               \
 529         ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
 530         if (!SvPOKp(v))                                         \
 531                 CROAK(("Not a scalar string")); \
 532         mptr = mbase = SvPV(v, msiz);           \
 533         mend = mbase + msiz;                            \
 534 } while (0)
 535
 536 #define MBUF_XTEND(x) do {                      \
 537         int nsz = (int) round_mgrow((x)+msiz);  \
 538         int offset = mptr - mbase;              \
 539         ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
 540         TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \
 541                 msiz, nsz, (x)));                       \
 542         Renew(mbase, nsz, char);                \
 543         msiz = nsz;                                             \
 544         mptr = mbase + offset;                  \
 545         mend = mbase + nsz;                             \
 546 } while (0)
 547
 548 #define MBUF_CHK(x) do {                        \
 549         if ((mptr + (x)) > mend)                \
 550                 MBUF_XTEND(x);                          \
 551 } while (0)
 552
 553 #define MBUF_GETC(x) do {                       \
 554         if (mptr < mend)                                \
 555                 x = (int) (unsigned char) *mptr++;      \
 556         else                                                    \
 557                 return (SV *) 0;                        \
 558 } while (0)
 559
 560 #ifdef CRAY_HACK
 561 #define MBUF_GETINT(x) do {                             \
 562         oC(x);                                                          \
 563         if ((mptr + 4) <= mend) {                       \
 564                 memcpy(oI(&x), mptr, 4);                \
 565                 mptr += 4;                                              \
 566         } else                                                          \
 567                 return (SV *) 0;                                \
 568 } while (0)
 569 #else
 570 #define MBUF_GETINT(x) do {                             \
 571         if ((mptr + sizeof(int)) <= mend) {     \
 572                 if (int_aligned(mptr))                  \
 573                         x = *(int *) mptr;                      \
 574                 else                                                    \
 575                         memcpy(&x, mptr, sizeof(int));  \
 576                 mptr += sizeof(int);                    \
 577         } else                                                          \
 578                 return (SV *) 0;                                \
 579 } while (0)
 580 #endif
 581
 582 #define MBUF_READ(x,s) do {                     \
 583         if ((mptr + (s)) <= mend) {             \
 584                 memcpy(x, mptr, s);                     \
 585                 mptr += s;                                      \
 586         } else                                                  \
 587                 return (SV *) 0;                        \
 588 } while (0)
 589
 590 #define MBUF_SAFEREAD(x,s,z) do {       \
 591         if ((mptr + (s)) <= mend) {             \
 592                 memcpy(x, mptr, s);                     \
 593                 mptr += s;                                      \
 594         } else {                                                \
 595                 sv_free(z);                                     \
 596                 return (SV *) 0;                        \
 597         }                                                               \
 598 } while (0)
 599
 600 #define MBUF_PUTC(c) do {                       \
 601         if (mptr < mend)                                \
 602                 *mptr++ = (char) c;                     \
 603         else {                                                  \
 604                 MBUF_XTEND(1);                          \
 605                 *mptr++ = (char) c;                     \
 606         }                                                               \
 607 } while (0)
 608
 609 #ifdef CRAY_HACK
 610 #define MBUF_PUTINT(i) do {                     \
 611         MBUF_CHK(4);                                    \
 612         memcpy(mptr, oI(&i), 4);                \
 613         mptr += 4;                                              \
 614 } while (0)
 615 #else
 616 #define MBUF_PUTINT(i) do {                     \
 617         MBUF_CHK(sizeof(int));                  \
 618         if (int_aligned(mptr))                  \
 619                 *(int *) mptr = i;                      \
 620         else                                                    \
 621                 memcpy(mptr, &i, sizeof(int));  \
 622         mptr += sizeof(int);                    \
 623 } while (0)
 624 #endif
 625
 626 #define MBUF_WRITE(x,s) do {            \
 627         MBUF_CHK(s);                                    \
 628         memcpy(mptr, x, s);                             \
 629         mptr += s;                                              \
 630 } while (0)
 631
 632 /*
 633  * Possible return values for sv_type().
 634  */
 635
 636 #define svis_REF                0
 637 #define svis_SCALAR             1
 638 #define svis_ARRAY              2
 639 #define svis_HASH               3
 640 #define svis_TIED               4
 641 #define svis_TIED_ITEM  5
 642 #define svis_OTHER              6
 643
 644 /*
 645  * Flags for SX_HOOK.
 646  */
 647
 648 #define SHF_TYPE_MASK           0x03
 649 #define SHF_LARGE_CLASSLEN      0x04
 650 #define SHF_LARGE_STRLEN        0x08
 651 #define SHF_LARGE_LISTLEN       0x10
 652 #define SHF_IDX_CLASSNAME       0x20
 653 #define SHF_NEED_RECURSE        0x40
 654 #define SHF_HAS_LIST            0x80
 655
 656 /*
 657  * Types for SX_HOOK (last 2 bits in flags).
 658  */
 659
 660 #define SHT_SCALAR                      0
 661 #define SHT_ARRAY                       1
 662 #define SHT_HASH                        2
 663 #define SHT_EXTRA                       3               /* Read extra byte for type */
 664
 665 /*
 666  * The following are held in the "extra byte"...
 667  */
 668
 669 #define SHT_TSCALAR                     4               /* 4 + 0 -- tied scalar */
 670 #define SHT_TARRAY                      5               /* 4 + 1 -- tied array */
 671 #define SHT_THASH                       6               /* 4 + 2 -- tied hash */
 672
 673 /*
 674  * per hash flags for flagged hashes
 675  */
 676
 677 #define SHV_RESTRICTED          0x01
 678
 679 /*
 680  * per key flags for flagged hashes
 681  */
 682
 683 #define SHV_K_UTF8              0x01
 684 #define SHV_K_WASUTF8           0x02
 685 #define SHV_K_LOCKED            0x04
 686 #define SHV_K_ISSV              0x08
 687 #define SHV_K_PLACEHOLDER       0x10
 688
 689 /*
 690  * Before 0.6, the magic string was "perl-store" (binary version number 0).
 691  *
 692  * Since 0.6 introduced many binary incompatibilities, the magic string has
 693  * been changed to "pst0" to allow an old image to be properly retrieved by
 694  * a newer Storable, but ensure a newer image cannot be retrieved with an
 695  * older version.
 696  *
 697  * At 0.7, objects are given the ability to serialize themselves, and the
 698  * set of markers is extended, backward compatibility is not jeopardized,
 699  * so the binary version number could have remained unchanged.  To correctly
 700  * spot errors if a file making use of 0.7-specific extensions is given to
 701  * 0.6 for retrieval, the binary version was moved to "2".  And I'm introducing
 702  * a "minor" version, to better track this kind of evolution from now on.
 703  *
 704  */
 705 static char old_magicstr[] = "perl-store";      /* Magic number before 0.6 */
 706 static char magicstr[] = "pst0";                        /* Used as a magic number */
 707
 708
 709 #define STORABLE_BIN_MAJOR      2               /* Binary major "version" */
 710 #define STORABLE_BIN_MINOR      5               /* Binary minor "version" */
 711
 712 /* If we aren't 5.7.3 or later, we won't be writing out files that use the
 713  * new flagged hash introdued in 2.5, so put 2.4 in the binary header to
 714  * maximise ease of interoperation with older Storables.
 715  * Could we write 2.3s if we're on 5.005_03? NWC
 716  */
 717 #if (PATCHLEVEL <= 6)
 718 #define STORABLE_BIN_WRITE_MINOR        4
 719 #else
 720 /*
 721  * As of perl 5.7.3, utf8 hash key is introduced.
 722  * So this must change -- dankogai
 723 */
 724 #define STORABLE_BIN_WRITE_MINOR        5
 725 #endif /* (PATCHLEVEL <= 6) */
 726
 727 /*
 728  * Useful store shortcuts...
 729  */
 730
 731 #define PUTMARK(x) do {                                         \
 732         if (!cxt->fio)                                                  \
 733                 MBUF_PUTC(x);                                           \
 734         else if (PerlIO_putc(cxt->fio, x) == EOF)       \
 735                 return -1;                                                      \
 736 } while (0)
 737
 738 #define WRITE_I32(x)    do {                    \
 739         ASSERT(sizeof(x) == sizeof(I32), ("writing an I32"));   \
 740         if (!cxt->fio)                                          \
 741                 MBUF_PUTINT(x);                                 \
 742         else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
 743                 return -1;                                      \
 744         } while (0)
 745
 746 #ifdef HAS_HTONL
 747 #define WLEN(x) do {                            \
 748         if (cxt->netorder) {                    \
 749                 int y = (int) htonl(x);         \
 750                 if (!cxt->fio)                          \
 751                         MBUF_PUTINT(y);                 \
 752                 else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \
 753                         return -1;                              \
 754         } else {                                                \
 755                 if (!cxt->fio)                          \
 756                         MBUF_PUTINT(x);                 \
 757                 else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \
 758                         return -1;                              \
 759         }                                                               \
 760 } while (0)
 761 #else
 762 #define WLEN(x) WRITE_I32(x)
 763 #endif
 764
 765 #define WRITE(x,y) do {                                         \
 766         if (!cxt->fio)                                                  \
 767                 MBUF_WRITE(x,y);                                        \
 768         else if (PerlIO_write(cxt->fio, x, y) != y)     \
 769                 return -1;                                                      \
 770         } while (0)
 771
 772 #define STORE_PV_LEN(pv, len, small, large) do {        \
 773         if (len <= LG_SCALAR) {                         \
 774                 unsigned char clen = (unsigned char) len;       \
 775                 PUTMARK(small);                                 \
 776                 PUTMARK(clen);                                  \
 777                 if (len)                                                \
 778                         WRITE(pv, len);                         \
 779         } else {                                                        \
 780                 PUTMARK(large);                                 \
 781                 WLEN(len);                                              \
 782                 WRITE(pv, len);                                 \
 783         }                                                                       \
 784 } while (0)
 785
 786 #define STORE_SCALAR(pv, len)   STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
 787
 788 /*
 789  * Store undef in arrays and hashes without recursing through store().
 790  */
 791 #define STORE_UNDEF() do {                              \
 792         cxt->tagnum++;                                          \
 793         PUTMARK(SX_UNDEF);                                      \
 794 } while (0)
 795
 796 /*
 797  * Useful retrieve shortcuts...
 798  */
 799
 800 #define GETCHAR() \
 801         (cxt->fio ? PerlIO_getc(cxt->fio) : (mptr >= mend ? EOF : (int) *mptr++))
 802
 803 #define GETMARK(x) do {                                                 \
 804         if (!cxt->fio)                                                          \
 805                 MBUF_GETC(x);                                                   \
 806         else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF)      \
 807                 return (SV *) 0;                                                \
 808 } while (0)
 809
 810 #define READ_I32(x)     do {                            \
 811         ASSERT(sizeof(x) == sizeof(I32), ("reading an I32"));   \
 812         oC(x);                                                          \
 813         if (!cxt->fio)                                          \
 814                 MBUF_GETINT(x);                                 \
 815         else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
 816                 return (SV *) 0;                                \
 817 } while (0)
 818
 819 #ifdef HAS_NTOHL
 820 #define RLEN(x) do {                                    \
 821         oC(x);                                                          \
 822         if (!cxt->fio)                                          \
 823                 MBUF_GETINT(x);                                 \
 824         else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
 825                 return (SV *) 0;                                \
 826         if (cxt->netorder)                                      \
 827                 x = (int) ntohl(x);                             \
 828 } while (0)
 829 #else
 830 #define RLEN(x) READ_I32(x)
 831 #endif
 832
 833 #define READ(x,y) do {                                          \
 834         if (!cxt->fio)                                                  \
 835                 MBUF_READ(x, y);                                        \
 836         else if (PerlIO_read(cxt->fio, x, y) != y)      \
 837                 return (SV *) 0;                                        \
 838 } while (0)
 839
 840 #define SAFEREAD(x,y,z) do {                                    \
 841         if (!cxt->fio)                                                          \
 842                 MBUF_SAFEREAD(x,y,z);                                   \
 843         else if (PerlIO_read(cxt->fio, x, y) != y)       {      \
 844                 sv_free(z);                                                             \
 845                 return (SV *) 0;                                                \
 846         }                                                                                       \
 847 } while (0)
 848
 849 /*
 850  * This macro is used at retrieve time, to remember where object 'y', bearing a
 851  * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
 852  * we'll therefore know where it has been retrieved and will be able to
 853  * share the same reference, as in the original stored memory image.
 854  *
 855  * We also need to bless objects ASAP for hooks (which may compute "ref $x"
 856  * on the objects given to STORABLE_thaw and expect that to be defined), and
 857  * also for overloaded objects (for which we might not find the stash if the
 858  * object is not blessed yet--this might occur for overloaded objects that
 859  * refer to themselves indirectly: if we blessed upon return from a sub
 860  * retrieve(), the SX_OBJECT marker we'd found could not have overloading
 861  * restored on it because the underlying object would not be blessed yet!).
 862  *
 863  * To achieve that, the class name of the last retrieved object is passed down
 864  * recursively, and the first SEEN() call for which the class name is not NULL
 865  * will bless the object.
 866  */
 867 #define SEEN(y,c) do {                                          \
 868         if (!y)                                                                 \
 869                 return (SV *) 0;                                        \
 870         if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \
 871                 return (SV *) 0;                                        \
 872         TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \
 873                  PTR2UV(y), SvREFCNT(y)-1));            \
 874         if (c)                                                                  \
 875                 BLESS((SV *) (y), c);                           \
 876 } while (0)
 877
 878 /*
 879  * Bless `s' in `p', via a temporary reference, required by sv_bless().
 880  */
 881 #define BLESS(s,p) do {                                 \
 882         SV *ref;                                                                \
 883         HV *stash;                                                              \
 884         TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \
 885         stash = gv_stashpv((p), TRUE);                  \
 886         ref = newRV_noinc(s);                                   \
 887         (void) sv_bless(ref, stash);                    \
 888         SvRV(ref) = 0;                                                  \
 889         SvREFCNT_dec(ref);                                              \
 890 } while (0)
 891
 892 static int store();
 893 static SV *retrieve(stcxt_t *cxt, char *cname);
 894
 895 /*
 896  * Dynamic dispatching table for SV store.
 897  */
 898
 899 static int store_ref(stcxt_t *cxt, SV *sv);
 900 static int store_scalar(stcxt_t *cxt, SV *sv);
 901 static int store_array(stcxt_t *cxt, AV *av);
 902 static int store_hash(stcxt_t *cxt, HV *hv);
 903 static int store_tied(stcxt_t *cxt, SV *sv);
 904 static int store_tied_item(stcxt_t *cxt, SV *sv);
 905 static int store_other(stcxt_t *cxt, SV *sv);
 906 static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
 907
 908 static int (*sv_store[])(stcxt_t *cxt, SV *sv) = {
 909         store_ref,                                                                              /* svis_REF */
 910         store_scalar,                                                                   /* svis_SCALAR */
 911         (int (*)(stcxt_t *cxt, SV *sv)) store_array,    /* svis_ARRAY */
 912         (int (*)(stcxt_t *cxt, SV *sv)) store_hash,             /* svis_HASH */
 913         store_tied,                                                                             /* svis_TIED */
 914         store_tied_item,                                                                /* svis_TIED_ITEM */
 915         store_other,                                                                    /* svis_OTHER */
 916 };
 917
 918 #define SV_STORE(x)     (*sv_store[x])
 919
 920 /*
 921  * Dynamic dispatching tables for SV retrieval.
 922  */
 923
 924 static SV *retrieve_lscalar(stcxt_t *cxt, char *cname);
 925 static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname);
 926 static SV *old_retrieve_array(stcxt_t *cxt, char *cname);
 927 static SV *old_retrieve_hash(stcxt_t *cxt, char *cname);
 928 static SV *retrieve_ref(stcxt_t *cxt, char *cname);
 929 static SV *retrieve_undef(stcxt_t *cxt, char *cname);
 930 static SV *retrieve_integer(stcxt_t *cxt, char *cname);
 931 static SV *retrieve_double(stcxt_t *cxt, char *cname);
 932 static SV *retrieve_byte(stcxt_t *cxt, char *cname);
 933 static SV *retrieve_netint(stcxt_t *cxt, char *cname);
 934 static SV *retrieve_scalar(stcxt_t *cxt, char *cname);
 935 static SV *retrieve_utf8str(stcxt_t *cxt, char *cname);
 936 static SV *retrieve_tied_array(stcxt_t *cxt, char *cname);
 937 static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname);
 938 static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname);
 939 static SV *retrieve_other(stcxt_t *cxt, char *cname);
 940
 941 static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = {
 942         0,                      /* SX_OBJECT -- entry unused dynamically */
 943         retrieve_lscalar,               /* SX_LSCALAR */
 944         old_retrieve_array,             /* SX_ARRAY -- for pre-0.6 binaries */
 945         old_retrieve_hash,              /* SX_HASH -- for pre-0.6 binaries */
 946         retrieve_ref,                   /* SX_REF */
 947         retrieve_undef,                 /* SX_UNDEF */
 948         retrieve_integer,               /* SX_INTEGER */
 949         retrieve_double,                /* SX_DOUBLE */
 950         retrieve_byte,                  /* SX_BYTE */
 951         retrieve_netint,                /* SX_NETINT */
 952         retrieve_scalar,                /* SX_SCALAR */
 953         retrieve_tied_array,    /* SX_ARRAY */
 954         retrieve_tied_hash,             /* SX_HASH */
 955         retrieve_tied_scalar,   /* SX_SCALAR */
 956         retrieve_other,                 /* SX_SV_UNDEF not supported */
 957         retrieve_other,                 /* SX_SV_YES not supported */
 958         retrieve_other,                 /* SX_SV_NO not supported */
 959         retrieve_other,                 /* SX_BLESS not supported */
 960         retrieve_other,                 /* SX_IX_BLESS not supported */
 961         retrieve_other,                 /* SX_HOOK not supported */
 962         retrieve_other,                 /* SX_OVERLOADED not supported */
 963         retrieve_other,                 /* SX_TIED_KEY not supported */
 964         retrieve_other,                 /* SX_TIED_IDX not supported */
 965         retrieve_other,                 /* SX_UTF8STR not supported */
 966         retrieve_other,                 /* SX_LUTF8STR not supported */
 967         retrieve_other,                 /* SX_FLAG_HASH not supported */
 968         retrieve_other,                 /* SX_ERROR */
 969 };
 970
 971 static SV *retrieve_array(stcxt_t *cxt, char *cname);
 972 static SV *retrieve_hash(stcxt_t *cxt, char *cname);
 973 static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname);
 974 static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname);
 975 static SV *retrieve_sv_no(stcxt_t *cxt, char *cname);
 976 static SV *retrieve_blessed(stcxt_t *cxt, char *cname);
 977 static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname);
 978 static SV *retrieve_hook(stcxt_t *cxt, char *cname);
 979 static SV *retrieve_overloaded(stcxt_t *cxt, char *cname);
 980 static SV *retrieve_tied_key(stcxt_t *cxt, char *cname);
 981 static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname);
 982 static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname);
 983
 984 static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
 985         0,                      /* SX_OBJECT -- entry unused dynamically */
 986         retrieve_lscalar,               /* SX_LSCALAR */
 987         retrieve_array,                 /* SX_ARRAY */
 988         retrieve_hash,                  /* SX_HASH */
 989         retrieve_ref,                   /* SX_REF */
 990         retrieve_undef,                 /* SX_UNDEF */
 991         retrieve_integer,               /* SX_INTEGER */
 992         retrieve_double,                /* SX_DOUBLE */
 993         retrieve_byte,                  /* SX_BYTE */
 994         retrieve_netint,                /* SX_NETINT */
 995         retrieve_scalar,                /* SX_SCALAR */
 996         retrieve_tied_array,    /* SX_ARRAY */
 997         retrieve_tied_hash,             /* SX_HASH */
 998         retrieve_tied_scalar,   /* SX_SCALAR */
 999         retrieve_sv_undef,              /* SX_SV_UNDEF */
1000         retrieve_sv_yes,                /* SX_SV_YES */
1001         retrieve_sv_no,                 /* SX_SV_NO */
1002         retrieve_blessed,               /* SX_BLESS */
1003         retrieve_idx_blessed,   /* SX_IX_BLESS */
1004         retrieve_hook,                  /* SX_HOOK */
1005         retrieve_overloaded,    /* SX_OVERLOAD */
1006         retrieve_tied_key,              /* SX_TIED_KEY */
1007         retrieve_tied_idx,              /* SX_TIED_IDX */
1008         retrieve_utf8str,               /* SX_UTF8STR  */
1009         retrieve_lutf8str,              /* SX_LUTF8STR */
1010         retrieve_flag_hash,             /* SX_HASH */
1011         retrieve_other,                 /* SX_ERROR */
1012 };
1013
1014 #define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)])
1015
1016 static SV *mbuf2sv(void);
1017
1018 /***
1019  *** Context management.
1020  ***/
1021
1022 /*
1023  * init_perinterp
1024  *
1025  * Called once per "thread" (interpreter) to initialize some global context.
1026  */
1027 static void init_perinterp(void)
1028 {
1029     INIT_STCXT;
1030
1031     cxt->netorder = 0;          /* true if network order used */
1032     cxt->forgive_me = -1;       /* whether to be forgiving... */
1033 }
1034
1035 /*
1036  * reset_context
1037  *
1038  * Called at the end of every context cleaning, to perform common reset
1039  * operations.
1040  */
1041 static void reset_context(stcxt_t *cxt)
1042 {
1043         cxt->entry = 0;
1044         cxt->s_dirty = 0;
1045         cxt->optype &= ~(ST_STORE|ST_RETRIEVE);         /* Leave ST_CLONE alone */
1046 }
1047
1048 /*
1049  * init_store_context
1050  *
1051  * Initialize a new store context for real recursion.
1052  */
1053 static void init_store_context(
1054         stcxt_t *cxt,
1055         PerlIO *f,
1056         int optype,
1057         int network_order)
1058 {
1059         TRACEME(("init_store_context"));
1060
1061         cxt->netorder = network_order;
1062         cxt->forgive_me = -1;                   /* Fetched from perl if needed */
1063         cxt->canonical = -1;                    /* Idem */
1064         cxt->tagnum = -1;                               /* Reset tag numbers */
1065         cxt->classnum = -1;                             /* Reset class numbers */
1066         cxt->fio = f;                                   /* Where I/O are performed */
1067         cxt->optype = optype;                   /* A store, or a deep clone */
1068         cxt->entry = 1;                                 /* No recursion yet */
1069
1070         /*
1071          * The `hseen' table is used to keep track of each SV stored and their
1072          * associated tag numbers is special. It is "abused" because the
1073          * values stored are not real SV, just integers cast to (SV *),
1074          * which explains the freeing below.
1075          *
1076          * It is also one possible bottlneck to achieve good storing speed,
1077          * so the "shared keys" optimization is turned off (unlikely to be
1078          * of any use here), and the hash table is "pre-extended". Together,
1079          * those optimizations increase the throughput by 12%.
1080          */
1081
1082         cxt->hseen = newHV();                   /* Table where seen objects are stored */
1083         HvSHAREKEYS_off(cxt->hseen);
1084
1085         /*
1086          * The following does not work well with perl5.004_04, and causes
1087          * a core dump later on, in a completely unrelated spot, which
1088          * makes me think there is a memory corruption going on.
1089          *
1090          * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking
1091          * it below does not make any difference. It seems to work fine
1092          * with perl5.004_68 but given the probable nature of the bug,
1093          * that does not prove anything.
1094          *
1095          * It's a shame because increasing the amount of buckets raises
1096          * store() throughput by 5%, but until I figure this out, I can't
1097          * allow for this to go into production.
1098          *
1099          * It is reported fixed in 5.005, hence the #if.
1100          */
1101 #if PERL_VERSION >= 5
1102 #define HBUCKETS        4096                            /* Buckets for %hseen */
1103         HvMAX(cxt->hseen) = HBUCKETS - 1;       /* keys %hseen = $HBUCKETS; */
1104 #endif
1105
1106         /*
1107          * The `hclass' hash uses the same settings as `hseen' above, but it is
1108          * used to assign sequential tags (numbers) to class names for blessed
1109          * objects.
1110          *
1111          * We turn the shared key optimization on.
1112          */
1113
1114         cxt->hclass = newHV();                  /* Where seen classnames are stored */
1115
1116 #if PERL_VERSION >= 5
1117         HvMAX(cxt->hclass) = HBUCKETS - 1;      /* keys %hclass = $HBUCKETS; */
1118 #endif
1119
1120         /*
1121          * The `hook' hash table is used to keep track of the references on
1122          * the STORABLE_freeze hook routines, when found in some class name.
1123          *
1124          * It is assumed that the inheritance tree will not be changed during
1125          * storing, and that no new method will be dynamically created by the
1126          * hooks.
1127          */
1128
1129         cxt->hook = newHV();                    /* Table where hooks are cached */
1130
1131         /*
1132          * The `hook_seen' array keeps track of all the SVs returned by
1133          * STORABLE_freeze hooks for us to serialize, so that they are not
1134          * reclaimed until the end of the serialization process.  Each SV is
1135          * only stored once, the first time it is seen.
1136          */
1137
1138         cxt->hook_seen = newAV();               /* Lists SVs returned by STORABLE_freeze */
1139 }
1140
1141 /*
1142  * clean_store_context
1143  *
1144  * Clean store context by
1145  */
1146 static void clean_store_context(stcxt_t *cxt)
1147 {
1148         HE *he;
1149
1150         TRACEME(("clean_store_context"));
1151
1152         ASSERT(cxt->optype & ST_STORE, ("was performing a store()"));
1153
1154         /*
1155          * Insert real values into hashes where we stored faked pointers.
1156          */
1157
1158         if (cxt->hseen) {
1159                 hv_iterinit(cxt->hseen);
1160                 while ((he = hv_iternext(cxt->hseen)))  /* Extra () for -Wall, grr.. */
1161                         HeVAL(he) = &PL_sv_undef;
1162         }
1163
1164         if (cxt->hclass) {
1165                 hv_iterinit(cxt->hclass);
1166                 while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall, grr.. */
1167                         HeVAL(he) = &PL_sv_undef;
1168         }
1169
1170         /*
1171          * And now dispose of them...
1172          *
1173          * The surrounding if() protection has been added because there might be
1174          * some cases where this routine is called more than once, during
1175          * exceptionnal events.  This was reported by Marc Lehmann when Storable
1176          * is executed from mod_perl, and the fix was suggested by him.
1177          *              -- RAM, 20/12/2000
1178          */
1179
1180         if (cxt->hseen) {
1181                 HV *hseen = cxt->hseen;
1182                 cxt->hseen = 0;
1183                 hv_undef(hseen);
1184                 sv_free((SV *) hseen);
1185         }
1186
1187         if (cxt->hclass) {
1188                 HV *hclass = cxt->hclass;
1189                 cxt->hclass = 0;
1190                 hv_undef(hclass);
1191                 sv_free((SV *) hclass);
1192         }
1193
1194         if (cxt->hook) {
1195                 HV *hook = cxt->hook;
1196                 cxt->hook = 0;
1197                 hv_undef(hook);
1198                 sv_free((SV *) hook);
1199         }
1200
1201         if (cxt->hook_seen) {
1202                 AV *hook_seen = cxt->hook_seen;
1203                 cxt->hook_seen = 0;
1204                 av_undef(hook_seen);
1205                 sv_free((SV *) hook_seen);
1206         }
1207
1208         cxt->forgive_me = -1;                   /* Fetched from perl if needed */
1209         cxt->canonical = -1;                    /* Idem */
1210
1211         reset_context(cxt);
1212 }
1213
1214 /*
1215  * init_retrieve_context
1216  *
1217  * Initialize a new retrieve context for real recursion.
1218  */
1219 static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted)
1220 {
1221         TRACEME(("init_retrieve_context"));
1222
1223         /*
1224          * The hook hash table is used to keep track of the references on
1225          * the STORABLE_thaw hook routines, when found in some class name.
1226          *
1227          * It is assumed that the inheritance tree will not be changed during
1228          * storing, and that no new method will be dynamically created by the
1229          * hooks.
1230          */
1231
1232         cxt->hook  = newHV();                   /* Caches STORABLE_thaw */
1233
1234         /*
1235          * If retrieving an old binary version, the cxt->retrieve_vtbl variable
1236          * was set to sv_old_retrieve. We'll need a hash table to keep track of
1237          * the correspondance between the tags and the tag number used by the
1238          * new retrieve routines.
1239          */
1240
1241         cxt->hseen = ((cxt->retrieve_vtbl == sv_old_retrieve) ? newHV() : 0);
1242
1243         cxt->aseen = newAV();                   /* Where retrieved objects are kept */
1244         cxt->aclass = newAV();                  /* Where seen classnames are kept */
1245         cxt->tagnum = 0;                                /* Have to count objects... */
1246         cxt->classnum = 0;                              /* ...and class names as well */
1247         cxt->optype = optype;
1248         cxt->s_tainted = is_tainted;
1249         cxt->entry = 1;                                 /* No recursion yet */
1250 #ifndef HAS_RESTRICTED_HASHES
1251         cxt->derestrict = -1;           /* Fetched from perl if needed */
1252 #endif
1253 #ifndef HAS_UTF8_ALL
1254         cxt->use_bytes = -1;            /* Fetched from perl if needed */
1255 #endif
1256         cxt->accept_future_minor = -1;  /* Fetched from perl if needed */
1257 }
1258
1259 /*
1260  * clean_retrieve_context
1261  *
1262  * Clean retrieve context by
1263  */
1264 static void clean_retrieve_context(stcxt_t *cxt)
1265 {
1266         TRACEME(("clean_retrieve_context"));
1267
1268         ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
1269
1270         if (cxt->aseen) {
1271                 AV *aseen = cxt->aseen;
1272                 cxt->aseen = 0;
1273                 av_undef(aseen);
1274                 sv_free((SV *) aseen);
1275         }
1276
1277         if (cxt->aclass) {
1278                 AV *aclass = cxt->aclass;
1279                 cxt->aclass = 0;
1280                 av_undef(aclass);
1281                 sv_free((SV *) aclass);
1282         }
1283
1284         if (cxt->hook) {
1285                 HV *hook = cxt->hook;
1286                 cxt->hook = 0;
1287                 hv_undef(hook);
1288                 sv_free((SV *) hook);
1289         }
1290
1291         if (cxt->hseen) {
1292                 HV *hseen = cxt->hseen;
1293                 cxt->hseen = 0;
1294                 hv_undef(hseen);
1295                 sv_free((SV *) hseen);          /* optional HV, for backward compat. */
1296         }
1297
1298 #ifndef HAS_RESTRICTED_HASHES
1299         cxt->derestrict = -1;           /* Fetched from perl if needed */
1300 #endif
1301 #ifndef HAS_UTF8_ALL
1302         cxt->use_bytes = -1;            /* Fetched from perl if needed */
1303 #endif
1304         cxt->accept_future_minor = -1;  /* Fetched from perl if needed */
1305
1306         reset_context(cxt);
1307 }
1308
1309 /*
1310  * clean_context
1311  *
1312  * A workaround for the CROAK bug: cleanup the last context.
1313  */
1314 static void clean_context(stcxt_t *cxt)
1315 {
1316         TRACEME(("clean_context"));
1317
1318         ASSERT(cxt->s_dirty, ("dirty context"));
1319
1320         if (cxt->membuf_ro)
1321                 MBUF_RESTORE();
1322
1323         ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
1324
1325         if (cxt->optype & ST_RETRIEVE)
1326                 clean_retrieve_context(cxt);
1327         else if (cxt->optype & ST_STORE)
1328                 clean_store_context(cxt);
1329         else
1330                 reset_context(cxt);
1331
1332         ASSERT(!cxt->s_dirty, ("context is clean"));
1333         ASSERT(cxt->entry == 0, ("context is reset"));
1334 }
1335
1336 /*
1337  * allocate_context
1338  *
1339  * Allocate a new context and push it on top of the parent one.
1340  * This new context is made globally visible via SET_STCXT().
1341  */
1342 static stcxt_t *allocate_context(parent_cxt)
1343 stcxt_t *parent_cxt;
1344 {
1345         stcxt_t *cxt;
1346
1347         TRACEME(("allocate_context"));
1348
1349         ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
1350
1351         Newz(0, cxt, 1, stcxt_t);
1352         cxt->prev = parent_cxt;
1353         SET_STCXT(cxt);
1354
1355         ASSERT(!cxt->s_dirty, ("clean context"));
1356
1357         return cxt;
1358 }
1359
1360 /*
1361  * free_context
1362  *
1363  * Free current context, which cannot be the "root" one.
1364  * Make the context underneath globally visible via SET_STCXT().
1365  */
1366 static void free_context(cxt)
1367 stcxt_t *cxt;
1368 {
1369         stcxt_t *prev = cxt->prev;
1370
1371         TRACEME(("free_context"));
1372
1373         ASSERT(!cxt->s_dirty, ("clean context"));
1374         ASSERT(prev, ("not freeing root context"));
1375
1376         if (kbuf)
1377                 Safefree(kbuf);
1378         if (mbase)
1379                 Safefree(mbase);
1380
1381         Safefree(cxt);
1382         SET_STCXT(prev);
1383
1384         ASSERT(cxt, ("context not void"));
1385 }
1386
1387 /***
1388  *** Predicates.
1389  ***/
1390
1391 /*
1392  * is_storing
1393  *
1394  * Tells whether we're in the middle of a store operation.
1395  */
1396 int is_storing(void)
1397 {
1398         dSTCXT;
1399
1400         return cxt->entry && (cxt->optype & ST_STORE);
1401 }
1402
1403 /*
1404  * is_retrieving
1405  *
1406  * Tells whether we're in the middle of a retrieve operation.
1407  */
1408 int is_retrieving(void)
1409 {
1410         dSTCXT;
1411
1412         return cxt->entry && (cxt->optype & ST_RETRIEVE);
1413 }
1414
1415 /*
1416  * last_op_in_netorder
1417  *
1418  * Returns whether last operation was made using network order.
1419  *
1420  * This is typically out-of-band information that might prove useful
1421  * to people wishing to convert native to network order data when used.
1422  */
1423 int last_op_in_netorder(void)
1424 {
1425         dSTCXT;
1426
1427         return cxt->netorder;
1428 }
1429
1430 /***
1431  *** Hook lookup and calling routines.
1432  ***/
1433
1434 /*
1435  * pkg_fetchmeth
1436  *
1437  * A wrapper on gv_fetchmethod_autoload() which caches results.
1438  *
1439  * Returns the routine reference as an SV*, or null if neither the package
1440  * nor its ancestors know about the method.
1441  */
1442 static SV *pkg_fetchmeth(
1443         HV *cache,
1444         HV *pkg,
1445         char *method)
1446 {
1447         GV *gv;
1448         SV *sv;
1449
1450         /*
1451          * The following code is the same as the one performed by UNIVERSAL::can
1452          * in the Perl core.
1453          */
1454
1455         gv = gv_fetchmethod_autoload(pkg, method, FALSE);
1456         if (gv && isGV(gv)) {
1457                 sv = newRV((SV*) GvCV(gv));
1458                 TRACEME(("%s->%s: 0x%"UVxf, HvNAME(pkg), method, PTR2UV(sv)));
1459         } else {
1460                 sv = newSVsv(&PL_sv_undef);
1461                 TRACEME(("%s->%s: not found", HvNAME(pkg), method));
1462         }
1463
1464         /*
1465          * Cache the result, ignoring failure: if we can't store the value,
1466          * it just won't be cached.
1467          */
1468
1469         (void) hv_store(cache, HvNAME(pkg), strlen(HvNAME(pkg)), sv, 0);
1470
1471         return SvOK(sv) ? sv : (SV *) 0;
1472 }
1473
1474 /*
1475  * pkg_hide
1476  *
1477  * Force cached value to be undef: hook ignored even if present.
1478  */
1479 static void pkg_hide(
1480         HV *cache,
1481         HV *pkg,
1482         char *method)
1483 {
1484         (void) hv_store(cache,
1485                 HvNAME(pkg), strlen(HvNAME(pkg)), newSVsv(&PL_sv_undef), 0);
1486 }
1487
1488 /*
1489  * pkg_uncache
1490  *
1491  * Discard cached value: a whole fetch loop will be retried at next lookup.
1492  */
1493 static void pkg_uncache(
1494         HV *cache,
1495         HV *pkg,
1496         char *method)
1497 {
1498         (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD);
1499 }
1500
1501 /*
1502  * pkg_can
1503  *
1504  * Our own "UNIVERSAL::can", which caches results.
1505  *
1506  * Returns the routine reference as an SV*, or null if the object does not
1507  * know about the method.
1508  */
1509 static SV *pkg_can(
1510         HV *cache,
1511         HV *pkg,
1512         char *method)
1513 {
1514         SV **svh;
1515         SV *sv;
1516
1517         TRACEME(("pkg_can for %s->%s", HvNAME(pkg), method));
1518
1519         /*
1520          * Look into the cache to see whether we already have determined
1521          * where the routine was, if any.
1522          *
1523          * NOTA BENE: we don't use `method' at all in our lookup, since we know
1524          * that only one hook (i.e. always the same) is cached in a given cache.
1525          */
1526
1527         svh = hv_fetch(cache, HvNAME(pkg), strlen(HvNAME(pkg)), FALSE);
1528         if (svh) {
1529                 sv = *svh;
1530                 if (!SvOK(sv)) {
1531                         TRACEME(("cached %s->%s: not found", HvNAME(pkg), method));
1532                         return (SV *) 0;
1533                 } else {
1534                         TRACEME(("cached %s->%s: 0x%"UVxf,
1535                                 HvNAME(pkg), method, PTR2UV(sv)));
1536                         return sv;
1537                 }
1538         }
1539
1540         TRACEME(("not cached yet"));
1541         return pkg_fetchmeth(cache, pkg, method);               /* Fetch and cache */
1542 }
1543
1544 /*
1545  * scalar_call
1546  *
1547  * Call routine as obj->hook(av) in scalar context.
1548  * Propagates the single returned value if not called in void context.
1549  */
1550 static SV *scalar_call(
1551         SV *obj,
1552         SV *hook,
1553         int cloning,
1554         AV *av,
1555         I32 flags)
1556 {
1557         dSP;
1558         int count;
1559         SV *sv = 0;
1560
1561         TRACEME(("scalar_call (cloning=%d)", cloning));
1562
1563         ENTER;
1564         SAVETMPS;
1565
1566         PUSHMARK(sp);
1567         XPUSHs(obj);
1568         XPUSHs(sv_2mortal(newSViv(cloning)));           /* Cloning flag */
1569         if (av) {
1570                 SV **ary = AvARRAY(av);
1571                 int cnt = AvFILLp(av) + 1;
1572                 int i;
1573                 XPUSHs(ary[0]);                                                 /* Frozen string */
1574                 for (i = 1; i < cnt; i++) {
1575                         TRACEME(("pushing arg #%d (0x%"UVxf")...",
1576                                  i, PTR2UV(ary[i])));
1577                         XPUSHs(sv_2mortal(newRV(ary[i])));
1578                 }
1579         }
1580         PUTBACK;
1581
1582         TRACEME(("calling..."));
1583         count = perl_call_sv(hook, flags);              /* Go back to Perl code */
1584         TRACEME(("count = %d", count));
1585
1586         SPAGAIN;
1587
1588         if (count) {
1589                 sv = POPs;
1590                 SvREFCNT_inc(sv);               /* We're returning it, must stay alive! */
1591         }
1592
1593         PUTBACK;
1594         FREETMPS;
1595         LEAVE;
1596
1597         return sv;
1598 }
1599
1600 /*
1601  * array_call
1602  *
1603  * Call routine obj->hook(cloning) in list context.
1604  * Returns the list of returned values in an array.
1605  */
1606 static AV *array_call(
1607         SV *obj,
1608         SV *hook,
1609         int cloning)
1610 {
1611         dSP;
1612         int count;
1613         AV *av;
1614         int i;
1615
1616         TRACEME(("array_call (cloning=%d)", cloning));
1617
1618         ENTER;
1619         SAVETMPS;
1620
1621         PUSHMARK(sp);
1622         XPUSHs(obj);                                                            /* Target object */
1623         XPUSHs(sv_2mortal(newSViv(cloning)));           /* Cloning flag */
1624         PUTBACK;
1625
1626         count = perl_call_sv(hook, G_ARRAY);            /* Go back to Perl code */
1627
1628         SPAGAIN;
1629
1630         av = newAV();
1631         for (i = count - 1; i >= 0; i--) {
1632                 SV *sv = POPs;
1633                 av_store(av, i, SvREFCNT_inc(sv));
1634         }
1635
1636         PUTBACK;
1637         FREETMPS;
1638         LEAVE;
1639
1640         return av;
1641 }
1642
1643 /*
1644  * known_class
1645  *
1646  * Lookup the class name in the `hclass' table and either assign it a new ID
1647  * or return the existing one, by filling in `classnum'.
1648  *
1649  * Return true if the class was known, false if the ID was just generated.
1650  */
1651 static int known_class(
1652         stcxt_t *cxt,
1653         char *name,             /* Class name */
1654         int len,                /* Name length */
1655         I32 *classnum)
1656 {
1657         SV **svh;
1658         HV *hclass = cxt->hclass;
1659
1660         TRACEME(("known_class (%s)", name));
1661
1662         /*
1663          * Recall that we don't store pointers in this hash table, but tags.
1664          * Therefore, we need LOW_32BITS() to extract the relevant parts.
1665          */
1666
1667         svh = hv_fetch(hclass, name, len, FALSE);
1668         if (svh) {
1669                 *classnum = LOW_32BITS(*svh);
1670                 return TRUE;
1671         }
1672
1673         /*
1674          * Unknown classname, we need to record it.
1675          */
1676
1677         cxt->classnum++;
1678         if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0))
1679                 CROAK(("Unable to record new classname"));
1680
1681         *classnum = cxt->classnum;
1682         return FALSE;
1683 }
1684
1685 /***
1686  *** Sepcific store routines.
1687  ***/
1688
1689 /*
1690  * store_ref
1691  *
1692  * Store a reference.
1693  * Layout is SX_REF <object> or SX_OVERLOAD <object>.
1694  */
1695 static int store_ref(stcxt_t *cxt, SV *sv)
1696 {
1697         TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv)));
1698
1699         /*
1700          * Follow reference, and check if target is overloaded.
1701          */
1702
1703         sv = SvRV(sv);
1704
1705         if (SvOBJECT(sv)) {
1706                 HV *stash = (HV *) SvSTASH(sv);
1707                 if (stash && Gv_AMG(stash)) {
1708                         TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv)));
1709                         PUTMARK(SX_OVERLOAD);
1710                 } else
1711                         PUTMARK(SX_REF);
1712         } else
1713                 PUTMARK(SX_REF);
1714
1715         return store(cxt, sv);
1716 }
1717
1718 /*
1719  * store_scalar
1720  *
1721  * Store a scalar.
1722  *
1723  * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
1724  * The <data> section is omitted if <length> is 0.
1725  *
1726  * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
1727  * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
1728  */
1729 static int store_scalar(stcxt_t *cxt, SV *sv)
1730 {
1731         IV iv;
1732         char *pv;
1733         STRLEN len;
1734         U32 flags = SvFLAGS(sv);                        /* "cc -O" may put it in register */
1735
1736         TRACEME(("store_scalar (0x%"UVxf")", PTR2UV(sv)));
1737
1738         /*
1739          * For efficiency, break the SV encapsulation by peaking at the flags
1740          * directly without using the Perl macros to avoid dereferencing
1741          * sv->sv_flags each time we wish to check the flags.
1742          */
1743
1744         if (!(flags & SVf_OK)) {                        /* !SvOK(sv) */
1745                 if (sv == &PL_sv_undef) {
1746                         TRACEME(("immortal undef"));
1747                         PUTMARK(SX_SV_UNDEF);
1748                 } else {
1749                         TRACEME(("undef at 0x%"UVxf, PTR2UV(sv)));
1750                         PUTMARK(SX_UNDEF);
1751                 }
1752                 return 0;
1753         }
1754
1755         /*
1756          * Always store the string representation of a scalar if it exists.
1757          * Gisle Aas provided me with this test case, better than a long speach:
1758          *
1759          *  perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)'
1760          *  SV = PVNV(0x80c8520)
1761          *       REFCNT = 1
1762          *       FLAGS = (NOK,POK,pNOK,pPOK)
1763          *       IV = 0
1764          *       NV = 0
1765          *       PV = 0x80c83d0 "abc"\0
1766          *       CUR = 3
1767          *       LEN = 4
1768          *
1769          * Write SX_SCALAR, length, followed by the actual data.
1770          *
1771          * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as
1772          * appropriate, followed by the actual (binary) data. A double
1773          * is written as a string if network order, for portability.
1774          *
1775          * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv).
1776          * The reason is that when the scalar value is tainted, the SvNOK(sv)
1777          * value is false.
1778          *
1779          * The test for a read-only scalar with both POK and NOK set is meant
1780          * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the
1781          * address comparison for each scalar we store.
1782          */
1783
1784 #define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK)
1785
1786         if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) {
1787                 if (sv == &PL_sv_yes) {
1788                         TRACEME(("immortal yes"));
1789                         PUTMARK(SX_SV_YES);
1790                 } else if (sv == &PL_sv_no) {
1791                         TRACEME(("immortal no"));
1792                         PUTMARK(SX_SV_NO);
1793                 } else {
1794                         pv = SvPV(sv, len);                     /* We know it's SvPOK */
1795                         goto string;                            /* Share code below */
1796                 }
1797         } else if (flags & SVp_POK) {           /* SvPOKp(sv) => string */
1798                 I32 wlen;                                               /* For 64-bit machines */
1799                 pv = SvPV(sv, len);
1800
1801                 /*
1802                  * Will come here from below with pv and len set if double & netorder,
1803                  * or from above if it was readonly, POK and NOK but neither &PL_sv_yes
1804                  * nor &PL_sv_no.
1805                  */
1806         string:
1807
1808                 wlen = (I32) len;                               /* WLEN via STORE_SCALAR expects I32 */
1809                 if (SvUTF8 (sv))
1810                         STORE_UTF8STR(pv, wlen);
1811                 else
1812                         STORE_SCALAR(pv, wlen);
1813                 TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
1814                          PTR2UV(sv), SvPVX(sv), (IV)len));
1815
1816         } else if (flags & SVp_NOK) {           /* SvNOKp(sv) => double */
1817                 NV nv = SvNV(sv);
1818
1819                 /*
1820                  * Watch for number being an integer in disguise.
1821                  */
1822                 if (nv == (NV) (iv = I_V(nv))) {
1823                         TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv));
1824                         goto integer;           /* Share code below */
1825                 }
1826
1827                 if (cxt->netorder) {
1828                         TRACEME(("double %"NVff" stored as string", nv));
1829                         pv = SvPV(sv, len);
1830                         goto string;            /* Share code above */
1831                 }
1832
1833                 PUTMARK(SX_DOUBLE);
1834                 WRITE(&nv, sizeof(nv));
1835
1836                 TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
1837
1838         } else if (flags & SVp_IOK) {           /* SvIOKp(sv) => integer */
1839                 iv = SvIV(sv);
1840
1841                 /*
1842                  * Will come here from above with iv set if double is an integer.
1843                  */
1844         integer:
1845
1846                 /*
1847                  * Optimize small integers into a single byte, otherwise store as
1848                  * a real integer (converted into network order if they asked).
1849                  */
1850
1851                 if (iv >= -128 && iv <= 127) {
1852                         unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
1853                         PUTMARK(SX_BYTE);
1854                         PUTMARK(siv);
1855                         TRACEME(("small integer stored as %d", siv));
1856                 } else if (cxt->netorder) {
1857                         I32 niv;
1858 #ifdef HAS_HTONL
1859                         niv = (I32) htonl(iv);
1860                         TRACEME(("using network order"));
1861 #else
1862                         niv = (I32) iv;
1863                         TRACEME(("as-is for network order"));
1864 #endif
1865                         PUTMARK(SX_NETINT);
1866                         WRITE_I32(niv);
1867                 } else {
1868                         PUTMARK(SX_INTEGER);
1869                         WRITE(&iv, sizeof(iv));
1870                 }
1871
1872                 TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
1873
1874         } else
1875                 CROAK(("Can't determine type of %s(0x%"UVxf")",
1876                        sv_reftype(sv, FALSE),
1877                        PTR2UV(sv)));
1878
1879         return 0;               /* Ok, no recursion on scalars */
1880 }
1881
1882 /*
1883  * store_array
1884  *
1885  * Store an array.
1886  *
1887  * Layout is SX_ARRAY <size> followed by each item, in increading index order.
1888  * Each item is stored as <object>.
1889  */
1890 static int store_array(stcxt_t *cxt, AV *av)
1891 {
1892         SV **sav;
1893         I32 len = av_len(av) + 1;
1894         I32 i;
1895         int ret;
1896
1897         TRACEME(("store_array (0x%"UVxf")", PTR2UV(av)));
1898
1899         /*
1900          * Signal array by emitting SX_ARRAY, followed by the array length.
1901          */
1902
1903         PUTMARK(SX_ARRAY);
1904         WLEN(len);
1905         TRACEME(("size = %d", len));
1906
1907         /*
1908          * Now store each item recursively.
1909          */
1910
1911         for (i = 0; i < len; i++) {
1912                 sav = av_fetch(av, i, 0);
1913                 if (!sav) {
1914                         TRACEME(("(#%d) undef item", i));
1915                         STORE_UNDEF();
1916                         continue;
1917                 }
1918                 TRACEME(("(#%d) item", i));
1919                 if ((ret = store(cxt, *sav)))   /* Extra () for -Wall, grr... */
1920                         return ret;
1921         }
1922
1923         TRACEME(("ok (array)"));
1924
1925         return 0;
1926 }
1927
1928 /*
1929  * sortcmp
1930  *
1931  * Sort two SVs
1932  * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
1933  */
1934 static int
1935 sortcmp(const void *a, const void *b)
1936 {
1937         return sv_cmp(*(SV * const *) a, *(SV * const *) b);
1938 }
1939
1940
1941 /*
1942  * store_hash
1943  *
1944  * Store a hash table.
1945  *
1946  * For a "normal" hash (not restricted, no utf8 keys):
1947  *
1948  * Layout is SX_HASH <size> followed by each key/value pair, in random order.
1949  * Values are stored as <object>.
1950  * Keys are stored as <length> <data>, the <data> section being omitted
1951  * if length is 0.
1952  *
1953  * For a "fancy" hash (restricted or utf8 keys):
1954  *
1955  * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair,
1956  * in random order.
1957  * Values are stored as <object>.
1958  * Keys are stored as <flags> <length> <data>, the <data> section being omitted
1959  * if length is 0.
1960  * Currently the only hash flag is "restriced"
1961  * Key flags are as for hv.h
1962  */
1963 static int store_hash(stcxt_t *cxt, HV *hv)
1964 {
1965         I32 len =
1966 #ifdef HAS_RESTRICTED_HASHES
1967             HvTOTALKEYS(hv);
1968 #else
1969             HvKEYS(hv);
1970 #endif
1971         I32 i;
1972         int ret = 0;
1973         I32 riter;
1974         HE *eiter;
1975         int flagged_hash = ((SvREADONLY(hv)
1976 #ifdef HAS_HASH_KEY_FLAGS
1977                              || HvHASKFLAGS(hv)
1978 #endif
1979                                 ) ? 1 : 0);
1980         unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
1981
1982         if (flagged_hash) {
1983             /* needs int cast for C++ compilers, doesn't it?  */
1984             TRACEME(("store_hash (0x%"UVxf") (flags %x)", PTR2UV(hv),
1985                      (int) hash_flags));
1986         } else {
1987             TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv)));
1988         }
1989
1990         /*
1991          * Signal hash by emitting SX_HASH, followed by the table length.
1992          */
1993
1994         if (flagged_hash) {
1995             PUTMARK(SX_FLAG_HASH);
1996             PUTMARK(hash_flags);
1997         } else {
1998             PUTMARK(SX_HASH);
1999         }
2000         WLEN(len);
2001         TRACEME(("size = %d", len));
2002
2003         /*
2004          * Save possible iteration state via each() on that table.
2005          */
2006
2007         riter = HvRITER(hv);
2008         eiter = HvEITER(hv);
2009         hv_iterinit(hv);
2010
2011         /*
2012          * Now store each item recursively.
2013          *
2014      * If canonical is defined to some true value then store each
2015      * key/value pair in sorted order otherwise the order is random.
2016          * Canonical order is irrelevant when a deep clone operation is performed.
2017          *
2018          * Fetch the value from perl only once per store() operation, and only
2019          * when needed.
2020          */
2021
2022         if (
2023                 !(cxt->optype & ST_CLONE) && (cxt->canonical == 1 ||
2024                 (cxt->canonical < 0 && (cxt->canonical =
2025                         (SvTRUE(perl_get_sv("Storable::canonical", TRUE)) ? 1 : 0))))
2026         ) {
2027                 /*
2028                  * Storing in order, sorted by key.
2029                  * Run through the hash, building up an array of keys in a
2030                  * mortal array, sort the array and then run through the
2031                  * array.
2032                  */
2033
2034                 AV *av = newAV();
2035
2036                 /*av_extend (av, len);*/
2037
2038                 TRACEME(("using canonical order"));
2039
2040                 for (i = 0; i < len; i++) {
2041 #ifdef HAS_RESTRICTED_HASHES
2042                         HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
2043 #else
2044                         HE *he = hv_iternext(hv);
2045 #endif
2046                         SV *key = hv_iterkeysv(he);
2047                         av_store(av, AvFILLp(av)+1, key);       /* av_push(), really */
2048                 }
2049
2050                 qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
2051
2052                 for (i = 0; i < len; i++) {
2053                         unsigned char flags;
2054                         char *keyval;
2055                         STRLEN keylen_tmp;
2056                         I32 keylen;
2057                         SV *key = av_shift(av);
2058                         HE *he  = hv_fetch_ent(hv, key, 0, 0);
2059                         SV *val = HeVAL(he);
2060                         if (val == 0)
2061                                 return 1;               /* Internal error, not I/O error */
2062
2063                         /*
2064                          * Store value first.
2065                          */
2066
2067                         TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
2068
2069                         if ((ret = store(cxt, val)))    /* Extra () for -Wall, grr... */
2070                                 goto out;
2071
2072                         /*
2073                          * Write key string.
2074                          * Keys are written after values to make sure retrieval
2075                          * can be optimal in terms of memory usage, where keys are
2076                          * read into a fixed unique buffer called kbuf.
2077                          * See retrieve_hash() for details.
2078                          */
2079
2080                         /* Implementation of restricted hashes isn't nicely
2081                            abstracted:  */
2082                         flags
2083                             = (((hash_flags & SHV_RESTRICTED)
2084                                 && SvREADONLY(val))
2085                                ? SHV_K_LOCKED : 0);
2086                         if (val == &PL_sv_undef)
2087                             flags |= SHV_K_PLACEHOLDER;
2088
2089                         keyval = SvPV(key, keylen_tmp);
2090                         keylen = keylen_tmp;
2091 #ifdef HAS_UTF8_HASHES
2092                         /* If you build without optimisation on pre 5.6
2093                            then nothing spots that SvUTF8(key) is always 0,
2094                            so the block isn't optimised away, at which point
2095                            the linker dislikes the reference to
2096                            bytes_from_utf8.  */
2097                         if (SvUTF8(key)) {
2098                             const char *keysave = keyval;
2099                             bool is_utf8 = TRUE;
2100
2101                             /* Just casting the &klen to (STRLEN) won't work
2102                                well if STRLEN and I32 are of different widths.
2103                                --jhi */
2104                             keyval = (char*)bytes_from_utf8((U8*)keyval,
2105                                                             &keylen_tmp,
2106                                                             &is_utf8);
2107
2108                             /* If we were able to downgrade here, then than
2109                                means that we have  a key which only had chars
2110                                0-255, but was utf8 encoded.  */
2111
2112                             if (keyval != keysave) {
2113                                 keylen = keylen_tmp;
2114                                 flags |= SHV_K_WASUTF8;
2115                             } else {
2116                                 /* keylen_tmp can't have changed, so no need
2117                                    to assign back to keylen.  */
2118                                 flags |= SHV_K_UTF8;
2119                             }
2120                         }
2121 #endif
2122
2123                         if (flagged_hash) {
2124                             PUTMARK(flags);
2125                             TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval));
2126                         } else {
2127                             assert (flags == 0);
2128                             TRACEME(("(#%d) key '%s'", i, keyval));
2129                         }
2130                         WLEN(keylen);
2131                         if (keylen)
2132                                 WRITE(keyval, keylen);
2133                         if (flags & SHV_K_WASUTF8)
2134                             Safefree (keyval);
2135                 }
2136
2137                 /*
2138                  * Free up the temporary array
2139                  */
2140
2141                 av_undef(av);
2142                 sv_free((SV *) av);
2143
2144         } else {
2145
2146                 /*
2147                  * Storing in "random" order (in the order the keys are stored
2148                  * within the the hash).  This is the default and will be faster!
2149                  */
2150
2151                 for (i = 0; i < len; i++) {
2152                         char *key;
2153                         I32 len;
2154                         unsigned char flags;
2155 #ifdef HV_ITERNEXT_WANTPLACEHOLDERS
2156                         HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
2157 #else
2158                         HE *he = hv_iternext(hv);
2159 #endif
2160                         SV *val = (he ? hv_iterval(hv, he) : 0);
2161                         SV *key_sv = NULL;
2162                         HEK *hek;
2163
2164                         if (val == 0)
2165                                 return 1;               /* Internal error, not I/O error */
2166
2167                         /*
2168                          * Store value first.
2169                          */
2170
2171                         TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
2172
2173                         if ((ret = store(cxt, val)))    /* Extra () for -Wall, grr... */
2174                                 goto out;
2175
2176                         /* Implementation of restricted hashes isn't nicely
2177                            abstracted:  */
2178                         flags
2179                             = (((hash_flags & SHV_RESTRICTED)
2180                                 && SvREADONLY(val))
2181                                              ? SHV_K_LOCKED : 0);
2182                         if (val == &PL_sv_undef)
2183                             flags |= SHV_K_PLACEHOLDER;
2184
2185                         hek = HeKEY_hek(he);
2186                         len = HEK_LEN(hek);
2187                         if (len == HEf_SVKEY) {
2188                             /* This is somewhat sick, but the internal APIs are
2189                              * such that XS code could put one of these in in
2190                              * a regular hash.
2191                              * Maybe we should be capable of storing one if
2192                              * found.
2193                              */
2194                             key_sv = HeKEY_sv(he);
2195                             flags |= SHV_K_ISSV;
2196                         } else {
2197                             /* Regular string key. */
2198 #ifdef HAS_HASH_KEY_FLAGS
2199                             if (HEK_UTF8(hek))
2200                                 flags |= SHV_K_UTF8;
2201                             if (HEK_WASUTF8(hek))
2202                                 flags |= SHV_K_WASUTF8;
2203 #endif
2204                             key = HEK_KEY(hek);
2205                         }
2206                         /*
2207                          * Write key string.
2208                          * Keys are written after values to make sure retrieval
2209                          * can be optimal in terms of memory usage, where keys are
2210                          * read into a fixed unique buffer called kbuf.
2211                          * See retrieve_hash() for details.
2212                          */
2213
2214                         if (flagged_hash) {
2215                             PUTMARK(flags);
2216                             TRACEME(("(#%d) key '%s' flags %x", i, key, flags));
2217                         } else {
2218                             assert (flags == 0);
2219                             TRACEME(("(#%d) key '%s'", i, key));
2220                         }
2221                         if (flags & SHV_K_ISSV) {
2222                             store(cxt, key_sv);
2223                         } else {
2224                             WLEN(len);
2225                             if (len)
2226                                 WRITE(key, len);
2227                         }
2228                 }
2229     }
2230
2231         TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv)));
2232
2233 out:
2234         HvRITER(hv) = riter;            /* Restore hash iterator state */
2235         HvEITER(hv) = eiter;
2236
2237         return ret;
2238 }
2239
2240 /*
2241  * store_tied
2242  *
2243  * When storing a tied object (be it a tied scalar, array or hash), we lay out
2244  * a special mark, followed by the underlying tied object. For instance, when
2245  * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
2246  * <hash object> stands for the serialization of the tied hash.
2247  */
2248 static int store_tied(stcxt_t *cxt, SV *sv)
2249 {
2250         MAGIC *mg;
2251         int ret = 0;
2252         int svt = SvTYPE(sv);
2253         char mtype = 'P';
2254
2255         TRACEME(("store_tied (0x%"UVxf")", PTR2UV(sv)));
2256
2257         /*
2258          * We have a small run-time penalty here because we chose to factorise
2259          * all tieds objects into the same routine, and not have a store_tied_hash,
2260          * a store_tied_array, etc...
2261          *
2262          * Don't use a switch() statement, as most compilers don't optimize that
2263          * well for 2/3 values. An if() else if() cascade is just fine. We put
2264          * tied hashes first, as they are the most likely beasts.
2265          */
2266
2267         if (svt == SVt_PVHV) {
2268                 TRACEME(("tied hash"));
2269                 PUTMARK(SX_TIED_HASH);                  /* Introduces tied hash */
2270         } else if (svt == SVt_PVAV) {
2271                 TRACEME(("tied array"));
2272                 PUTMARK(SX_TIED_ARRAY);                 /* Introduces tied array */
2273         } else {
2274                 TRACEME(("tied scalar"));
2275                 PUTMARK(SX_TIED_SCALAR);                /* Introduces tied scalar */
2276                 mtype = 'q';
2277         }
2278
2279         if (!(mg = mg_find(sv, mtype)))
2280                 CROAK(("No magic '%c' found while storing tied %s", mtype,
2281                         (svt == SVt_PVHV) ? "hash" :
2282                                 (svt == SVt_PVAV) ? "array" : "scalar"));
2283
2284         /*
2285          * The mg->mg_obj found by mg_find() above actually points to the
2286          * underlying tied Perl object implementation. For instance, if the
2287          * original SV was that of a tied array, then mg->mg_obj is an AV.
2288          *
2289          * Note that we store the Perl object as-is. We don't call its FETCH
2290          * method along the way. At retrieval time, we won't call its STORE
2291          * method either, but the tieing magic will be re-installed. In itself,
2292          * that ensures that the tieing semantics are preserved since futher
2293          * accesses on the retrieved object will indeed call the magic methods...
2294          */
2295
2296         if ((ret = store(cxt, mg->mg_obj)))             /* Extra () for -Wall, grr... */
2297                 return ret;
2298
2299         TRACEME(("ok (tied)"));
2300
2301         return 0;
2302 }
2303
2304 /*
2305  * store_tied_item
2306  *
2307  * Stores a reference to an item within a tied structure:
2308  *
2309  *  . \$h{key}, stores both the (tied %h) object and 'key'.
2310  *  . \$a[idx], stores both the (tied @a) object and 'idx'.
2311  *
2312  * Layout is therefore either:
2313  *     SX_TIED_KEY <object> <key>
2314  *     SX_TIED_IDX <object> <index>
2315  */
2316 static int store_tied_item(stcxt_t *cxt, SV *sv)
2317 {
2318         MAGIC *mg;
2319         int ret;
2320
2321         TRACEME(("store_tied_item (0x%"UVxf")", PTR2UV(sv)));
2322
2323         if (!(mg = mg_find(sv, 'p')))
2324                 CROAK(("No magic 'p' found while storing reference to tied item"));
2325
2326         /*
2327          * We discriminate between \$h{key} and \$a[idx] via mg_ptr.
2328          */
2329
2330         if (mg->mg_ptr) {
2331                 TRACEME(("store_tied_item: storing a ref to a tied hash item"));
2332                 PUTMARK(SX_TIED_KEY);
2333                 TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
2334
2335                 if ((ret = store(cxt, mg->mg_obj)))             /* Extra () for -Wall, grr... */
2336                         return ret;
2337
2338                 TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
2339
2340                 if ((ret = store(cxt, (SV *) mg->mg_ptr)))      /* Idem, for -Wall */
2341                         return ret;
2342         } else {
2343                 I32 idx = mg->mg_len;
2344
2345                 TRACEME(("store_tied_item: storing a ref to a tied array item "));
2346                 PUTMARK(SX_TIED_IDX);
2347                 TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
2348
2349                 if ((ret = store(cxt, mg->mg_obj)))             /* Idem, for -Wall */
2350                         return ret;
2351
2352                 TRACEME(("store_tied_item: storing IDX %d", idx));
2353
2354                 WLEN(idx);
2355         }
2356
2357         TRACEME(("ok (tied item)"));
2358
2359         return 0;
2360 }
2361
2362 /*
2363  * store_hook           -- dispatched manually, not via sv_store[]
2364  *
2365  * The blessed SV is serialized by a hook.
2366  *
2367  * Simple Layout is:
2368  *
2369  *     SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
2370  *
2371  * where <flags> indicates how long <len>, <len2> and <len3> are, whether
2372  * the trailing part [] is present, the type of object (scalar, array or hash).
2373  * There is also a bit which says how the classname is stored between:
2374  *
2375  *     <len> <classname>
2376  *     <index>
2377  *
2378  * and when the <index> form is used (classname already seen), the "large
2379  * classname" bit in <flags> indicates how large the <index> is.
2380  *
2381  * The serialized string returned by the hook is of length <len2> and comes
2382  * next.  It is an opaque string for us.
2383  *
2384  * Those <len3> object IDs which are listed last represent the extra references
2385  * not directly serialized by the hook, but which are linked to the object.
2386  *
2387  * When recursion is mandated to resolve object-IDs not yet seen, we have
2388  * instead, with <header> being flags with bits set to indicate the object type
2389  * and that recursion was indeed needed:
2390  *
2391  *     SX_HOOK <header> <object> <header> <object> <flags>
2392  *
2393  * that same header being repeated between serialized objects obtained through
2394  * recursion, until we reach flags indicating no recursion, at which point
2395  * we know we've resynchronized with a single layout, after <flags>.
2396  *
2397  * When storing a blessed ref to a tied variable, the following format is
2398  * used:
2399  *
2400  *     SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
2401  *
2402  * The first <flags> indication carries an object of type SHT_EXTRA, and the
2403  * real object type is held in the <extra> flag.  At the very end of the
2404  * serialization stream, the underlying magic object is serialized, just like
2405  * any other tied variable.
2406  */
2407 static int store_hook(
2408         stcxt_t *cxt,
2409         SV *sv,
2410         int type,
2411         HV *pkg,
2412         SV *hook)
2413 {
2414         I32 len;
2415         char *class;
2416         STRLEN len2;
2417         SV *ref;
2418         AV *av;
2419         SV **ary;
2420         int count;                              /* really len3 + 1 */
2421         unsigned char flags;
2422         char *pv;
2423         int i;
2424         int recursed = 0;               /* counts recursion */
2425         int obj_type;                   /* object type, on 2 bits */
2426         I32 classnum;
2427         int ret;
2428         int clone = cxt->optype & ST_CLONE;
2429         char mtype = '\0';                              /* for blessed ref to tied structures */
2430         unsigned char eflags = '\0';    /* used when object type is SHT_EXTRA */
2431
2432         TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
2433
2434         /*
2435          * Determine object type on 2 bits.
2436          */
2437
2438         switch (type) {
2439         case svis_SCALAR:
2440                 obj_type = SHT_SCALAR;
2441                 break;
2442         case svis_ARRAY:
2443                 obj_type = SHT_ARRAY;
2444                 break;
2445         case svis_HASH:
2446                 obj_type = SHT_HASH;
2447                 break;
2448         case svis_TIED:
2449                 /*
2450                  * Produced by a blessed ref to a tied data structure, $o in the
2451                  * following Perl code.
2452                  *
2453                  *      my %h;
2454                  *  tie %h, 'FOO';
2455                  *      my $o = bless \%h, 'BAR';
2456                  *
2457                  * Signal the tie-ing magic by setting the object type as SHT_EXTRA
2458                  * (since we have only 2 bits in <flags> to store the type), and an
2459                  * <extra> byte flag will be emitted after the FIRST <flags> in the
2460                  * stream, carrying what we put in `eflags'.
2461                  */
2462                 obj_type = SHT_EXTRA;
2463                 switch (SvTYPE(sv)) {
2464                 case SVt_PVHV:
2465                         eflags = (unsigned char) SHT_THASH;
2466                         mtype = 'P';
2467                         break;
2468                 case SVt_PVAV:
2469                         eflags = (unsigned char) SHT_TARRAY;
2470                         mtype = 'P';
2471                         break;
2472                 default:
2473                         eflags = (unsigned char) SHT_TSCALAR;
2474                         mtype = 'q';
2475                         break;
2476                 }
2477                 break;
2478         default:
2479                 CROAK(("Unexpected object type (%d) in store_hook()", type));
2480         }
2481         flags = SHF_NEED_RECURSE | obj_type;
2482
2483         class = HvNAME(pkg);
2484         len = strlen(class);
2485
2486         /*
2487          * To call the hook, we need to fake a call like:
2488          *
2489          *    $object->STORABLE_freeze($cloning);
2490          *
2491          * but we don't have the $object here.  For instance, if $object is
2492          * a blessed array, what we have in `sv' is the array, and we can't
2493          * call a method on those.
2494          *
2495          * Therefore, we need to create a temporary reference to the object and
2496          * make the call on that reference.
2497          */
2498
2499         TRACEME(("about to call STORABLE_freeze on class %s", class));
2500
2501         ref = newRV_noinc(sv);                          /* Temporary reference */
2502         av = array_call(ref, hook, clone);      /* @a = $object->STORABLE_freeze($c) */
2503         SvRV(ref) = 0;
2504         SvREFCNT_dec(ref);                                      /* Reclaim temporary reference */
2505
2506         count = AvFILLp(av) + 1;
2507         TRACEME(("store_hook, array holds %d items", count));
2508
2509         /*
2510          * If they return an empty list, it means they wish to ignore the
2511          * hook for this class (and not just this instance -- that's for them
2512          * to handle if they so wish).
2513          *
2514          * Simply disable the cached entry for the hook (it won't be recomputed
2515          * since it's present in the cache) and recurse to store_blessed().
2516          */
2517
2518         if (!count) {
2519                 /*
2520                  * They must not change their mind in the middle of a serialization.
2521                  */
2522
2523                 if (hv_fetch(cxt->hclass, class, len, FALSE))
2524                         CROAK(("Too late to ignore hooks for %s class \"%s\"",
2525                                 (cxt->optype & ST_CLONE) ? "cloning" : "storing", class));
2526
2527                 pkg_hide(cxt->hook, pkg, "STORABLE_freeze");
2528
2529                 ASSERT(!pkg_can(cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
2530                 TRACEME(("ignoring STORABLE_freeze in class \"%s\"", class));
2531
2532                 return store_blessed(cxt, sv, type, pkg);
2533         }
2534
2535         /*
2536          * Get frozen string.
2537          */
2538
2539         ary = AvARRAY(av);
2540         pv = SvPV(ary[0], len2);
2541
2542         /*
2543          * If they returned more than one item, we need to serialize some
2544          * extra references if not already done.
2545          *
2546          * Loop over the array, starting at postion #1, and for each item,
2547          * ensure it is a reference, serialize it if not already done, and
2548          * replace the entry with the tag ID of the corresponding serialized
2549          * object.
2550          *
2551          * We CHEAT by not calling av_fetch() and read directly within the
2552          * array, for speed.
2553          */
2554
2555         for (i = 1; i < count; i++) {
2556                 SV **svh;
2557                 SV *rsv = ary[i];
2558                 SV *xsv;
2559                 AV *av_hook = cxt->hook_seen;
2560
2561                 if (!SvROK(rsv))
2562                         CROAK(("Item #%d returned by STORABLE_freeze "
2563                                 "for %s is not a reference", i, class));
2564                 xsv = SvRV(rsv);                /* Follow ref to know what to look for */
2565
2566                 /*
2567                  * Look in hseen and see if we have a tag already.
2568                  * Serialize entry if not done already, and get its tag.
2569                  */
2570
2571                 if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
2572                         goto sv_seen;           /* Avoid moving code too far to the right */
2573
2574                 TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
2575
2576                 /*
2577                  * We need to recurse to store that object and get it to be known
2578                  * so that we can resolve the list of object-IDs at retrieve time.
2579                  *
2580                  * The first time we do this, we need to emit the proper header
2581                  * indicating that we recursed, and what the type of object is (the
2582                  * object we're storing via a user-hook).  Indeed, during retrieval,
2583                  * we'll have to create the object before recursing to retrieve the
2584                  * others, in case those would point back at that object.
2585                  */
2586
2587                 /* [SX_HOOK] <flags> [<extra>] <object>*/
2588                 if (!recursed++) {
2589                         PUTMARK(SX_HOOK);
2590                         PUTMARK(flags);
2591                         if (obj_type == SHT_EXTRA)
2592                                 PUTMARK(eflags);
2593                 } else
2594                         PUTMARK(flags);
2595
2596                 if ((ret = store(cxt, xsv)))    /* Given by hook for us to store */
2597                         return ret;
2598
2599                 svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
2600                 if (!svh)
2601                         CROAK(("Could not serialize item #%d from hook in %s", i, class));
2602
2603                 /*
2604                  * It was the first time we serialized `xsv'.
2605                  *
2606                  * Keep this SV alive until the end of the serialization: if we
2607                  * disposed of it right now by decrementing its refcount, and it was
2608                  * a temporary value, some next temporary value allocated during
2609                  * another STORABLE_freeze might take its place, and we'd wrongly
2610                  * assume that new SV was already serialized, based on its presence
2611                  * in cxt->hseen.
2612                  *
2613                  * Therefore, push it away in cxt->hook_seen.
2614                  */
2615
2616                 av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv));
2617
2618         sv_seen:
2619                 /*
2620                  * Dispose of the REF they returned.  If we saved the `xsv' away
2621                  * in the array of returned SVs, that will not cause the underlying
2622                  * referenced SV to be reclaimed.
2623                  */
2624
2625                 ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF"));
2626                 SvREFCNT_dec(rsv);                      /* Dispose of reference */
2627
2628                 /*
2629                  * Replace entry with its tag (not a real SV, so no refcnt increment)
2630                  */
2631
2632                 ary[i] = *svh;
2633                 TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf,
2634                          i-1, PTR2UV(xsv), PTR2UV(*svh)));
2635         }
2636
2637         /*
2638          * Allocate a class ID if not already done.
2639          *
2640          * This needs to be done after the recursion above, since at retrieval
2641          * time, we'll see the inner objects first.  Many thanks to
2642          * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and
2643          * proposed the right fix.  -- RAM, 15/09/2000
2644          */
2645
2646         if (!known_class(cxt, class, len, &classnum)) {
2647                 TRACEME(("first time we see class %s, ID = %d", class, classnum));
2648                 classnum = -1;                          /* Mark: we must store classname */
2649         } else {
2650                 TRACEME(("already seen class %s, ID = %d", class, classnum));
2651         }
2652
2653         /*
2654          * Compute leading flags.
2655          */
2656
2657         flags = obj_type;
2658         if (((classnum == -1) ? len : classnum) > LG_SCALAR)
2659                 flags |= SHF_LARGE_CLASSLEN;
2660         if (classnum != -1)
2661                 flags |= SHF_IDX_CLASSNAME;
2662         if (len2 > LG_SCALAR)
2663                 flags |= SHF_LARGE_STRLEN;
2664         if (count > 1)
2665                 flags |= SHF_HAS_LIST;
2666         if (count > (LG_SCALAR + 1))
2667                 flags |= SHF_LARGE_LISTLEN;
2668
2669         /*
2670          * We're ready to emit either serialized form:
2671          *
2672          *   SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
2673          *   SX_HOOK <flags> <index>           <len2> <str> [<len3> <object-IDs>]
2674          *
2675          * If we recursed, the SX_HOOK has already been emitted.
2676          */
2677
2678         TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
2679                         "class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d",
2680                  recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
2681
2682         /* SX_HOOK <flags> [<extra>] */
2683         if (!recursed) {
2684                 PUTMARK(SX_HOOK);
2685                 PUTMARK(flags);
2686                 if (obj_type == SHT_EXTRA)
2687                         PUTMARK(eflags);
2688         } else
2689                 PUTMARK(flags);
2690
2691         /* <len> <classname> or <index> */
2692         if (flags & SHF_IDX_CLASSNAME) {
2693                 if (flags & SHF_LARGE_CLASSLEN)
2694                         WLEN(classnum);
2695                 else {
2696                         unsigned char cnum = (unsigned char) classnum;
2697                         PUTMARK(cnum);
2698                 }
2699         } else {
2700                 if (flags & SHF_LARGE_CLASSLEN)
2701                         WLEN(len);
2702                 else {
2703                         unsigned char clen = (unsigned char) len;
2704                         PUTMARK(clen);
2705                 }
2706                 WRITE(class, len);              /* Final \0 is omitted */
2707         }
2708
2709         /* <len2> <frozen-str> */
2710         if (flags & SHF_LARGE_STRLEN) {
2711                 I32 wlen2 = len2;               /* STRLEN might be 8 bytes */
2712                 WLEN(wlen2);                    /* Must write an I32 for 64-bit machines */
2713         } else {
2714                 unsigned char clen = (unsigned char) len2;
2715                 PUTMARK(clen);
2716         }
2717         if (len2)
2718                 WRITE(pv, (SSize_t)len2);       /* Final \0 is omitted */
2719
2720         /* [<len3> <object-IDs>] */
2721         if (flags & SHF_HAS_LIST) {
2722                 int len3 = count - 1;
2723                 if (flags & SHF_LARGE_LISTLEN)
2724                         WLEN(len3);
2725                 else {
2726                         unsigned char clen = (unsigned char) len3;
2727                         PUTMARK(clen);
2728                 }
2729
2730                 /*
2731                  * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a
2732                  * real pointer, rather a tag number, well under the 32-bit limit.
2733                  */
2734
2735                 for (i = 1; i < count; i++) {
2736                         I32 tagval = htonl(LOW_32BITS(ary[i]));
2737                         WRITE_I32(tagval);
2738                         TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
2739                 }
2740         }
2741
2742         /*
2743          * Free the array.  We need extra care for indices after 0, since they
2744          * don't hold real SVs but integers cast.
2745          */
2746
2747         if (count > 1)
2748                 AvFILLp(av) = 0;        /* Cheat, nothing after 0 interests us */
2749         av_undef(av);
2750         sv_free((SV *) av);
2751
2752         /*
2753          * If object was tied, need to insert serialization of the magic object.
2754          */
2755
2756         if (obj_type == SHT_EXTRA) {
2757                 MAGIC *mg;
2758
2759                 if (!(mg = mg_find(sv, mtype))) {
2760                         int svt = SvTYPE(sv);
2761                         CROAK(("No magic '%c' found while storing ref to tied %s with hook",
2762                                 mtype, (svt == SVt_PVHV) ? "hash" :
2763                                         (svt == SVt_PVAV) ? "array" : "scalar"));
2764                 }
2765
2766                 TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf,
2767                         PTR2UV(mg->mg_obj), PTR2UV(sv)));
2768
2769                 /*
2770                  * [<magic object>]
2771                  */
2772
2773                 if ((ret = store(cxt, mg->mg_obj)))     /* Extra () for -Wall, grr... */
2774                         return ret;
2775         }
2776
2777         return 0;
2778 }
2779
2780 /*
2781  * store_blessed        -- dispatched manually, not via sv_store[]
2782  *
2783  * Check whether there is a STORABLE_xxx hook defined in the class or in one
2784  * of its ancestors.  If there is, then redispatch to store_hook();
2785  *
2786  * Otherwise, the blessed SV is stored using the following layout:
2787  *
2788  *    SX_BLESS <flag> <len> <classname> <object>
2789  *
2790  * where <flag> indicates whether <len> is stored on 0 or 4 bytes, depending
2791  * on the high-order bit in flag: if 1, then length follows on 4 bytes.
2792  * Otherwise, the low order bits give the length, thereby giving a compact
2793  * representation for class names less than 127 chars long.
2794  *
2795  * Each <classname> seen is remembered and indexed, so that the next time
2796  * an object in the blessed in the same <classname> is stored, the following
2797  * will be emitted:
2798  *
2799  *    SX_IX_BLESS <flag> <index> <object>
2800  *
2801  * where <index> is the classname index, stored on 0 or 4 bytes depending
2802  * on the high-order bit in flag (same encoding as above for <len>).
2803  */
2804 static int store_blessed(
2805         stcxt_t *cxt,
2806         SV *sv,
2807         int type,
2808         HV *pkg)
2809 {
2810         SV *hook;
2811         I32 len;
2812         char *class;
2813         I32 classnum;
2814
2815         TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME(pkg)));
2816
2817         /*
2818          * Look for a hook for this blessed SV and redirect to store_hook()
2819          * if needed.
2820          */
2821
2822         hook = pkg_can(cxt->hook, pkg, "STORABLE_freeze");
2823         if (hook)
2824                 return store_hook(cxt, sv, type, pkg, hook);
2825
2826         /*
2827          * This is a blessed SV without any serialization hook.
2828          */
2829
2830         class = HvNAME(pkg);
2831         len = strlen(class);
2832
2833         TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d",
2834                  PTR2UV(sv), class, cxt->tagnum));
2835
2836         /*
2837          * Determine whether it is the first time we see that class name (in which
2838          * case it will be stored in the SX_BLESS form), or whether we already
2839          * saw that class name before (in which case the SX_IX_BLESS form will be
2840          * used).
2841          */
2842
2843         if (known_class(cxt, class, len, &classnum)) {
2844                 TRACEME(("already seen class %s, ID = %d", class, classnum));
2845                 PUTMARK(SX_IX_BLESS);
2846                 if (classnum <= LG_BLESS) {
2847                         unsigned char cnum = (unsigned char) classnum;
2848                         PUTMARK(cnum);
2849                 } else {
2850                         unsigned char flag = (unsigned char) 0x80;
2851                         PUTMARK(flag);
2852                         WLEN(classnum);
2853                 }
2854         } else {
2855                 TRACEME(("first time we see class %s, ID = %d", class, classnum));
2856                 PUTMARK(SX_BLESS);
2857                 if (len <= LG_BLESS) {
2858                         unsigned char clen = (unsigned char) len;
2859                         PUTMARK(clen);
2860                 } else {
2861                         unsigned char flag = (unsigned char) 0x80;
2862                         PUTMARK(flag);
2863                         WLEN(len);                                      /* Don't BER-encode, this should be rare */
2864                 }
2865                 WRITE(class, len);                              /* Final \0 is omitted */
2866         }
2867
2868         /*
2869          * Now emit the <object> part.
2870          */
2871
2872         return SV_STORE(type)(cxt, sv);
2873 }
2874
2875 /*
2876  * store_other
2877  *
2878  * We don't know how to store the item we reached, so return an error condition.
2879  * (it's probably a GLOB, some CODE reference, etc...)
2880  *
2881  * If they defined the `forgive_me' variable at the Perl level to some
2882  * true value, then don't croak, just warn, and store a placeholder string
2883  * instead.
2884  */
2885 static int store_other(stcxt_t *cxt, SV *sv)
2886 {
2887         I32 len;
2888         static char buf[80];
2889
2890         TRACEME(("store_other"));
2891
2892         /*
2893          * Fetch the value from perl only once per store() operation.
2894          */
2895
2896         if (
2897                 cxt->forgive_me == 0 ||
2898                 (cxt->forgive_me < 0 && !(cxt->forgive_me =
2899                         SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0))
2900         )
2901                 CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
2902
2903         warn("Can't store item %s(0x%"UVxf")",
2904                 sv_reftype(sv, FALSE), PTR2UV(sv));
2905
2906         /*
2907          * Store placeholder string as a scalar instead...
2908          */
2909
2910         (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE),
2911                        PTR2UV(sv), (char) 0);
2912
2913         len = strlen(buf);
2914         STORE_SCALAR(buf, len);
2915         TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, len));
2916
2917         return 0;
2918 }
2919
2920 /***
2921  *** Store driving routines
2922  ***/
2923
2924 /*
2925  * sv_type
2926  *
2927  * WARNING: partially duplicates Perl's sv_reftype for speed.
2928  *
2929  * Returns the type of the SV, identified by an integer. That integer
2930  * may then be used to index the dynamic routine dispatch table.
2931  */
2932 static int sv_type(SV *sv)
2933 {
2934         switch (SvTYPE(sv)) {
2935         case SVt_NULL:
2936         case SVt_IV:
2937         case SVt_NV:
2938                 /*
2939                  * No need to check for ROK, that can't be set here since there
2940                  * is no field capable of hodling the xrv_rv reference.
2941                  */
2942                 return svis_SCALAR;
2943         case SVt_PV:
2944         case SVt_RV:
2945         case SVt_PVIV:
2946         case SVt_PVNV:
2947                 /*
2948                  * Starting from SVt_PV, it is possible to have the ROK flag
2949                  * set, the pointer to the other SV being either stored in
2950                  * the xrv_rv (in the case of a pure SVt_RV), or as the
2951                  * xpv_pv field of an SVt_PV and its heirs.
2952                  *
2953                  * However, those SV cannot be magical or they would be an
2954                  * SVt_PVMG at least.
2955                  */
2956                 return SvROK(sv) ? svis_REF : svis_SCALAR;
2957         case SVt_PVMG:
2958         case SVt_PVLV:          /* Workaround for perl5.004_04 "LVALUE" bug */
2959                 if (SvRMAGICAL(sv) && (mg_find(sv, 'p')))
2960                         return svis_TIED_ITEM;
2961                 /* FALL THROUGH */
2962         case SVt_PVBM:
2963                 if (SvRMAGICAL(sv) && (mg_find(sv, 'q')))
2964                         return svis_TIED;
2965                 return SvROK(sv) ? svis_REF : svis_SCALAR;
2966         case SVt_PVAV:
2967                 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
2968                         return svis_TIED;
2969                 return svis_ARRAY;
2970         case SVt_PVHV:
2971                 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
2972                         return svis_TIED;
2973                 return svis_HASH;
2974         default:
2975                 break;
2976         }
2977
2978         return svis_OTHER;
2979 }
2980
2981 /*
2982  * store
2983  *
2984  * Recursively store objects pointed to by the sv to the specified file.
2985  *
2986  * Layout is <content> or SX_OBJECT <tagnum> if we reach an already stored
2987  * object (one for which storage has started -- it may not be over if we have
2988  * a self-referenced structure). This data set forms a stored <object>.
2989  */
2990 static int store(stcxt_t *cxt, SV *sv)
2991 {
2992         SV **svh;
2993         int ret;
2994         int type;
2995         HV *hseen = cxt->hseen;
2996
2997         TRACEME(("store (0x%"UVxf")", PTR2UV(sv)));
2998
2999         /*
3000          * If object has already been stored, do not duplicate data.
3001          * Simply emit the SX_OBJECT marker followed by its tag data.
3002          * The tag is always written in network order.
3003          *
3004          * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a
3005          * real pointer, rather a tag number (watch the insertion code below).
3006          * That means it pobably safe to assume it is well under the 32-bit limit,
3007          * and makes the truncation safe.
3008          *              -- RAM, 14/09/1999
3009          */
3010
3011         svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
3012         if (svh) {
3013                 I32 tagval = htonl(LOW_32BITS(*svh));
3014
3015                 TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval)));
3016
3017                 PUTMARK(SX_OBJECT);
3018                 WRITE_I32(tagval);
3019                 return 0;
3020         }
3021
3022         /*
3023          * Allocate a new tag and associate it with the address of the sv being
3024          * stored, before recursing...
3025          *
3026          * In order to avoid creating new SvIVs to hold the tagnum we just
3027          * cast the tagnum to an SV pointer and store that in the hash.  This
3028          * means that we must clean up the hash manually afterwards, but gives
3029          * us a 15% throughput increase.
3030          *
3031          */
3032
3033         cxt->tagnum++;
3034         if (!hv_store(hseen,
3035                         (char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0))
3036                 return -1;
3037
3038         /*
3039          * Store `sv' and everything beneath it, using appropriate routine.
3040          * Abort immediately if we get a non-zero status back.
3041          */
3042
3043         type = sv_type(sv);
3044
3045         TRACEME(("storing 0x%"UVxf" tag #%d, type %d...",
3046                  PTR2UV(sv), cxt->tagnum, type));
3047
3048         if (SvOBJECT(sv)) {
3049                 HV *pkg = SvSTASH(sv);
3050                 ret = store_blessed(cxt, sv, type, pkg);
3051         } else
3052                 ret = SV_STORE(type)(cxt, sv);
3053
3054         TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)",
3055                 ret ? "FAILED" : "ok", PTR2UV(sv),
3056                 SvREFCNT(sv), sv_reftype(sv, FALSE)));
3057
3058         return ret;
3059 }
3060
3061 /*
3062  * magic_write
3063  *
3064  * Write magic number and system information into the file.
3065  * Layout is <magic> <network> [<len> <byteorder> <sizeof int> <sizeof long>
3066  * <sizeof ptr>] where <len> is the length of the byteorder hexa string.
3067  * All size and lenghts are written as single characters here.
3068  *
3069  * Note that no byte ordering info is emitted when <network> is true, since
3070  * integers will be emitted in network order in that case.
3071  */
3072 static int magic_write(stcxt_t *cxt)
3073 {
3074         char buf[256];  /* Enough room for 256 hexa digits */
3075         unsigned char c;
3076         int use_network_order = cxt->netorder;
3077
3078         TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio)
3079                  : -1));
3080
3081         if (cxt->fio)
3082                 WRITE(magicstr, (SSize_t)strlen(magicstr));     /* Don't write final \0 */
3083
3084         /*
3085          * Starting with 0.6, the "use_network_order" byte flag is also used to
3086          * indicate the version number of the binary image, encoded in the upper
3087          * bits. The bit 0 is always used to indicate network order.
3088          */
3089
3090         c = (unsigned char)
3091                 ((use_network_order ? 0x1 : 0x0) | (STORABLE_BIN_MAJOR << 1));
3092         PUTMARK(c);
3093
3094         /*
3095          * Starting with 0.7, a full byte is dedicated to the minor version of
3096          * the binary format, which is incremented only when new markers are
3097          * introduced, for instance, but when backward compatibility is preserved.
3098          */
3099
3100         PUTMARK((unsigned char) STORABLE_BIN_WRITE_MINOR);
3101
3102         if (use_network_order)
3103                 return 0;                                               /* Don't bother with byte ordering */
3104
3105         sprintf(buf, "%lx", (unsigned long) BYTEORDER);
3106         c = (unsigned char) strlen(buf);
3107         PUTMARK(c);
3108         WRITE(buf, (SSize_t)c);         /* Don't write final \0 */
3109         PUTMARK((unsigned char) sizeof(int));
3110         PUTMARK((unsigned char) sizeof(long));
3111         PUTMARK((unsigned char) sizeof(char *));
3112         PUTMARK((unsigned char) sizeof(NV));
3113
3114         TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
3115                  (unsigned long) BYTEORDER, (int) c,
3116                  (int) sizeof(int), (int) sizeof(long),
3117                  (int) sizeof(char *), (int) sizeof(NV)));
3118
3119         return 0;
3120 }
3121
3122 /*
3123  * do_store
3124  *
3125  * Common code for store operations.
3126  *
3127  * When memory store is requested (f = NULL) and a non null SV* is given in
3128  * `res', it is filled with a new SV created out of the memory buffer.
3129  *
3130  * It is required to provide a non-null `res' when the operation type is not
3131  * dclone() and store() is performed to memory.
3132  */
3133 static int do_store(
3134         PerlIO *f,
3135         SV *sv,
3136         int optype,
3137         int network_order,
3138         SV **res)
3139 {
3140         dSTCXT;
3141         int status;
3142
3143         ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res,
3144                 ("must supply result SV pointer for real recursion to memory"));
3145
3146         TRACEME(("do_store (optype=%d, netorder=%d)",
3147                 optype, network_order));
3148
3149         optype |= ST_STORE;
3150
3151         /*
3152          * Workaround for CROAK leak: if they enter with a "dirty" context,
3153          * free up memory for them now.
3154          */
3155
3156         if (cxt->s_dirty)
3157                 clean_context(cxt);
3158
3159         /*
3160          * Now that STORABLE_xxx hooks exist, it is possible that they try to
3161          * re-enter store() via the hooks.  We need to stack contexts.
3162          */
3163
3164         if (cxt->entry)
3165                 cxt = allocate_context(cxt);
3166
3167         cxt->entry++;
3168
3169         ASSERT(cxt->entry == 1, ("starting new recursion"));
3170         ASSERT(!cxt->s_dirty, ("clean context"));
3171
3172         /*
3173          * Ensure sv is actually a reference. From perl, we called something
3174          * like:
3175          *       pstore(FILE, \@array);
3176          * so we must get the scalar value behing that reference.
3177          */
3178
3179         if (!SvROK(sv))
3180                 CROAK(("Not a reference"));
3181         sv = SvRV(sv);                  /* So follow it to know what to store */
3182
3183         /*
3184          * If we're going to store to memory, reset the buffer.
3185          */
3186
3187         if (!f)
3188                 MBUF_INIT(0);
3189
3190         /*
3191          * Prepare context and emit headers.
3192          */
3193
3194         init_store_context(cxt, f, optype, network_order);
3195
3196         if (-1 == magic_write(cxt))             /* Emit magic and ILP info */
3197                 return 0;                                       /* Error */
3198
3199         /*
3200          * Recursively store object...
3201          */
3202
3203         ASSERT(is_storing(), ("within store operation"));
3204
3205         status = store(cxt, sv);                /* Just do it! */
3206
3207         /*
3208          * If they asked for a memory store and they provided an SV pointer,
3209          * make an SV string out of the buffer and fill their pointer.
3210          *
3211          * When asking for ST_REAL, it's MANDATORY for the caller to provide
3212          * an SV, since context cleanup might free the buffer if we did recurse.
3213          * (unless caller is dclone(), which is aware of that).
3214          */
3215
3216         if (!cxt->fio && res)
3217                 *res = mbuf2sv();
3218
3219         /*
3220          * Final cleanup.
3221          *
3222          * The "root" context is never freed, since it is meant to be always
3223          * handy for the common case where no recursion occurs at all (i.e.
3224          * we enter store() outside of any Storable code and leave it, period).
3225          * We know it's the "root" context because there's nothing stacked
3226          * underneath it.
3227          *
3228          * OPTIMIZATION:
3229          *
3230          * When deep cloning, we don't free the context: doing so would force
3231          * us to copy the data in the memory buffer.  Sicne we know we're
3232          * about to enter do_retrieve...
3233          */
3234
3235         clean_store_context(cxt);
3236         if (cxt->prev && !(cxt->optype & ST_CLONE))
3237                 free_context(cxt);
3238
3239         TRACEME(("do_store returns %d", status));
3240
3241         return status == 0;
3242 }
3243
3244 /*
3245  * pstore
3246  *
3247  * Store the transitive data closure of given object to disk.
3248  * Returns 0 on error, a true value otherwise.
3249  */
3250 int pstore(PerlIO *f, SV *sv)
3251 {
3252         TRACEME(("pstore"));
3253         return do_store(f, sv, 0, FALSE, (SV**) 0);
3254
3255 }
3256
3257 /*
3258  * net_pstore
3259  *
3260  * Same as pstore(), but network order is used for integers and doubles are
3261  * emitted as strings.
3262  */
3263 int net_pstore(PerlIO *f, SV *sv)
3264 {
3265         TRACEME(("net_pstore"));
3266         return do_store(f, sv, 0, TRUE, (SV**) 0);
3267 }
3268
3269 /***
3270  *** Memory stores.
3271  ***/
3272
3273 /*
3274  * mbuf2sv
3275  *
3276  * Build a new SV out of the content of the internal memory buffer.
3277  */
3278 static SV *mbuf2sv(void)
3279 {
3280         dSTCXT;
3281
3282         return newSVpv(mbase, MBUF_SIZE());
3283 }
3284
3285 /*
3286  * mstore
3287  *
3288  * Store the transitive data closure of given object to memory.
3289  * Returns undef on error, a scalar value containing the data otherwise.
3290  */
3291 SV *mstore(SV *sv)
3292 {
3293         SV *out;
3294
3295         TRACEME(("mstore"));
3296
3297         if (!do_store((PerlIO*) 0, sv, 0, FALSE, &out))
3298                 return &PL_sv_undef;
3299
3300         return out;
3301 }
3302
3303 /*
3304  * net_mstore
3305  *
3306  * Same as mstore(), but network order is used for integers and doubles are
3307  * emitted as strings.
3308  */
3309 SV *net_mstore(SV *sv)
3310 {
3311         SV *out;
3312
3313         TRACEME(("net_mstore"));
3314
3315         if (!do_store((PerlIO*) 0, sv, 0, TRUE, &out))
3316                 return &PL_sv_undef;
3317
3318         return out;
3319 }
3320
3321 /***
3322  *** Specific retrieve callbacks.
3323  ***/
3324
3325 /*
3326  * retrieve_other
3327  *
3328  * Return an error via croak, since it is not possible that we get here
3329  * under normal conditions, when facing a file produced via pstore().
3330  */
3331 static SV *retrieve_other(stcxt_t *cxt, char *cname)
3332 {
3333         if (
3334                 cxt->ver_major != STORABLE_BIN_MAJOR &&
3335                 cxt->ver_minor != STORABLE_BIN_MINOR
3336         ) {
3337                 CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d",
3338                         cxt->fio ? "file" : "string",
3339                         cxt->ver_major, cxt->ver_minor,
3340                         STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
3341         } else {
3342                 CROAK(("Corrupted storable %s (binary v%d.%d)",
3343                         cxt->fio ? "file" : "string",
3344                         cxt->ver_major, cxt->ver_minor));
3345         }
3346
3347         return (SV *) 0;                /* Just in case */
3348 }
3349
3350 /*
3351  * retrieve_idx_blessed
3352  *
3353  * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
3354  * <index> can be coded on either 1 or 5 bytes.
3355  */
3356 static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname)
3357 {
3358         I32 idx;
3359         char *class;
3360         SV **sva;
3361         SV *sv;
3362
3363         TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum));
3364         ASSERT(!cname, ("no bless-into class given here, got %s", cname));
3365
3366         GETMARK(idx);                   /* Index coded on a single char? */
3367         if (idx & 0x80)
3368                 RLEN(idx);
3369
3370         /*
3371          * Fetch classname in `aclass'
3372          */
3373
3374         sva = av_fetch(cxt->aclass, idx, FALSE);
3375         if (!sva)
3376                 CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx));
3377
3378         class = SvPVX(*sva);    /* We know it's a PV, by construction */
3379
3380         TRACEME(("class ID %d => %s", idx, class));
3381
3382         /*
3383          * Retrieve object and bless it.
3384          */
3385
3386         sv = retrieve(cxt, class);      /* First SV which is SEEN will be blessed */
3387
3388         return sv;
3389 }
3390
3391 /*
3392  * retrieve_blessed
3393  *
3394  * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
3395  * <len> can be coded on either 1 or 5 bytes.
3396  */
3397 static SV *retrieve_blessed(stcxt_t *cxt, char *cname)
3398 {
3399         I32 len;
3400         SV *sv;
3401         char buf[LG_BLESS + 1];         /* Avoid malloc() if possible */
3402         char *class = buf;
3403
3404         TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
3405         ASSERT(!cname, ("no bless-into class given here, got %s", cname));
3406
3407         /*
3408          * Decode class name length and read that name.
3409          *
3410          * Short classnames have two advantages: their length is stored on one
3411          * single byte, and the string can be read on the stack.
3412          */
3413
3414         GETMARK(len);                   /* Length coded on a single char? */
3415         if (len & 0x80) {
3416                 RLEN(len);
3417                 TRACEME(("** allocating %d bytes for class name", len+1));
3418                 New(10003, class, len+1, char);
3419         }
3420         READ(class, len);
3421         class[len] = '\0';              /* Mark string end */
3422
3423         /*
3424          * It's a new classname, otherwise it would have been an SX_IX_BLESS.
3425          */
3426
3427         TRACEME(("new class name \"%s\" will bear ID = %d", class, cxt->classnum));
3428
3429         if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
3430                 return (SV *) 0;
3431
3432         /*
3433          * Retrieve object and bless it.
3434          */
3435
3436         sv = retrieve(cxt, class);      /* First SV which is SEEN will be blessed */
3437         if (class != buf)
3438                 Safefree(class);
3439
3440         return sv;
3441 }
3442
3443 /*
3444  * retrieve_hook
3445  *
3446  * Layout: SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
3447  * with leading mark already read, as usual.
3448  *
3449  * When recursion was involved during serialization of the object, there
3450  * is an unknown amount of serialized objects after the SX_HOOK mark.  Until
3451  * we reach a <flags> marker with the recursion bit cleared.
3452  *
3453  * If the first <flags> byte contains a type of SHT_EXTRA, then the real type
3454  * is held in the <extra> byte, and if the object is tied, the serialized
3455  * magic object comes at the very end:
3456  *
3457  *     SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
3458  *
3459  * This means the STORABLE_thaw hook will NOT get a tied variable during its
3460  * processing (since we won't have seen the magic object by the time the hook
3461  * is called).  See comments below for why it was done that way.
3462  */
3463 static SV *retrieve_hook(stcxt_t *cxt, char *cname)
3464 {
3465         I32 len;
3466         char buf[LG_BLESS + 1];         /* Avoid malloc() if possible */
3467         char *class = buf;
3468         unsigned int flags;
3469         I32 len2;
3470         SV *frozen;
3471         I32 len3 = 0;
3472         AV *av = 0;
3473         SV *hook;
3474         SV *sv;
3475         SV *rv;
3476         int obj_type;
3477         int clone = cxt->optype & ST_CLONE;
3478         char mtype = '\0';
3479         unsigned int extra_type = 0;
3480
3481         TRACEME(("retrieve_hook (#%d)", cxt->tagnum));
3482         ASSERT(!cname, ("no bless-into class given here, got %s", cname));
3483
3484         /*
3485          * Read flags, which tell us about the type, and whether we need to recurse.
3486          */
3487
3488         GETMARK(flags);
3489
3490         /*
3491          * Create the (empty) object, and mark it as seen.
3492          *
3493          * This must be done now, because tags are incremented, and during
3494          * serialization, the object tag was affected before recursion could
3495          * take place.
3496          */
3497
3498         obj_type = flags & SHF_TYPE_MASK;
3499         switch (obj_type) {
3500         case SHT_SCALAR:
3501                 sv = newSV(0);
3502                 break;
3503         case SHT_ARRAY:
3504                 sv = (SV *) newAV();
3505                 break;
3506         case SHT_HASH:
3507                 sv = (SV *) newHV();
3508                 break;
3509         case SHT_EXTRA:
3510                 /*
3511                  * Read <extra> flag to know the type of the object.
3512                  * Record associated magic type for later.
3513                  */
3514                 GETMARK(extra_type);
3515                 switch (extra_type) {
3516                 case SHT_TSCALAR:
3517                         sv = newSV(0);
3518                         mtype = 'q';
3519                         break;
3520                 case SHT_TARRAY:
3521                         sv = (SV *) newAV();
3522                         mtype = 'P';
3523                         break;
3524                 case SHT_THASH:
3525                         sv = (SV *) newHV();
3526                         mtype = 'P';
3527                         break;
3528                 default:
3529                         return retrieve_other(cxt, 0);  /* Let it croak */
3530                 }
3531                 break;
3532         default:
3533                 return retrieve_other(cxt, 0);          /* Let it croak */
3534         }
3535         SEEN(sv, 0);                                                    /* Don't bless yet */
3536
3537         /*
3538          * Whilst flags tell us to recurse, do so.
3539          *
3540          * We don't need to remember the addresses returned by retrieval, because
3541          * all the references will be obtained through indirection via the object
3542          * tags in the object-ID list.
3543          */
3544
3545         while (flags & SHF_NEED_RECURSE) {
3546                 TRACEME(("retrieve_hook recursing..."));
3547                 rv = retrieve(cxt, 0);
3548                 if (!rv)
3549                         return (SV *) 0;
3550                 TRACEME(("retrieve_hook back with rv=0x%"UVxf,
3551                          PTR2UV(rv)));
3552                 GETMARK(flags);
3553         }
3554
3555         if (flags & SHF_IDX_CLASSNAME) {
3556                 SV **sva;
3557                 I32 idx;
3558
3559                 /*
3560                  * Fetch index from `aclass'
3561                  */
3562
3563                 if (flags & SHF_LARGE_CLASSLEN)
3564                         RLEN(idx);
3565                 else
3566                         GETMARK(idx);
3567
3568                 sva = av_fetch(cxt->aclass, idx, FALSE);
3569                 if (!sva)
3570                         CROAK(("Class name #%"IVdf" should have been seen already",
3571                                 (IV) idx));
3572
3573                 class = SvPVX(*sva);    /* We know it's a PV, by construction */
3574                 TRACEME(("class ID %d => %s", idx, class));
3575
3576         } else {
3577                 /*
3578                  * Decode class name length and read that name.
3579                  *
3580                  * NOTA BENE: even if the length is stored on one byte, we don't read
3581                  * on the stack.  Just like retrieve_blessed(), we limit the name to
3582                  * LG_BLESS bytes.  This is an arbitrary decision.
3583                  */
3584
3585                 if (flags & SHF_LARGE_CLASSLEN)
3586                         RLEN(len);
3587                 else
3588                         GETMARK(len);
3589
3590                 if (len > LG_BLESS) {
3591                         TRACEME(("** allocating %d bytes for class name", len+1));
3592                         New(10003, class, len+1, char);
3593                 }
3594
3595                 READ(class, len);
3596                 class[len] = '\0';              /* Mark string end */
3597
3598                 /*
3599                  * Record new classname.
3600                  */
3601
3602                 if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
3603                         return (SV *) 0;
3604         }
3605
3606         TRACEME(("class name: %s", class));
3607
3608         /*
3609          * Decode user-frozen string length and read it in an SV.
3610          *
3611          * For efficiency reasons, we read data directly into the SV buffer.
3612          * To understand that code, read retrieve_scalar()
3613          */
3614
3615         if (flags & SHF_LARGE_STRLEN)
3616                 RLEN(len2);
3617         else
3618                 GETMARK(len2);
3619
3620         frozen = NEWSV(10002, len2);
3621         if (len2) {
3622                 SAFEREAD(SvPVX(frozen), len2, frozen);
3623                 SvCUR_set(frozen, len2);
3624                 *SvEND(frozen) = '\0';
3625         }
3626         (void) SvPOK_only(frozen);              /* Validates string pointer */
3627         if (cxt->s_tainted)                             /* Is input source tainted? */
3628                 SvTAINT(frozen);
3629
3630         TRACEME(("frozen string: %d bytes", len2));
3631
3632         /*
3633          * Decode object-ID list length, if present.
3634          */
3635
3636         if (flags & SHF_HAS_LIST) {
3637                 if (flags & SHF_LARGE_LISTLEN)
3638                         RLEN(len3);
3639                 else
3640                         GETMARK(len3);
3641                 if (len3) {
3642                         av = newAV();
3643                         av_extend(av, len3 + 1);        /* Leave room for [0] */
3644                         AvFILLp(av) = len3;                     /* About to be filled anyway */
3645                 }
3646         }
3647
3648         TRACEME(("has %d object IDs to link", len3));
3649
3650         /*
3651          * Read object-ID list into array.
3652          * Because we pre-extended it, we can cheat and fill it manually.
3653          *
3654          * We read object tags and we can convert them into SV* on the fly
3655          * because we know all the references listed in there (as tags)
3656          * have been already serialized, hence we have a valid correspondance
3657          * between each of those tags and the recreated SV.
3658          */
3659
3660         if (av) {
3661                 SV **ary = AvARRAY(av);
3662                 int i;
3663                 for (i = 1; i <= len3; i++) {   /* We leave [0] alone */
3664                         I32 tag;
3665                         SV **svh;
3666                         SV *xsv;
3667
3668                         READ_I32(tag);
3669                         tag = ntohl(tag);
3670                         svh = av_fetch(cxt->aseen, tag, FALSE);
3671                         if (!svh)
3672                                 CROAK(("Object #%"IVdf" should have been retrieved already",
3673                                         (IV) tag));
3674                         xsv = *svh;
3675                         ary[i] = SvREFCNT_inc(xsv);
3676                 }
3677         }
3678
3679         /*
3680          * Bless the object and look up the STORABLE_thaw hook.
3681          */
3682
3683         BLESS(sv, class);
3684         hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
3685         if (!hook) {
3686                 /*
3687                  * Hook not found.  Maybe they did not require the module where this
3688                  * hook is defined yet?
3689                  *
3690                  * If the require below succeeds, we'll be able to find the hook.
3691                  * Still, it only works reliably when each class is defined in a
3692                  * file of its own.
3693                  */
3694
3695                 SV *psv = newSVpvn("require ", 8);
3696                 sv_catpv(psv, class);
3697
3698                 TRACEME(("No STORABLE_thaw defined for objects of class %s", class));
3699                 TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv)));
3700
3701                 perl_eval_sv(psv, G_DISCARD);
3702                 sv_free(psv);
3703
3704                 /*
3705                  * We cache results of pkg_can, so we need to uncache before attempting
3706                  * the lookup again.
3707                  */
3708
3709                 pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
3710                 hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
3711
3712                 if (!hook)
3713                         CROAK(("No STORABLE_thaw defined for objects of class %s "
3714                                         "(even after a \"require %s;\")", class, class));
3715         }
3716
3717         /*
3718          * If we don't have an `av' yet, prepare one.
3719          * Then insert the frozen string as item [0].
3720          */
3721
3722         if (!av) {
3723                 av = newAV();
3724                 av_extend(av, 1);
3725                 AvFILLp(av) = 0;
3726         }
3727         AvARRAY(av)[0] = SvREFCNT_inc(frozen);
3728
3729         /*
3730          * Call the hook as:
3731          *
3732          *   $object->STORABLE_thaw($cloning, $frozen, @refs);
3733          *
3734          * where $object is our blessed (empty) object, $cloning is a boolean
3735          * telling whether we're running a deep clone, $frozen is the frozen
3736          * string the user gave us in his serializing hook, and @refs, which may
3737          * be empty, is the list of extra references he returned along for us
3738          * to serialize.
3739          *
3740          * In effect, the hook is an alternate creation routine for the class,
3741          * the object itself being already created by the runtime.
3742          */
3743
3744         TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)",
3745                  class, PTR2UV(sv), AvFILLp(av) + 1));
3746
3747         rv = newRV(sv);
3748         (void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD);
3749         SvREFCNT_dec(rv);
3750
3751         /*
3752          * Final cleanup.
3753          */
3754
3755         SvREFCNT_dec(frozen);
3756         av_undef(av);
3757         sv_free((SV *) av);
3758         if (!(flags & SHF_IDX_CLASSNAME) && class != buf)
3759                 Safefree(class);
3760
3761         /*
3762          * If we had an <extra> type, then the object was not as simple, and
3763          * we need to restore extra magic now.
3764          */
3765
3766         if (!extra_type)
3767                 return sv;
3768
3769         TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv)));
3770
3771         rv = retrieve(cxt, 0);          /* Retrieve <magic object> */
3772
3773         TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf,
3774                 PTR2UV(rv), PTR2UV(sv)));
3775
3776         switch (extra_type) {
3777         case SHT_TSCALAR:
3778                 sv_upgrade(sv, SVt_PVMG);
3779                 break;
3780         case SHT_TARRAY:
3781                 sv_upgrade(sv, SVt_PVAV);
3782                 AvREAL_off((AV *)sv);
3783                 break;
3784         case SHT_THASH:
3785                 sv_upgrade(sv, SVt_PVHV);
3786                 break;
3787         default:
3788                 CROAK(("Forgot to deal with extra type %d", extra_type));
3789                 break;
3790         }
3791
3792         /*
3793          * Adding the magic only now, well after the STORABLE_thaw hook was called
3794          * means the hook cannot know it deals with an object whose variable is
3795          * tied.  But this is happening when retrieving $o in the following case:
3796          *
3797          *      my %h;
3798          *  tie %h, 'FOO';
3799          *      my $o = bless \%h, 'BAR';
3800          *
3801          * The 'BAR' class is NOT the one where %h is tied into.  Therefore, as
3802          * far as the 'BAR' class is concerned, the fact that %h is not a REAL
3803          * hash but a tied one should not matter at all, and remain transparent.
3804          * This means the magic must be restored by Storable AFTER the hook is
3805          * called.
3806          *
3807          * That looks very reasonable to me, but then I've come up with this
3808          * after a bug report from David Nesting, who was trying to store such
3809          * an object and caused Storable to fail.  And unfortunately, it was
3810          * also the easiest way to retrofit support for blessed ref to tied objects
3811          * into the existing design.  -- RAM, 17/02/2001
3812          */
3813
3814         sv_magic(sv, rv, mtype, Nullch, 0);
3815         SvREFCNT_dec(rv);                       /* Undo refcnt inc from sv_magic() */
3816
3817         return sv;
3818 }
3819
3820 /*
3821  * retrieve_ref
3822  *
3823  * Retrieve reference to some other scalar.
3824  * Layout is SX_REF <object>, with SX_REF already read.
3825  */
3826 static SV *retrieve_ref(stcxt_t *cxt, char *cname)
3827 {
3828         SV *rv;
3829         SV *sv;
3830
3831         TRACEME(("retrieve_ref (#%d)", cxt->tagnum));
3832
3833         /*
3834          * We need to create the SV that holds the reference to the yet-to-retrieve
3835          * object now, so that we may record the address in the seen table.
3836          * Otherwise, if the object to retrieve references us, we won't be able
3837          * to resolve the SX_OBJECT we'll see at that point! Hence we cannot
3838          * do the retrieve first and use rv = newRV(sv) since it will be too late
3839          * for SEEN() recording.
3840          */
3841
3842         rv = NEWSV(10002, 0);
3843         SEEN(rv, cname);                /* Will return if rv is null */
3844         sv = retrieve(cxt, 0);  /* Retrieve <object> */
3845         if (!sv)
3846                 return (SV *) 0;        /* Failed */
3847
3848         /*
3849          * WARNING: breaks RV encapsulation.
3850          *
3851          * Now for the tricky part. We have to upgrade our existing SV, so that
3852          * it is now an RV on sv... Again, we cheat by duplicating the code
3853          * held in newSVrv(), since we already got our SV from retrieve().
3854          *
3855          * We don't say:
3856          *
3857          *              SvRV(rv) = SvREFCNT_inc(sv);
3858          *
3859          * here because the reference count we got from retrieve() above is
3860          * already correct: if the object was retrieved from the file, then
3861          * its reference count is one. Otherwise, if it was retrieved via
3862          * an SX_OBJECT indication, a ref count increment was done.
3863          */
3864
3865         sv_upgrade(rv, SVt_RV);
3866         SvRV(rv) = sv;                          /* $rv = \$sv */
3867         SvROK_on(rv);
3868
3869         TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv)));
3870
3871         return rv;
3872 }
3873
3874 /*
3875  * retrieve_overloaded
3876  *
3877  * Retrieve reference to some other scalar with overloading.
3878  * Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read.
3879  */
3880 static SV *retrieve_overloaded(stcxt_t *cxt, char *cname)
3881 {
3882         SV *rv;
3883         SV *sv;
3884         HV *stash;
3885
3886         TRACEME(("retrieve_overloaded (#%d)", cxt->tagnum));
3887
3888         /*
3889          * Same code as retrieve_ref(), duplicated to avoid extra call.
3890          */
3891
3892         rv = NEWSV(10002, 0);
3893         SEEN(rv, cname);                /* Will return if rv is null */
3894         sv = retrieve(cxt, 0);  /* Retrieve <object> */
3895         if (!sv)
3896                 return (SV *) 0;        /* Failed */
3897
3898         /*
3899          * WARNING: breaks RV encapsulation.
3900          */
3901
3902         sv_upgrade(rv, SVt_RV);
3903         SvRV(rv) = sv;                          /* $rv = \$sv */
3904         SvROK_on(rv);
3905
3906         /*
3907          * Restore overloading magic.
3908          */
3909
3910         stash = (HV *) SvSTASH (sv);
3911         if (!stash || !Gv_AMG(stash))
3912                 CROAK(("Cannot restore overloading on %s(0x%"UVxf") (package %s)",
3913                        sv_reftype(sv, FALSE),
3914                        PTR2UV(sv),
3915                            stash ? HvNAME(stash) : "<unknown>"));
3916
3917         SvAMAGIC_on(rv);
3918
3919         TRACEME(("ok (retrieve_overloaded at 0x%"UVxf")", PTR2UV(rv)));
3920
3921         return rv;
3922 }
3923
3924 /*
3925  * retrieve_tied_array
3926  *
3927  * Retrieve tied array
3928  * Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
3929  */
3930 static SV *retrieve_tied_array(stcxt_t *cxt, char *cname)
3931 {
3932         SV *tv;
3933         SV *sv;
3934
3935         TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum));
3936
3937         tv = NEWSV(10002, 0);
3938         SEEN(tv, cname);                        /* Will return if tv is null */
3939         sv = retrieve(cxt, 0);          /* Retrieve <object> */
3940         if (!sv)
3941                 return (SV *) 0;                /* Failed */
3942
3943         sv_upgrade(tv, SVt_PVAV);
3944         AvREAL_off((AV *)tv);
3945         sv_magic(tv, sv, 'P', Nullch, 0);
3946         SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
3947
3948         TRACEME(("ok (retrieve_tied_array at 0x%"UVxf")", PTR2UV(tv)));
3949
3950         return tv;
3951 }
3952
3953 /*
3954  * retrieve_tied_hash
3955  *
3956  * Retrieve tied hash
3957  * Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read.
3958  */
3959 static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname)
3960 {
3961         SV *tv;
3962         SV *sv;
3963
3964         TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum));
3965
3966         tv = NEWSV(10002, 0);
3967         SEEN(tv, cname);                        /* Will return if tv is null */
3968         sv = retrieve(cxt, 0);          /* Retrieve <object> */
3969         if (!sv)
3970                 return (SV *) 0;                /* Failed */
3971
3972         sv_upgrade(tv, SVt_PVHV);
3973         sv_magic(tv, sv, 'P', Nullch, 0);
3974         SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
3975
3976         TRACEME(("ok (retrieve_tied_hash at 0x%"UVxf")", PTR2UV(tv)));
3977
3978         return tv;
3979 }
3980
3981 /*
3982  * retrieve_tied_scalar
3983  *
3984  * Retrieve tied scalar
3985  * Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read.
3986  */
3987 static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname)
3988 {
3989         SV *tv;
3990         SV *sv;
3991
3992         TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum));
3993
3994         tv = NEWSV(10002, 0);
3995         SEEN(tv, cname);                        /* Will return if rv is null */
3996         sv = retrieve(cxt, 0);          /* Retrieve <object> */
3997         if (!sv)
3998                 return (SV *) 0;                /* Failed */
3999
4000         sv_upgrade(tv, SVt_PVMG);
4001         sv_magic(tv, sv, 'q', Nullch, 0);
4002         SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
4003
4004         TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv)));
4005
4006         return tv;
4007 }
4008
4009 /*
4010  * retrieve_tied_key
4011  *
4012  * Retrieve reference to value in a tied hash.
4013  * Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read.
4014  */
4015 static SV *retrieve_tied_key(stcxt_t *cxt, char *cname)
4016 {
4017         SV *tv;
4018         SV *sv;
4019         SV *key;
4020
4021         TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum));
4022
4023         tv = NEWSV(10002, 0);
4024         SEEN(tv, cname);                        /* Will return if tv is null */
4025         sv = retrieve(cxt, 0);          /* Retrieve <object> */
4026         if (!sv)
4027                 return (SV *) 0;                /* Failed */
4028
4029         key = retrieve(cxt, 0);         /* Retrieve <key> */
4030         if (!key)
4031                 return (SV *) 0;                /* Failed */
4032
4033         sv_upgrade(tv, SVt_PVMG);
4034         sv_magic(tv, sv, 'p', (char *)key, HEf_SVKEY);
4035         SvREFCNT_dec(key);                      /* Undo refcnt inc from sv_magic() */
4036         SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
4037
4038         return tv;
4039 }
4040
4041 /*
4042  * retrieve_tied_idx
4043  *
4044  * Retrieve reference to value in a tied array.
4045  * Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read.
4046  */
4047 static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname)
4048 {
4049         SV *tv;
4050         SV *sv;
4051         I32 idx;
4052
4053         TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum));
4054
4055         tv = NEWSV(10002, 0);
4056         SEEN(tv, cname);                        /* Will return if tv is null */
4057         sv = retrieve(cxt, 0);          /* Retrieve <object> */
4058         if (!sv)
4059                 return (SV *) 0;                /* Failed */
4060
4061         RLEN(idx);                                      /* Retrieve <idx> */
4062
4063         sv_upgrade(tv, SVt_PVMG);
4064         sv_magic(tv, sv, 'p', Nullch, idx);
4065         SvREFCNT_dec(sv);                       /* Undo refcnt inc from sv_magic() */
4066
4067         return tv;
4068 }
4069
4070
4071 /*
4072  * retrieve_lscalar
4073  *
4074  * Retrieve defined long (string) scalar.
4075  *
4076  * Layout is SX_LSCALAR <length> <data>, with SX_LSCALAR already read.
4077  * The scalar is "long" in that <length> is larger than LG_SCALAR so it
4078  * was not stored on a single byte.
4079  */
4080 static SV *retrieve_lscalar(stcxt_t *cxt, char *cname)
4081 {
4082         I32 len;
4083         SV *sv;
4084
4085         RLEN(len);
4086         TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, len));
4087
4088         /*
4089          * Allocate an empty scalar of the suitable length.
4090          */
4091
4092         sv = NEWSV(10002, len);
4093         SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
4094
4095         /*
4096          * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
4097          *
4098          * Now, for efficiency reasons, read data directly inside the SV buffer,
4099          * and perform the SV final settings directly by duplicating the final
4100          * work done by sv_setpv. Since we're going to allocate lots of scalars
4101          * this way, it's worth the hassle and risk.
4102          */
4103
4104         SAFEREAD(SvPVX(sv), len, sv);
4105         SvCUR_set(sv, len);                             /* Record C string length */
4106         *SvEND(sv) = '\0';                              /* Ensure it's null terminated anyway */
4107         (void) SvPOK_only(sv);                  /* Validate string pointer */
4108         if (cxt->s_tainted)                             /* Is input source tainted? */
4109                 SvTAINT(sv);                            /* External data cannot be trusted */
4110
4111         TRACEME(("large scalar len %"IVdf" '%s'", len, SvPVX(sv)));
4112         TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv)));
4113
4114         return sv;
4115 }
4116
4117 /*
4118  * retrieve_scalar
4119  *
4120  * Retrieve defined short (string) scalar.
4121  *
4122  * Layout is SX_SCALAR <length> <data>, with SX_SCALAR already read.
4123  * The scalar is "short" so <length> is single byte. If it is 0, there
4124  * is no <data> section.
4125  */
4126 static SV *retrieve_scalar(stcxt_t *cxt, char *cname)
4127 {
4128         int len;
4129         SV *sv;
4130
4131         GETMARK(len);
4132         TRACEME(("retrieve_scalar (#%d), len = %d", cxt->tagnum, len));
4133
4134         /*
4135          * Allocate an empty scalar of the suitable length.
4136          */
4137
4138         sv = NEWSV(10002, len);
4139         SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
4140
4141         /*
4142          * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
4143          */
4144
4145         if (len == 0) {
4146                 /*
4147                  * newSV did not upgrade to SVt_PV so the scalar is undefined.
4148                  * To make it defined with an empty length, upgrade it now...
4149                  * Don't upgrade to a PV if the original type contains more
4150                  * information than a scalar.
4151                  */
4152                 if (SvTYPE(sv) <= SVt_PV) {
4153                         sv_upgrade(sv, SVt_PV);
4154                 }
4155                 SvGROW(sv, 1);
4156                 *SvEND(sv) = '\0';                      /* Ensure it's null terminated anyway */
4157                 TRACEME(("ok (retrieve_scalar empty at 0x%"UVxf")", PTR2UV(sv)));
4158         } else {
4159                 /*
4160                  * Now, for efficiency reasons, read data directly inside the SV buffer,
4161                  * and perform the SV final settings directly by duplicating the final
4162                  * work done by sv_setpv. Since we're going to allocate lots of scalars
4163                  * this way, it's worth the hassle and risk.
4164                  */
4165                 SAFEREAD(SvPVX(sv), len, sv);
4166                 SvCUR_set(sv, len);                     /* Record C string length */
4167                 *SvEND(sv) = '\0';                      /* Ensure it's null terminated anyway */
4168                 TRACEME(("small scalar len %d '%s'", len, SvPVX(sv)));
4169         }
4170
4171         (void) SvPOK_only(sv);                  /* Validate string pointer */
4172         if (cxt->s_tainted)                             /* Is input source tainted? */
4173                 SvTAINT(sv);                            /* External data cannot be trusted */
4174
4175         TRACEME(("ok (retrieve_scalar at 0x%"UVxf")", PTR2UV(sv)));
4176         return sv;
4177 }
4178
4179 /*
4180  * retrieve_utf8str
4181  *
4182  * Like retrieve_scalar(), but tag result as utf8.
4183  * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
4184  */
4185 static SV *retrieve_utf8str(stcxt_t *cxt, char *cname)
4186 {
4187     SV *sv;
4188
4189     TRACEME(("retrieve_utf8str"));
4190
4191     sv = retrieve_scalar(cxt, cname);
4192     if (sv) {
4193 #ifdef HAS_UTF8_SCALARS
4194         SvUTF8_on(sv);
4195 #else
4196         if (cxt->use_bytes < 0)
4197             cxt->use_bytes
4198                 = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
4199                    ? 1 : 0);
4200         if (cxt->use_bytes == 0)
4201             UTF8_CROAK();
4202 #endif
4203     }
4204
4205     return sv;
4206 }
4207
4208 /*
4209  * retrieve_lutf8str
4210  *
4211  * Like retrieve_lscalar(), but tag result as utf8.
4212  * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
4213  */
4214 static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname)
4215 {
4216     SV *sv;
4217
4218     TRACEME(("retrieve_lutf8str"));
4219
4220     sv = retrieve_lscalar(cxt, cname);
4221     if (sv) {
4222 #ifdef HAS_UTF8_SCALARS
4223         SvUTF8_on(sv);
4224 #else
4225         if (cxt->use_bytes < 0)
4226             cxt->use_bytes
4227                 = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
4228                    ? 1 : 0);
4229         if (cxt->use_bytes == 0)
4230             UTF8_CROAK();
4231 #endif
4232     }
4233     return sv;
4234 }
4235
4236 /*
4237  * retrieve_integer
4238  *
4239  * Retrieve defined integer.
4240  * Layout is SX_INTEGER <data>, whith SX_INTEGER already read.
4241  */
4242 static SV *retrieve_integer(stcxt_t *cxt, char *cname)
4243 {
4244         SV *sv;
4245         IV iv;
4246
4247         TRACEME(("retrieve_integer (#%d)", cxt->tagnum));
4248
4249         READ(&iv, sizeof(iv));
4250         sv = newSViv(iv);
4251         SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
4252
4253         TRACEME(("integer %"IVdf, iv));
4254         TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv)));
4255
4256         return sv;
4257 }
4258
4259 /*
4260  * retrieve_netint
4261  *
4262  * Retrieve defined integer in network order.
4263  * Layout is SX_NETINT <data>, whith SX_NETINT already read.
4264  */
4265 static SV *retrieve_netint(stcxt_t *cxt, char *cname)
4266 {
4267         SV *sv;
4268         I32 iv;
4269
4270         TRACEME(("retrieve_netint (#%d)", cxt->tagnum));
4271
4272         READ_I32(iv);
4273 #ifdef HAS_NTOHL
4274         sv = newSViv((int) ntohl(iv));
4275         TRACEME(("network integer %d", (int) ntohl(iv)));
4276 #else
4277         sv = newSViv(iv);
4278         TRACEME(("network integer (as-is) %d", iv));
4279 #endif
4280         SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
4281
4282         TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv)));
4283
4284         return sv;
4285 }
4286
4287 /*
4288  * retrieve_double
4289  *
4290  * Retrieve defined double.
4291  * Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read.
4292  */
4293 static SV *retrieve_double(stcxt_t *cxt, char *cname)
4294 {
4295         SV *sv;
4296         NV nv;
4297
4298         TRACEME(("retrieve_double (#%d)", cxt->tagnum));
4299
4300         READ(&nv, sizeof(nv));
4301         sv = newSVnv(nv);
4302         SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
4303
4304         TRACEME(("double %"NVff, nv));
4305         TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv)));
4306
4307         return sv;
4308 }
4309
4310 /*
4311  * retrieve_byte
4312  *
4313  * Retrieve defined byte (small integer within the [-128, +127] range).
4314  * Layout is SX_BYTE <data>, whith SX_BYTE already read.
4315  */
4316 static SV *retrieve_byte(stcxt_t *cxt, char *cname)
4317 {
4318         SV *sv;
4319         int siv;
4320         signed char tmp;        /* Workaround for AIX cc bug --H.Merijn Brand */
4321
4322         TRACEME(("retrieve_byte (#%d)", cxt->tagnum));
4323
4324         GETMARK(siv);
4325         TRACEME(("small integer read as %d", (unsigned char) siv));
4326         tmp = (unsigned char) siv - 128;
4327         sv = newSViv(tmp);
4328         SEEN(sv, cname);        /* Associate this new scalar with tag "tagnum" */
4329
4330         TRACEME(("byte %d", tmp));
4331         TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv)));
4332
4333         return sv;
4334 }
4335
4336 /*
4337  * retrieve_undef
4338  *
4339  * Return the undefined value.
4340  */
4341 static SV *retrieve_undef(stcxt_t *cxt, char *cname)
4342 {
4343         SV* sv;
4344
4345         TRACEME(("retrieve_undef"));
4346
4347         sv = newSV(0);
4348         SEEN(sv, cname);
4349
4350         return sv;
4351 }
4352
4353 /*
4354  * retrieve_sv_undef
4355  *
4356  * Return the immortal undefined value.
4357  */
4358 static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname)
4359 {
4360         SV *sv = &PL_sv_undef;
4361
4362         TRACEME(("retrieve_sv_undef"));
4363
4364         SEEN(sv, cname);
4365         return sv;
4366 }
4367
4368 /*
4369  * retrieve_sv_yes
4370  *
4371  * Return the immortal yes value.
4372  */
4373 static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname)
4374 {
4375         SV *sv = &PL_sv_yes;
4376
4377         TRACEME(("retrieve_sv_yes"));
4378
4379         SEEN(sv, cname);
4380         return sv;
4381 }
4382
4383 /*
4384  * retrieve_sv_no
4385  *
4386  * Return the immortal no value.
4387  */
4388 static SV *retrieve_sv_no(stcxt_t *cxt, char *cname)
4389 {
4390         SV *sv = &PL_sv_no;
4391
4392         TRACEME(("retrieve_sv_no"));
4393
4394         SEEN(sv, cname);
4395         return sv;
4396 }
4397
4398 /*
4399  * retrieve_array
4400  *
4401  * Retrieve a whole array.
4402  * Layout is SX_ARRAY <size> followed by each item, in increading index order.
4403  * Each item is stored as <object>.
4404  *
4405  * When we come here, SX_ARRAY has been read already.
4406  */
4407 static SV *retrieve_array(stcxt_t *cxt, char *cname)
4408 {
4409         I32 len;
4410         I32 i;
4411         AV *av;
4412         SV *sv;
4413
4414         TRACEME(("retrieve_array (#%d)", cxt->tagnum));
4415
4416         /*
4417          * Read length, and allocate array, then pre-extend it.
4418          */
4419
4420         RLEN(len);
4421         TRACEME(("size = %d", len));
4422         av = newAV();
4423         SEEN(av, cname);                        /* Will return if array not allocated nicely */
4424         if (len)
4425                 av_extend(av, len);
4426         else
4427                 return (SV *) av;               /* No data follow if array is empty */
4428
4429         /*
4430          * Now get each item in turn...
4431          */
4432
4433         for (i = 0; i < len; i++) {
4434                 TRACEME(("(#%d) item", i));
4435                 sv = retrieve(cxt, 0);                  /* Retrieve item */
4436                 if (!sv)
4437                         return (SV *) 0;
4438                 if (av_store(av, i, sv) == 0)
4439                         return (SV *) 0;
4440         }
4441
4442         TRACEME(("ok (retrieve_array at 0x%"UVxf")", PTR2UV(av)));
4443
4444         return (SV *) av;
4445 }
4446
4447 /*
4448  * retrieve_hash
4449  *
4450  * Retrieve a whole hash table.
4451  * Layout is SX_HASH <size> followed by each key/value pair, in random order.
4452  * Keys are stored as <length> <data>, the <data> section being omitted
4453  * if length is 0.
4454  * Values are stored as <object>.
4455  *
4456  * When we come here, SX_HASH has been read already.
4457  */
4458 static SV *retrieve_hash(stcxt_t *cxt, char *cname)
4459 {
4460         I32 len;
4461         I32 size;
4462         I32 i;
4463         HV *hv;
4464         SV *sv;
4465
4466         TRACEME(("retrieve_hash (#%d)", cxt->tagnum));
4467
4468         /*
4469          * Read length, allocate table.
4470          */
4471
4472         RLEN(len);
4473         TRACEME(("size = %d", len));
4474         hv = newHV();
4475         SEEN(hv, cname);                /* Will return if table not allocated properly */
4476         if (len == 0)
4477                 return (SV *) hv;       /* No data follow if table empty */
4478         hv_ksplit(hv, len);             /* pre-extend hash to save multiple splits */
4479
4480         /*
4481          * Now get each key/value pair in turn...
4482          */
4483
4484         for (i = 0; i < len; i++) {
4485                 /*
4486                  * Get value first.
4487                  */
4488
4489                 TRACEME(("(#%d) value", i));
4490                 sv = retrieve(cxt, 0);
4491                 if (!sv)
4492                         return (SV *) 0;
4493
4494                 /*
4495                  * Get key.
4496                  * Since we're reading into kbuf, we must ensure we're not
4497                  * recursing between the read and the hv_store() where it's used.
4498                  * Hence the key comes after the value.
4499                  */
4500
4501                 RLEN(size);                                             /* Get key size */
4502                 KBUFCHK((STRLEN)size);                                  /* Grow hash key read pool if needed */
4503                 if (size)
4504                         READ(kbuf, size);
4505                 kbuf[size] = '\0';                              /* Mark string end, just in case */
4506                 TRACEME(("(#%d) key '%s'", i, kbuf));
4507
4508                 /*
4509                  * Enter key/value pair into hash table.
4510                  */
4511
4512                 if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0)
4513                         return (SV *) 0;
4514         }
4515
4516         TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv)));
4517
4518         return (SV *) hv;
4519 }
4520
4521 /*
4522  * retrieve_hash
4523  *
4524  * Retrieve a whole hash table.
4525  * Layout is SX_HASH <size> followed by each key/value pair, in random order.
4526  * Keys are stored as <length> <data>, the <data> section being omitted
4527  * if length is 0.
4528  * Values are stored as <object>.
4529  *
4530  * When we come here, SX_HASH has been read already.
4531  */
4532 static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname)
4533 {
4534     I32 len;
4535     I32 size;
4536     I32 i;
4537     HV *hv;
4538     SV *sv;
4539     int hash_flags;
4540
4541     GETMARK(hash_flags);
4542     TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum));
4543     /*
4544      * Read length, allocate table.
4545      */
4546
4547 #ifndef HAS_RESTRICTED_HASHES
4548     if (hash_flags & SHV_RESTRICTED) {
4549         if (cxt->derestrict < 0)
4550             cxt->derestrict
4551                 = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", TRUE))
4552                    ? 1 : 0);
4553         if (cxt->derestrict == 0)
4554             RESTRICTED_HASH_CROAK();
4555     }
4556 #endif
4557
4558     RLEN(len);
4559     TRACEME(("size = %d, flags = %d", len, hash_flags));
4560     hv = newHV();
4561     SEEN(hv, cname);            /* Will return if table not allocated properly */
4562     if (len == 0)
4563         return (SV *) hv;       /* No data follow if table empty */
4564     hv_ksplit(hv, len);         /* pre-extend hash to save multiple splits */
4565
4566     /*
4567      * Now get each key/value pair in turn...
4568      */
4569
4570     for (i = 0; i < len; i++) {
4571         int flags;
4572         int store_flags = 0;
4573         /*
4574          * Get value first.
4575          */
4576
4577         TRACEME(("(#%d) value", i));
4578         sv = retrieve(cxt, 0);
4579         if (!sv)
4580             return (SV *) 0;
4581
4582         GETMARK(flags);
4583 #ifdef HAS_RESTRICTED_HASHES
4584         if ((hash_flags & SHV_RESTRICTED) && (flags & SHV_K_LOCKED))
4585             SvREADONLY_on(sv);
4586 #endif
4587
4588         if (flags & SHV_K_ISSV) {
4589             /* XXX you can't set a placeholder with an SV key.
4590                Then again, you can't get an SV key.
4591                Without messing around beyond what the API is supposed to do.
4592             */
4593             SV *keysv;
4594             TRACEME(("(#%d) keysv, flags=%d", i, flags));
4595             keysv = retrieve(cxt, 0);
4596             if (!keysv)
4597                 return (SV *) 0;
4598
4599             if (!hv_store_ent(hv, keysv, sv, 0))
4600                 return (SV *) 0;
4601         } else {
4602             /*
4603              * Get key.
4604              * Since we're reading into kbuf, we must ensure we're not
4605              * recursing between the read and the hv_store() where it's used.
4606              * Hence the key comes after the value.
4607              */
4608
4609             if (flags & SHV_K_PLACEHOLDER) {
4610                 SvREFCNT_dec (sv);
4611                 sv = &PL_sv_undef;
4612                 store_flags |= HVhek_PLACEHOLD;
4613             }
4614             if (flags & SHV_K_UTF8) {
4615 #ifdef HAS_UTF8_HASHES
4616                 store_flags |= HVhek_UTF8;
4617 #else
4618                 if (cxt->use_bytes < 0)
4619                     cxt->use_bytes
4620                         = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
4621                            ? 1 : 0);
4622                 if (cxt->use_bytes == 0)
4623                     UTF8_CROAK();
4624 #endif
4625             }
4626 #ifdef HAS_UTF8_HASHES
4627             if (flags & SHV_K_WASUTF8)
4628                 store_flags |= HVhek_WASUTF8;
4629 #endif
4630
4631             RLEN(size);                                         /* Get key size */
4632             KBUFCHK((STRLEN)size);                              /* Grow hash key read pool if needed */
4633             if (size)
4634                 READ(kbuf, size);
4635             kbuf[size] = '\0';                          /* Mark string end, just in case */
4636             TRACEME(("(#%d) key '%s' flags %X store_flags %X", i, kbuf,
4637                      flags, store_flags));
4638
4639             /*
4640              * Enter key/value pair into hash table.
4641              */
4642
4643 #ifdef HAS_RESTRICTED_HASHES
4644             if (hv_store_flags(hv, kbuf, size, sv, 0, flags) == 0)
4645                 return (SV *) 0;
4646 #else
4647             if (!(store_flags & HVhek_PLACEHOLD))
4648                 if (hv_store(hv, kbuf, size, sv, 0) == 0)
4649                     return (SV *) 0;
4650 #endif
4651         }
4652     }
4653 #ifdef HAS_RESTRICTED_HASHES
4654     if (hash_flags & SHV_RESTRICTED)
4655         SvREADONLY_on(hv);
4656 #endif
4657
4658     TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv)));
4659
4660     return (SV *) hv;
4661 }
4662
4663 /*
4664  * old_retrieve_array
4665  *
4666  * Retrieve a whole array in pre-0.6 binary format.
4667  *
4668  * Layout is SX_ARRAY <size> followed by each item, in increading index order.
4669  * Each item is stored as SX_ITEM <object> or SX_IT_UNDEF for "holes".
4670  *
4671  * When we come here, SX_ARRAY has been read already.
4672  */
4673 static SV *old_retrieve_array(stcxt_t *cxt, char *cname)
4674 {
4675         I32 len;
4676         I32 i;
4677         AV *av;
4678         SV *sv;
4679         int c;
4680
4681         TRACEME(("old_retrieve_array (#%d)", cxt->tagnum));
4682
4683         /*
4684          * Read length, and allocate array, then pre-extend it.
4685          */
4686
4687         RLEN(len);
4688         TRACEME(("size = %d", len));
4689         av = newAV();
4690         SEEN(av, 0);                            /* Will return if array not allocated nicely */
4691         if (len)
4692                 av_extend(av, len);
4693         else
4694                 return (SV *) av;               /* No data follow if array is empty */
4695
4696         /*
4697          * Now get each item in turn...
4698          */
4699
4700         for (i = 0; i < len; i++) {
4701                 GETMARK(c);
4702                 if (c == SX_IT_UNDEF) {
4703                         TRACEME(("(#%d) undef item", i));
4704                         continue;                       /* av_extend() already filled us with undef */
4705                 }
4706                 if (c != SX_ITEM)
4707                         (void) retrieve_other((stcxt_t *) 0, 0);        /* Will croak out */
4708                 TRACEME(("(#%d) item", i));
4709                 sv = retrieve(cxt, 0);                                          /* Retrieve item */
4710                 if (!sv)
4711                         return (SV *) 0;
4712                 if (av_store(av, i, sv) == 0)
4713                         return (SV *) 0;
4714         }
4715
4716         TRACEME(("ok (old_retrieve_array at 0x%"UVxf")", PTR2UV(av)));
4717
4718         return (SV *) av;
4719 }
4720
4721 /*
4722  * old_retrieve_hash
4723  *
4724  * Retrieve a whole hash table in pre-0.6 binary format.
4725  *
4726  * Layout is SX_HASH <size> followed by each key/value pair, in random order.
4727  * Keys are stored as SX_KEY <length> <data>, the <data> section being omitted
4728  * if length is 0.
4729  * Values are stored as SX_VALUE <object> or SX_VL_UNDEF for "holes".
4730  *
4731  * When we come here, SX_HASH has been read already.
4732  */
4733 static SV *old_retrieve_hash(stcxt_t *cxt, char *cname)
4734 {
4735         I32 len;
4736         I32 size;
4737         I32 i;
4738         HV *hv;
4739         SV *sv = (SV *) 0;
4740         int c;
4741         static SV *sv_h_undef = (SV *) 0;               /* hv_store() bug */
4742
4743         TRACEME(("old_retrieve_hash (#%d)", cxt->tagnum));
4744
4745         /*
4746          * Read length, allocate table.
4747          */
4748
4749         RLEN(len);
4750         TRACEME(("size = %d", len));
4751         hv = newHV();
4752         SEEN(hv, 0);                    /* Will return if table not allocated properly */
4753         if (len == 0)
4754                 return (SV *) hv;       /* No data follow if table empty */
4755         hv_ksplit(hv, len);             /* pre-extend hash to save multiple splits */
4756
4757         /*
4758          * Now get each key/value pair in turn...
4759          */
4760
4761         for (i = 0; i < len; i++) {
4762                 /*
4763                  * Get value first.
4764                  */
4765
4766                 GETMARK(c);
4767                 if (c == SX_VL_UNDEF) {
4768                         TRACEME(("(#%d) undef value", i));
4769                         /*
4770                          * Due to a bug in hv_store(), it's not possible to pass
4771                          * &PL_sv_undef to hv_store() as a value, otherwise the
4772                          * associated key will not be creatable any more. -- RAM, 14/01/97
4773                          */
4774                         if (!sv_h_undef)
4775                                 sv_h_undef = newSVsv(&PL_sv_undef);
4776                         sv = SvREFCNT_inc(sv_h_undef);
4777                 } else if (c == SX_VALUE) {
4778                         TRACEME(("(#%d) value", i));
4779                         sv = retrieve(cxt, 0);
4780                         if (!sv)
4781                                 return (SV *) 0;
4782                 } else
4783                         (void) retrieve_other((stcxt_t *) 0, 0);        /* Will croak out */
4784
4785                 /*
4786                  * Get key.
4787                  * Since we're reading into kbuf, we must ensure we're not
4788                  * recursing between the read and the hv_store() where it's used.
4789                  * Hence the key comes after the value.
4790                  */
4791
4792                 GETMARK(c);
4793                 if (c != SX_KEY)
4794                         (void) retrieve_other((stcxt_t *) 0, 0);        /* Will croak out */
4795                 RLEN(size);                                             /* Get key size */
4796                 KBUFCHK((STRLEN)size);                                  /* Grow hash key read pool if needed */
4797                 if (size)
4798                         READ(kbuf, size);
4799                 kbuf[size] = '\0';                              /* Mark string end, just in case */
4800                 TRACEME(("(#%d) key '%s'", i, kbuf));
4801
4802                 /*
4803                  * Enter key/value pair into hash table.
4804                  */
4805
4806                 if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0)
4807                         return (SV *) 0;
4808         }
4809
4810         TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv)));
4811
4812         return (SV *) hv;
4813 }
4814
4815 /***
4816  *** Retrieval engine.
4817  ***/
4818
4819 /*
4820  * magic_check
4821  *
4822  * Make sure the stored data we're trying to retrieve has been produced
4823  * on an ILP compatible system with the same byteorder. It croaks out in
4824  * case an error is detected. [ILP = integer-long-pointer sizes]
4825  * Returns null if error is detected, &PL_sv_undef otherwise.
4826  *
4827  * Note that there's no byte ordering info emitted when network order was
4828  * used at store time.
4829  */
4830 static SV *magic_check(stcxt_t *cxt)
4831 {
4832         char buf[256];
4833         char byteorder[256];
4834         int c;
4835         int use_network_order;
4836         int version_major;
4837         int version_minor = 0;
4838
4839         TRACEME(("magic_check"));
4840
4841         /*
4842          * The "magic number" is only for files, not when freezing in memory.
4843          */
4844
4845         if (cxt->fio) {
4846                 STRLEN len = sizeof(magicstr) - 1;
4847                 STRLEN old_len;
4848
4849                 READ(buf, (SSize_t)len);                        /* Not null-terminated */
4850                 buf[len] = '\0';                                /* Is now */
4851
4852                 if (0 == strcmp(buf, magicstr))
4853                         goto magic_ok;
4854
4855                 /*
4856                  * Try to read more bytes to check for the old magic number, which
4857                  * was longer.
4858                  */
4859
4860                 old_len = sizeof(old_magicstr) - 1;
4861                 READ(&buf[len], (SSize_t)(old_len - len));
4862                 buf[old_len] = '\0';                    /* Is now null-terminated */
4863
4864                 if (strcmp(buf, old_magicstr))
4865                         CROAK(("File is not a perl storable"));
4866         }
4867
4868 magic_ok:
4869         /*
4870          * Starting with 0.6, the "use_network_order" byte flag is also used to
4871          * indicate the version number of the binary, and therefore governs the
4872          * setting of sv_retrieve_vtbl. See magic_write().
4873          */
4874
4875         GETMARK(use_network_order);
4876         version_major = use_network_order >> 1;
4877         cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve;
4878
4879         TRACEME(("magic_check: netorder = 0x%x", use_network_order));
4880
4881
4882         /*
4883          * Starting with 0.7 (binary major 2), a full byte is dedicated to the
4884          * minor version of the protocol.  See magic_write().
4885          */
4886
4887         if (version_major > 1)
4888                 GETMARK(version_minor);
4889
4890         cxt->ver_major = version_major;
4891         cxt->ver_minor = version_minor;
4892
4893         TRACEME(("binary image version is %d.%d", version_major, version_minor));
4894
4895         /*
4896          * Inter-operability sanity check: we can't retrieve something stored
4897          * using a format more recent than ours, because we have no way to
4898          * know what has changed, and letting retrieval go would mean a probable
4899          * failure reporting a "corrupted" storable file.
4900          */
4901
4902         if (
4903                 version_major > STORABLE_BIN_MAJOR ||
4904                         (version_major == STORABLE_BIN_MAJOR &&
4905                         version_minor > STORABLE_BIN_MINOR)
4906             ) {
4907             int croak_now = 1;
4908             TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR,
4909                      STORABLE_BIN_MINOR));
4910
4911             if (version_major == STORABLE_BIN_MAJOR) {
4912                 TRACEME(("cxt->accept_future_minor is %d",
4913                          cxt->accept_future_minor));
4914                 if (cxt->accept_future_minor < 0)
4915                     cxt->accept_future_minor
4916                         = (SvTRUE(perl_get_sv("Storable::accept_future_minor",
4917                                               TRUE))
4918                            ? 1 : 0);
4919                 if (cxt->accept_future_minor == 1)
4920                     croak_now = 0;  /* Don't croak yet.  */
4921             }
4922             if (croak_now) {
4923                 CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)",
4924                        version_major, version_minor,
4925                        STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
4926             }
4927         }
4928
4929         /*
4930          * If they stored using network order, there's no byte ordering
4931          * information to check.
4932          */
4933
4934         if ((cxt->netorder = (use_network_order & 0x1)))        /* Extra () for -Wall */
4935                 return &PL_sv_undef;                    /* No byte ordering info */
4936
4937         sprintf(byteorder, "%lx", (unsigned long) BYTEORDER);
4938         GETMARK(c);
4939         READ(buf, c);                                           /* Not null-terminated */
4940         buf[c] = '\0';                                          /* Is now */
4941
4942         TRACEME(("byte order '%s'", buf));
4943
4944         if (strcmp(buf, byteorder))
4945                 CROAK(("Byte order is not compatible"));
4946
4947         GETMARK(c);             /* sizeof(int) */
4948         if ((int) c != sizeof(int))
4949                 CROAK(("Integer size is not compatible"));
4950
4951         GETMARK(c);             /* sizeof(long) */
4952         if ((int) c != sizeof(long))
4953                 CROAK(("Long integer size is not compatible"));
4954
4955         GETMARK(c);             /* sizeof(char *) */
4956         if ((int) c != sizeof(char *))
4957                 CROAK(("Pointer integer size is not compatible"));
4958
4959         if (version_major >= 2 && version_minor >= 2) {
4960                 GETMARK(c);             /* sizeof(NV) */
4961                 if ((int) c != sizeof(NV))
4962                         CROAK(("Double size is not compatible"));
4963         }
4964
4965         return &PL_sv_undef;    /* OK */
4966 }
4967
4968 /*
4969  * retrieve
4970  *
4971  * Recursively retrieve objects from the specified file and return their
4972  * root SV (which may be an AV or an HV for what we care).
4973  * Returns null if there is a problem.
4974  */
4975 static SV *retrieve(stcxt_t *cxt, char *cname)
4976 {
4977         int type;
4978         SV **svh;
4979         SV *sv;
4980
4981         TRACEME(("retrieve"));
4982
4983         /*
4984          * Grab address tag which identifies the object if we are retrieving
4985          * an older format. Since the new binary format counts objects and no
4986          * longer explicitely tags them, we must keep track of the correspondance
4987          * ourselves.
4988          *
4989          * The following section will disappear one day when the old format is
4990          * no longer supported, hence the final "goto" in the "if" block.
4991          */
4992
4993         if (cxt->hseen) {                                               /* Retrieving old binary */
4994                 stag_t tag;
4995                 if (cxt->netorder) {
4996                         I32 nettag;
4997                         READ(&nettag, sizeof(I32));             /* Ordered sequence of I32 */
4998                         tag = (stag_t) nettag;
4999                 } else
5000                         READ(&tag, sizeof(stag_t));             /* Original address of the SV */
5001
5002                 GETMARK(type);
5003                 if (type == SX_OBJECT) {
5004                         I32 tagn;
5005                         svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
5006                         if (!svh)
5007                                 CROAK(("Old tag 0x%"UVxf" should have been mapped already",
5008                                         (UV) tag));
5009                         tagn = SvIV(*svh);      /* Mapped tag number computed earlier below */
5010
5011                         /*
5012                          * The following code is common with the SX_OBJECT case below.
5013                          */
5014
5015                         svh = av_fetch(cxt->aseen, tagn, FALSE);
5016                         if (!svh)
5017                                 CROAK(("Object #%"IVdf" should have been retrieved already",
5018                                         (IV) tagn));
5019                         sv = *svh;
5020                         TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv)));
5021                         SvREFCNT_inc(sv);       /* One more reference to this same sv */
5022                         return sv;                      /* The SV pointer where object was retrieved */
5023                 }
5024
5025                 /*
5026                  * Map new object, but don't increase tagnum. This will be done
5027                  * by each of the retrieve_* functions when they call SEEN().
5028                  *
5029                  * The mapping associates the "tag" initially present with a unique
5030                  * tag number. See test for SX_OBJECT above to see how this is perused.
5031                  */
5032
5033                 if (!hv_store(cxt->hseen, (char *) &tag, sizeof(tag),
5034                                 newSViv(cxt->tagnum), 0))
5035                         return (SV *) 0;
5036
5037                 goto first_time;
5038         }
5039
5040         /*
5041          * Regular post-0.6 binary format.
5042          */
5043
5044         GETMARK(type);
5045
5046         TRACEME(("retrieve type = %d", type));
5047
5048         /*
5049          * Are we dealing with an object we should have already retrieved?
5050          */
5051
5052         if (type == SX_OBJECT) {
5053                 I32 tag;
5054                 READ_I32(tag);
5055                 tag = ntohl(tag);
5056                 svh = av_fetch(cxt->aseen, tag, FALSE);
5057                 if (!svh)
5058                         CROAK(("Object #%"IVdf" should have been retrieved already",
5059                                 (IV) tag));
5060                 sv = *svh;
5061                 TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv)));
5062                 SvREFCNT_inc(sv);       /* One more reference to this same sv */
5063                 return sv;                      /* The SV pointer where object was retrieved */
5064         } else if (type >= SX_ERROR && cxt->ver_minor > STORABLE_BIN_MINOR) {
5065             if (cxt->accept_future_minor < 0)
5066                 cxt->accept_future_minor
5067                     = (SvTRUE(perl_get_sv("Storable::accept_future_minor",
5068                                           TRUE))
5069                        ? 1 : 0);
5070             if (cxt->accept_future_minor == 1) {
5071                 CROAK(("Storable binary image v%d.%d contains data of type %d. "
5072                        "This Storable is v%d.%d and can only handle data types up to %d",
5073                        cxt->ver_major, cxt->ver_minor, type,
5074                        STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_ERROR - 1));
5075             }
5076         }
5077
5078 first_time:             /* Will disappear when support for old format is dropped */
5079
5080         /*
5081          * Okay, first time through for this one.
5082          */
5083
5084         sv = RETRIEVE(cxt, type)(cxt, cname);
5085         if (!sv)
5086                 return (SV *) 0;                        /* Failed */
5087
5088         /*
5089          * Old binary formats (pre-0.7).
5090          *
5091          * Final notifications, ended by SX_STORED may now follow.
5092          * Currently, the only pertinent notification to apply on the
5093          * freshly retrieved object is either:
5094          *    SX_CLASS <char-len> <classname> for short classnames.
5095          *    SX_LG_CLASS <int-len> <classname> for larger one (rare!).
5096          * Class name is then read into the key buffer pool used by
5097          * hash table key retrieval.
5098          */
5099
5100         if (cxt->ver_major < 2) {
5101                 while ((type = GETCHAR()) != SX_STORED) {
5102                         I32 len;
5103                         switch (type) {
5104                         case SX_CLASS:
5105                                 GETMARK(len);                   /* Length coded on a single char */
5106                                 break;
5107                         case SX_LG_CLASS:                       /* Length coded on a regular integer */
5108                                 RLEN(len);
5109                                 break;
5110                         case EOF:
5111                         default:
5112                                 return (SV *) 0;                /* Failed */
5113                         }
5114                         KBUFCHK((STRLEN)len);                   /* Grow buffer as necessary */
5115                         if (len)
5116                                 READ(kbuf, len);
5117                         kbuf[len] = '\0';                       /* Mark string end */
5118                         BLESS(sv, kbuf);
5119                 }
5120         }
5121
5122         TRACEME(("ok (retrieved 0x%"UVxf", refcnt=%d, %s)", PTR2UV(sv),
5123                 SvREFCNT(sv) - 1, sv_reftype(sv, FALSE)));
5124
5125         return sv;      /* Ok */
5126 }
5127
5128 /*
5129  * do_retrieve
5130  *
5131  * Retrieve data held in file and return the root object.
5132  * Common routine for pretrieve and mretrieve.
5133  */
5134 static SV *do_retrieve(
5135         PerlIO *f,
5136         SV *in,
5137         int optype)
5138 {
5139         dSTCXT;
5140         SV *sv;
5141         int is_tainted;                         /* Is input source tainted? */
5142         int pre_06_fmt = 0;                     /* True with pre Storable 0.6 formats */
5143
5144         TRACEME(("do_retrieve (optype = 0x%x)", optype));
5145
5146         optype |= ST_RETRIEVE;
5147
5148         /*
5149          * Sanity assertions for retrieve dispatch tables.
5150          */
5151
5152         ASSERT(sizeof(sv_old_retrieve) == sizeof(sv_retrieve),
5153                 ("old and new retrieve dispatch table have same size"));
5154         ASSERT(sv_old_retrieve[SX_ERROR] == retrieve_other,
5155                 ("SX_ERROR entry correctly initialized in old dispatch table"));
5156         ASSERT(sv_retrieve[SX_ERROR] == retrieve_other,
5157                 ("SX_ERROR entry correctly initialized in new dispatch table"));
5158
5159         /*
5160          * Workaround for CROAK leak: if they enter with a "dirty" context,
5161          * free up memory for them now.
5162          */
5163
5164         if (cxt->s_dirty)
5165                 clean_context(cxt);
5166
5167         /*
5168          * Now that STORABLE_xxx hooks exist, it is possible that they try to
5169          * re-enter retrieve() via the hooks.
5170          */
5171
5172         if (cxt->entry)
5173                 cxt = allocate_context(cxt);
5174
5175         cxt->entry++;
5176
5177         ASSERT(cxt->entry == 1, ("starting new recursion"));
5178         ASSERT(!cxt->s_dirty, ("clean context"));
5179
5180         /*
5181          * Prepare context.
5182          *
5183          * Data is loaded into the memory buffer when f is NULL, unless `in' is
5184          * also NULL, in which case we're expecting the data to already lie
5185          * in the buffer (dclone case).
5186          */
5187
5188         KBUFINIT();                                     /* Allocate hash key reading pool once */
5189
5190         if (!f && in)
5191                 MBUF_SAVE_AND_LOAD(in);
5192
5193         /*
5194          * Magic number verifications.
5195          *
5196          * This needs to be done before calling init_retrieve_context()
5197          * since the format indication in the file are necessary to conduct
5198          * some of the initializations.
5199          */
5200
5201         cxt->fio = f;                           /* Where I/O are performed */
5202
5203         if (!magic_check(cxt))
5204                 CROAK(("Magic number checking on storable %s failed",
5205                         cxt->fio ? "file" : "string"));
5206
5207         TRACEME(("data stored in %s format",
5208                 cxt->netorder ? "net order" : "native"));
5209
5210         /*
5211          * Check whether input source is tainted, so that we don't wrongly
5212          * taint perfectly good values...
5213          *
5214          * We assume file input is always tainted.  If both `f' and `in' are
5215          * NULL, then we come from dclone, and tainted is already filled in
5216          * the context.  That's a kludge, but the whole dclone() thing is
5217          * already quite a kludge anyway! -- RAM, 15/09/2000.
5218          */
5219
5220         is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted);
5221         TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted"));
5222         init_retrieve_context(cxt, optype, is_tainted);
5223
5224         ASSERT(is_retrieving(), ("within retrieve operation"));
5225
5226         sv = retrieve(cxt, 0);          /* Recursively retrieve object, get root SV */
5227
5228         /*
5229          * Final cleanup.
5230          */
5231
5232         if (!f && in)
5233                 MBUF_RESTORE();
5234
5235         pre_06_fmt = cxt->hseen != NULL;        /* Before we clean context */
5236
5237         /*
5238          * The "root" context is never freed.
5239          */
5240
5241         clean_retrieve_context(cxt);
5242         if (cxt->prev)                          /* This context was stacked */
5243                 free_context(cxt);              /* It was not the "root" context */
5244
5245         /*
5246          * Prepare returned value.
5247          */
5248
5249         if (!sv) {
5250                 TRACEME(("retrieve ERROR"));
5251                 return &PL_sv_undef;            /* Something went wrong, return undef */
5252         }
5253
5254         TRACEME(("retrieve got %s(0x%"UVxf")",
5255                 sv_reftype(sv, FALSE), PTR2UV(sv)));
5256
5257         /*
5258          * Backward compatibility with Storable-0.5@9 (which we know we
5259          * are retrieving if hseen is non-null): don't create an extra RV
5260          * for objects since we special-cased it at store time.
5261          *
5262          * Build a reference to the SV returned by pretrieve even if it is
5263          * already one and not a scalar, for consistency reasons.
5264          */
5265
5266         if (pre_06_fmt) {                       /* Was not handling overloading by then */
5267                 SV *rv;
5268                 TRACEME(("fixing for old formats -- pre 0.6"));
5269                 if (sv_type(sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
5270                         TRACEME(("ended do_retrieve() with an object -- pre 0.6"));
5271                         return sv;
5272                 }
5273         }
5274
5275         /*
5276          * If reference is overloaded, restore behaviour.
5277          *
5278          * NB: minor glitch here: normally, overloaded refs are stored specially
5279          * so that we can croak when behaviour cannot be re-installed, and also
5280          * avoid testing for overloading magic at each reference retrieval.
5281          *
5282          * Unfortunately, the root reference is implicitely stored, so we must
5283          * check for possible overloading now.  Furthermore, if we don't restore
5284          * overloading, we cannot croak as if the original ref was, because we
5285          * have no way to determine whether it was an overloaded ref or not in
5286          * the first place.
5287          *
5288          * It's a pity that overloading magic is attached to the rv, and not to
5289          * the underlying sv as blessing is.
5290          */
5291
5292         if (SvOBJECT(sv)) {
5293                 HV *stash = (HV *) SvSTASH(sv);
5294                 SV *rv = newRV_noinc(sv);
5295                 if (stash && Gv_AMG(stash)) {
5296                         SvAMAGIC_on(rv);
5297                         TRACEME(("restored overloading on root reference"));
5298                 }
5299                 TRACEME(("ended do_retrieve() with an object"));
5300                 return rv;
5301         }
5302
5303         TRACEME(("regular do_retrieve() end"));
5304
5305         return newRV_noinc(sv);
5306 }
5307
5308 /*
5309  * pretrieve
5310  *
5311  * Retrieve data held in file and return the root object, undef on error.
5312  */
5313 SV *pretrieve(PerlIO *f)
5314 {
5315         TRACEME(("pretrieve"));
5316         return do_retrieve(f, Nullsv, 0);
5317 }
5318
5319 /*
5320  * mretrieve
5321  *
5322  * Retrieve data held in scalar and return the root object, undef on error.
5323  */
5324 SV *mretrieve(SV *sv)
5325 {
5326         TRACEME(("mretrieve"));
5327         return do_retrieve((PerlIO*) 0, sv, 0);
5328 }
5329
5330 /***
5331  *** Deep cloning
5332  ***/
5333
5334 /*
5335  * dclone
5336  *
5337  * Deep clone: returns a fresh copy of the original referenced SV tree.
5338  *
5339  * This is achieved by storing the object in memory and restoring from
5340  * there. Not that efficient, but it should be faster than doing it from
5341  * pure perl anyway.
5342  */
5343 SV *dclone(SV *sv)
5344 {
5345         dSTCXT;
5346         int size;
5347         stcxt_t *real_context;
5348         SV *out;
5349
5350         TRACEME(("dclone"));
5351
5352         /*
5353          * Workaround for CROAK leak: if they enter with a "dirty" context,
5354          * free up memory for them now.
5355          */
5356
5357         if (cxt->s_dirty)
5358                 clean_context(cxt);
5359
5360         /*
5361          * do_store() optimizes for dclone by not freeing its context, should
5362          * we need to allocate one because we're deep cloning from a hook.
5363          */
5364
5365         if (!do_store((PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0))
5366                 return &PL_sv_undef;                            /* Error during store */
5367
5368         /*
5369          * Because of the above optimization, we have to refresh the context,
5370          * since a new one could have been allocated and stacked by do_store().
5371          */
5372
5373         { dSTCXT; real_context = cxt; }         /* Sub-block needed for macro */
5374         cxt = real_context;                                     /* And we need this temporary... */
5375
5376         /*
5377          * Now, `cxt' may refer to a new context.
5378          */
5379
5380         ASSERT(!cxt->s_dirty, ("clean context"));
5381         ASSERT(!cxt->entry, ("entry will not cause new context allocation"));
5382
5383         size = MBUF_SIZE();
5384         TRACEME(("dclone stored %d bytes", size));
5385         MBUF_INIT(size);
5386
5387         /*
5388          * Since we're passing do_retrieve() both a NULL file and sv, we need
5389          * to pre-compute the taintedness of the input by setting cxt->tainted
5390          * to whatever state our own input string was.  -- RAM, 15/09/2000
5391          *
5392          * do_retrieve() will free non-root context.
5393          */
5394
5395         cxt->s_tainted = SvTAINTED(sv);
5396         out = do_retrieve((PerlIO*) 0, Nullsv, ST_CLONE);
5397
5398         TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out)));
5399
5400         return out;
5401 }
5402
5403 /***
5404  *** Glue with perl.
5405  ***/
5406
5407 /*
5408  * The Perl IO GV object distinguishes between input and output for sockets
5409  * but not for plain files. To allow Storable to transparently work on
5410  * plain files and sockets transparently, we have to ask xsubpp to fetch the
5411  * right object for us. Hence the OutputStream and InputStream declarations.
5412  *
5413  * Before perl 5.004_05, those entries in the standard typemap are not
5414  * defined in perl include files, so we do that here.
5415  */
5416
5417 #ifndef OutputStream
5418 #define OutputStream    PerlIO *
5419 #define InputStream             PerlIO *
5420 #endif  /* !OutputStream */
5421
5422 MODULE = Storable       PACKAGE = Storable
5423
5424 PROTOTYPES: ENABLE
5425
5426 BOOT:
5427     init_perinterp();
5428
5429 int
5430 pstore(f,obj)
5431 OutputStream    f
5432 SV *    obj
5433
5434 int
5435 net_pstore(f,obj)
5436 OutputStream    f
5437 SV *    obj
5438
5439 SV *
5440 mstore(obj)
5441 SV *    obj
5442
5443 SV *
5444 net_mstore(obj)
5445 SV *    obj
5446
5447 SV *
5448 pretrieve(f)
5449 InputStream     f
5450
5451 SV *
5452 mretrieve(sv)
5453 SV *    sv
5454
5455 SV *
5456 dclone(sv)
5457 SV *    sv
5458
5459 int
5460 last_op_in_netorder()
5461
5462 int
5463 is_storing()
5464
5465 int
5466 is_retrieving()
5467