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