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