ext/Storable/Storable.xs

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