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