ext/Storable/Storable.xs

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