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