ext/Storable/Storable.xs

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