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