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