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