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