ext/Storable/Storable.xs

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