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