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