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