ext/Storable/Storable.xs

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