ext/Storable/Storable.xs

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