dist/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 || (PERL_VERSION == 8 && PERL_SUBVERSION < 9) || (PERL_VERSION == 10 && PERL_SUBVERSION < 1)
  21 #define NEED_load_module
  22 #define NEED_vload_module
  23 #define NEED_newCONSTSUB
  24 #define NEED_newSVpvn_flags
  25 #define NEED_newRV_noinc
  26 #include "ppport.h"             /* handle old perls */
  27 #endif
  28
  29 #if 0
  30 #define DEBUGME /* Debug mode, turns assertions on as well */
  31 #define DASSERT /* Assertion mode */
  32 #endif
  33
  34 /*
  35  * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined
  36  * Provide them with the necessary defines so they can build with pre-5.004.
  37  */
  38 #ifndef USE_PERLIO
  39 #ifndef PERLIO_IS_STDIO
  40 #define PerlIO FILE
  41 #define PerlIO_getc(x) getc(x)
  42 #define PerlIO_putc(f,x) putc(x,f)
  43 #define PerlIO_read(x,y,z) fread(y,1,z,x)
  44 #define PerlIO_write(x,y,z) fwrite(y,1,z,x)
  45 #define PerlIO_stdoutf printf
  46 #endif  /* PERLIO_IS_STDIO */
  47 #endif  /* USE_PERLIO */
  48
  49 /*
  50  * Earlier versions of perl might be used, we can't assume they have the latest!
  51  */
  52
  53 #ifndef HvSHAREKEYS_off
  54 #define HvSHAREKEYS_off(hv)     /* Ignore */
  55 #endif
  56
  57 /* perl <= 5.8.2 needs this */
  58 #ifndef SvIsCOW
  59 # define SvIsCOW(sv) 0
  60 #endif
  61
  62 #ifndef HvRITER_set
  63 #  define HvRITER_set(hv,r)     (HvRITER(hv) = r)
  64 #endif
  65 #ifndef HvEITER_set
  66 #  define HvEITER_set(hv,r)     (HvEITER(hv) = r)
  67 #endif
  68
  69 #ifndef HvRITER_get
  70 #  define HvRITER_get HvRITER
  71 #endif
  72 #ifndef HvEITER_get
  73 #  define HvEITER_get HvEITER
  74 #endif
  75
  76 #ifndef HvPLACEHOLDERS_get
  77 #  define HvPLACEHOLDERS_get HvPLACEHOLDERS
  78 #endif
  79
  80 #ifndef HvTOTALKEYS
  81 #  define HvTOTALKEYS(hv)       HvKEYS(hv)
  82 #endif
  83
  84 #ifdef DEBUGME
  85
  86 #ifndef DASSERT
  87 #define DASSERT
  88 #endif
  89
  90 /*
  91  * TRACEME() will only output things when the $Storable::DEBUGME is true.
  92  */
  93
  94 #define TRACEME(x)                                                                              \
  95   STMT_START {                                                                                  \
  96         if (SvTRUE(perl_get_sv("Storable::DEBUGME", GV_ADD)))   \
  97                 { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); }             \
  98   } STMT_END
  99 #else
 100 #define TRACEME(x)
 101 #endif  /* DEBUGME */
 102
 103 #ifdef DASSERT
 104 #define ASSERT(x,y)                                                                             \
 105   STMT_START {                                                                                  \
 106         if (!(x)) {                                                                                             \
 107                 PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ",     \
 108                         __FILE__, __LINE__);                                                    \
 109                 PerlIO_stdoutf y; PerlIO_stdoutf("\n");                         \
 110         }                                                                                                               \
 111   } STMT_END
 112 #else
 113 #define ASSERT(x,y)
 114 #endif
 115
 116 /*
 117  * Type markers.
 118  */
 119
 120 #define C(x) ((char) (x))       /* For markers with dynamic retrieval handling */
 121
 122 #define SX_OBJECT       C(0)    /* Already stored object */
 123 #define SX_LSCALAR      C(1)    /* Scalar (large binary) follows (length, data) */
 124 #define SX_ARRAY        C(2)    /* Array forthcoming (size, item list) */
 125 #define SX_HASH         C(3)    /* Hash forthcoming (size, key/value pair list) */
 126 #define SX_REF          C(4)    /* Reference to object forthcoming */
 127 #define SX_UNDEF        C(5)    /* Undefined scalar */
 128 #define SX_INTEGER      C(6)    /* Integer forthcoming */
 129 #define SX_DOUBLE       C(7)    /* Double forthcoming */
 130 #define SX_BYTE         C(8)    /* (signed) byte forthcoming */
 131 #define SX_NETINT       C(9)    /* Integer in network order forthcoming */
 132 #define SX_SCALAR       C(10)   /* Scalar (binary, small) follows (length, data) */
 133 #define SX_TIED_ARRAY   C(11)   /* Tied array forthcoming */
 134 #define SX_TIED_HASH    C(12)   /* Tied hash forthcoming */
 135 #define SX_TIED_SCALAR  C(13)   /* Tied scalar forthcoming */
 136 #define SX_SV_UNDEF     C(14)   /* Perl's immortal PL_sv_undef */
 137 #define SX_SV_YES       C(15)   /* Perl's immortal PL_sv_yes */
 138 #define SX_SV_NO        C(16)   /* Perl's immortal PL_sv_no */
 139 #define SX_BLESS        C(17)   /* Object is blessed */
 140 #define SX_IX_BLESS     C(18)   /* Object is blessed, classname given by index */
 141 #define SX_HOOK         C(19)   /* Stored via hook, user-defined */
 142 #define SX_OVERLOAD     C(20)   /* Overloaded reference */
 143 #define SX_TIED_KEY     C(21)   /* Tied magic key forthcoming */
 144 #define SX_TIED_IDX     C(22)   /* Tied magic index forthcoming */
 145 #define SX_UTF8STR      C(23)   /* UTF-8 string forthcoming (small) */
 146 #define SX_LUTF8STR     C(24)   /* UTF-8 string forthcoming (large) */
 147 #define SX_FLAG_HASH    C(25)   /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
 148 #define SX_CODE         C(26)   /* Code references as perl source code */
 149 #define SX_WEAKREF      C(27)   /* Weak reference to object forthcoming */
 150 #define SX_WEAKOVERLOAD C(28)   /* Overloaded weak reference */
 151 #define SX_ERROR        C(29)   /* Error */
 152
 153 /*
 154  * Those are only used to retrieve "old" pre-0.6 binary images.
 155  */
 156 #define SX_ITEM         'i'             /* An array item introducer */
 157 #define SX_IT_UNDEF     'I'             /* Undefined array item */
 158 #define SX_KEY          'k'             /* A hash key introducer */
 159 #define SX_VALUE        'v'             /* A hash value introducer */
 160 #define SX_VL_UNDEF     'V'             /* Undefined hash value */
 161
 162 /*
 163  * Those are only used to retrieve "old" pre-0.7 binary images
 164  */
 165
 166 #define SX_CLASS        'b'             /* Object is blessed, class name length <255 */
 167 #define SX_LG_CLASS     'B'             /* Object is blessed, class name length >255 */
 168 #define SX_STORED       'X'             /* End of object */
 169
 170 /*
 171  * Limits between short/long length representation.
 172  */
 173
 174 #define LG_SCALAR       255             /* Large scalar length limit */
 175 #define LG_BLESS        127             /* Large classname bless limit */
 176
 177 /*
 178  * Operation types
 179  */
 180
 181 #define ST_STORE        0x1             /* Store operation */
 182 #define ST_RETRIEVE     0x2             /* Retrieval operation */
 183 #define ST_CLONE        0x4             /* Deep cloning operation */
 184
 185 /*
 186  * The following structure is used for hash table key retrieval. Since, when
 187  * retrieving objects, we'll be facing blessed hash references, it's best
 188  * to pre-allocate that buffer once and resize it as the need arises, never
 189  * freeing it (keys will be saved away someplace else anyway, so even large
 190  * keys are not enough a motivation to reclaim that space).
 191  *
 192  * This structure is also used for memory store/retrieve operations which
 193  * happen in a fixed place before being malloc'ed elsewhere if persistence
 194  * is required. Hence the aptr pointer.
 195  */
 196 struct extendable {
 197         char *arena;            /* Will hold hash key strings, resized as needed */
 198         STRLEN asiz;            /* Size of aforementioned buffer */
 199         char *aptr;                     /* Arena pointer, for in-place read/write ops */
 200         char *aend;                     /* First invalid address */
 201 };
 202
 203 /*
 204  * At store time:
 205  * A hash table records the objects which have already been stored.
 206  * Those are referred to as SX_OBJECT in the file, and their "tag" (i.e.
 207  * an arbitrary sequence number) is used to identify them.
 208  *
 209  * At retrieve time:
 210  * An array table records the objects which have already been retrieved,
 211  * as seen by the tag determined by counting the objects themselves. The
 212  * reference to that retrieved object is kept in the table, and is returned
 213  * when an SX_OBJECT is found bearing that same tag.
 214  *
 215  * The same processing is used to record "classname" for blessed objects:
 216  * indexing by a hash at store time, and via an array at retrieve time.
 217  */
 218
 219 typedef unsigned long stag_t;   /* Used by pre-0.6 binary format */
 220
 221 /*
 222  * The following "thread-safe" related defines were contributed by
 223  * Murray Nesbitt <murray@activestate.com> and integrated by RAM, who
 224  * only renamed things a little bit to ensure consistency with surrounding
 225  * code.        -- RAM, 14/09/1999
 226  *
 227  * The original patch suffered from the fact that the stcxt_t structure
 228  * was global.  Murray tried to minimize the impact on the code as much as
 229  * possible.
 230  *
 231  * Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks
 232  * on objects.  Therefore, the notion of context needs to be generalized,
 233  * threading or not.
 234  */
 235
 236 #define MY_VERSION "Storable(" XS_VERSION ")"
 237
 238
 239 /*
 240  * Conditional UTF8 support.
 241  *
 242  */
 243 #ifdef SvUTF8_on
 244 #define STORE_UTF8STR(pv, len)  STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
 245 #define HAS_UTF8_SCALARS
 246 #ifdef HeKUTF8
 247 #define HAS_UTF8_HASHES
 248 #define HAS_UTF8_ALL
 249 #else
 250 /* 5.6 perl has utf8 scalars but not hashes */
 251 #endif
 252 #else
 253 #define SvUTF8(sv) 0
 254 #define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
 255 #endif
 256 #ifndef HAS_UTF8_ALL
 257 #define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
 258 #endif
 259 #ifndef SvWEAKREF
 260 #define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl"))
 261 #endif
 262
 263 #ifdef HvPLACEHOLDERS
 264 #define HAS_RESTRICTED_HASHES
 265 #else
 266 #define HVhek_PLACEHOLD 0x200
 267 #define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash"))
 268 #endif
 269
 270 #ifdef HvHASKFLAGS
 271 #define HAS_HASH_KEY_FLAGS
 272 #endif
 273
 274 #ifdef ptr_table_new
 275 #define USE_PTR_TABLE
 276 #endif
 277
 278 /*
 279  * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
 280  * files remap tainted and dirty when threading is enabled.  That's bad for
 281  * perl to remap such common words.     -- RAM, 29/09/00
 282  */
 283
 284 struct stcxt;
 285 typedef struct stcxt {
 286         int entry;                      /* flags recursion */
 287         int optype;                     /* type of traversal operation */
 288         /* which objects have been seen, store time.
 289            tags are numbers, which are cast to (SV *) and stored directly */
 290 #ifdef USE_PTR_TABLE
 291         /* use pseen if we have ptr_tables. We have to store tag+1, because
 292            tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table
 293            without it being confused for a fetch lookup failure.  */
 294         struct ptr_tbl *pseen;
 295         /* Still need hseen for the 0.6 file format code. */
 296 #endif
 297         HV *hseen;
 298         AV *hook_seen;          /* which SVs were returned by STORABLE_freeze() */
 299         AV *aseen;                      /* which objects have been seen, retrieve time */
 300         IV where_is_undef;              /* index in aseen of PL_sv_undef */
 301         HV *hclass;                     /* which classnames have been seen, store time */
 302         AV *aclass;                     /* which classnames have been seen, retrieve time */
 303         HV *hook;                       /* cache for hook methods per class name */
 304         IV tagnum;                      /* incremented at store time for each seen object */
 305         IV classnum;            /* incremented at store time for each seen classname */
 306         int netorder;           /* true if network order used */
 307         int s_tainted;          /* true if input source is tainted, at retrieve time */
 308         int forgive_me;         /* whether to be forgiving... */
 309         int deparse;        /* whether to deparse code refs */
 310         SV *eval;           /* whether to eval source code */
 311         int canonical;          /* whether to store hashes sorted by key */
 312 #ifndef HAS_RESTRICTED_HASHES
 313         int derestrict;         /* whether to downgrade restricted hashes */
 314 #endif
 315 #ifndef HAS_UTF8_ALL
 316         int use_bytes;         /* whether to bytes-ify utf8 */
 317 #endif
 318         int accept_future_minor; /* croak immediately on future minor versions?  */
 319         int s_dirty;            /* context is dirty due to CROAK() -- can be cleaned */
 320         int membuf_ro;          /* true means membuf is read-only and msaved is rw */
 321         struct extendable keybuf;       /* for hash key retrieval */
 322         struct extendable membuf;       /* for memory store/retrieve operations */
 323         struct extendable msaved;       /* where potentially valid mbuf is saved */
 324         PerlIO *fio;            /* where I/O are performed, NULL for memory */
 325         int ver_major;          /* major of version for retrieved object */
 326         int ver_minor;          /* minor of version for retrieved object */
 327         SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *);      /* retrieve dispatch table */
 328         SV *prev;               /* contexts chained backwards in real recursion */
 329         SV *my_sv;              /* the blessed scalar who's SvPVX() I am */
 330         int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */
 331 } stcxt_t;
 332
 333 #define NEW_STORABLE_CXT_OBJ(cxt)                                       \
 334   STMT_START {                                                                          \
 335         SV *self = newSV(sizeof(stcxt_t) - 1);                  \
 336         SV *my_sv = newRV_noinc(self);                                  \
 337         sv_bless(my_sv, gv_stashpv("Storable::Cxt", GV_ADD));   \
 338         cxt = (stcxt_t *)SvPVX(self);                                   \
 339         Zero(cxt, 1, stcxt_t);                                                  \
 340         cxt->my_sv = my_sv;                                                             \
 341   } STMT_END
 342
 343 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
 344
 345 #if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
 346 #define dSTCXT_SV                                                                       \
 347         SV *perinterp_sv = perl_get_sv(MY_VERSION, 0)
 348 #else   /* >= perl5.004_68 */
 349 #define dSTCXT_SV                                                                       \
 350         SV *perinterp_sv = *hv_fetch(PL_modglobal,              \
 351                 MY_VERSION, sizeof(MY_VERSION)-1, TRUE)
 352 #endif  /* < perl5.004_68 */
 353
 354 #define dSTCXT_PTR(T,name)                                                      \
 355         T name = ((perinterp_sv && SvIOK(perinterp_sv) && SvIVX(perinterp_sv)   \
 356                                 ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0))
 357 #define dSTCXT                                                                          \
 358         dSTCXT_SV;                                                                              \
 359         dSTCXT_PTR(stcxt_t *, cxt)
 360
 361 #define INIT_STCXT                                                      \
 362         dSTCXT;                                                                 \
 363         NEW_STORABLE_CXT_OBJ(cxt);                              \
 364         sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv))
 365
 366 #define SET_STCXT(x)                                                            \
 367   STMT_START {                                                                          \
 368         dSTCXT_SV;                                                                              \
 369         sv_setiv(perinterp_sv, PTR2IV(x->my_sv));               \
 370   } STMT_END
 371
 372 #else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
 373
 374 static stcxt_t *Context_ptr = NULL;
 375 #define dSTCXT                  stcxt_t *cxt = Context_ptr
 376 #define SET_STCXT(x)            Context_ptr = x
 377 #define INIT_STCXT                                              \
 378         dSTCXT;                                                         \
 379         NEW_STORABLE_CXT_OBJ(cxt);                      \
 380         SET_STCXT(cxt)
 381
 382
 383 #endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */
 384
 385 /*
 386  * KNOWN BUG:
 387  *   Croaking implies a memory leak, since we don't use setjmp/longjmp
 388  *   to catch the exit and free memory used during store or retrieve
 389  *   operations.  This is not too difficult to fix, but I need to understand
 390  *   how Perl does it, and croaking is exceptional anyway, so I lack the
 391  *   motivation to do it.
 392  *
 393  * The current workaround is to mark the context as dirty when croaking,
 394  * so that data structures can be freed whenever we renter Storable code
 395  * (but only *then*: it's a workaround, not a fix).
 396  *
 397  * This is also imperfect, because we don't really know how far they trapped
 398  * the croak(), and when we were recursing, we won't be able to clean anything
 399  * but the topmost context stacked.
 400  */
 401
 402 #define CROAK(x)        STMT_START { cxt->s_dirty = 1; croak x; } STMT_END
 403
 404 /*
 405  * End of "thread-safe" related definitions.
 406  */
 407
 408 /*
 409  * LOW_32BITS
 410  *
 411  * Keep only the low 32 bits of a pointer (used for tags, which are not
 412  * really pointers).
 413  */
 414
 415 #if PTRSIZE <= 4
 416 #define LOW_32BITS(x)   ((I32) (x))
 417 #else
 418 #define LOW_32BITS(x)   ((I32) ((unsigned long) (x) & 0xffffffffUL))
 419 #endif
 420
 421 /*
 422  * oI, oS, oC
 423  *
 424  * Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
 425  * Used in the WLEN and RLEN macros.
 426  */
 427
 428 #if INTSIZE > 4
 429 #define oI(x)   ((I32 *) ((char *) (x) + 4))
 430 #define oS(x)   ((x) - 4)
 431 #define oC(x)   (x = 0)
 432 #define CRAY_HACK
 433 #else
 434 #define oI(x)   (x)
 435 #define oS(x)   (x)
 436 #define oC(x)
 437 #endif
 438
 439 /*
 440  * key buffer handling
 441  */
 442 #define kbuf    (cxt->keybuf).arena
 443 #define ksiz    (cxt->keybuf).asiz
 444 #define KBUFINIT()                                              \
 445   STMT_START {                                                  \
 446         if (!kbuf) {                                            \
 447                 TRACEME(("** allocating kbuf of 128 bytes")); \
 448                 New(10003, kbuf, 128, char);    \
 449                 ksiz = 128;                                             \
 450         }                                                                       \
 451   } STMT_END
 452 #define KBUFCHK(x)                              \
 453   STMT_START {                                  \
 454         if (x >= ksiz) {                        \
 455                 TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \
 456                 Renew(kbuf, x+1, char); \
 457                 ksiz = x+1;                             \
 458         }                                                       \
 459   } STMT_END
 460
 461 /*
 462  * memory buffer handling
 463  */
 464 #define mbase   (cxt->membuf).arena
 465 #define msiz    (cxt->membuf).asiz
 466 #define mptr    (cxt->membuf).aptr
 467 #define mend    (cxt->membuf).aend
 468
 469 #define MGROW   (1 << 13)
 470 #define MMASK   (MGROW - 1)
 471
 472 #define round_mgrow(x)  \
 473         ((unsigned long) (((unsigned long) (x) + MMASK) & ~MMASK))
 474 #define trunc_int(x)    \
 475         ((unsigned long) ((unsigned long) (x) & ~(sizeof(int)-1)))
 476 #define int_aligned(x)  \
 477         ((unsigned long) (x) == trunc_int(x))
 478
 479 #define MBUF_INIT(x)                                    \
 480   STMT_START {                                                  \
 481         if (!mbase) {                                           \
 482                 TRACEME(("** allocating mbase of %d bytes", MGROW)); \
 483                 New(10003, mbase, MGROW, char); \
 484                 msiz = (STRLEN)MGROW;                                   \
 485         }                                                                       \
 486         mptr = mbase;                                           \
 487         if (x)                                                          \
 488                 mend = mbase + x;                               \
 489         else                                                            \
 490                 mend = mbase + msiz;                    \
 491   } STMT_END
 492
 493 #define MBUF_TRUNC(x)   mptr = mbase + x
 494 #define MBUF_SIZE()             (mptr - mbase)
 495
 496 /*
 497  * MBUF_SAVE_AND_LOAD
 498  * MBUF_RESTORE
 499  *
 500  * Those macros are used in do_retrieve() to save the current memory
 501  * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
 502  * data from a string.
 503  */
 504 #define MBUF_SAVE_AND_LOAD(in)                  \
 505   STMT_START {                                                  \
 506         ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \
 507         cxt->membuf_ro = 1;                                     \
 508         TRACEME(("saving mbuf"));                       \
 509         StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \
 510         MBUF_LOAD(in);                                          \
 511   } STMT_END
 512
 513 #define MBUF_RESTORE()                                  \
 514   STMT_START {                                                  \
 515         ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
 516         cxt->membuf_ro = 0;                                     \
 517         TRACEME(("restoring mbuf"));            \
 518         StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
 519   } STMT_END
 520
 521 /*
 522  * Use SvPOKp(), because SvPOK() fails on tainted scalars.
 523  * See store_scalar() for other usage of this workaround.
 524  */
 525 #define MBUF_LOAD(v)                                    \
 526   STMT_START {                                                  \
 527         ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
 528         if (!SvPOKp(v))                                         \
 529                 CROAK(("Not a scalar string")); \
 530         mptr = mbase = SvPV(v, msiz);           \
 531         mend = mbase + msiz;                            \
 532   } STMT_END
 533
 534 #define MBUF_XTEND(x)                           \
 535   STMT_START {                                          \
 536         int nsz = (int) round_mgrow((x)+msiz);  \
 537         int offset = mptr - mbase;              \
 538         ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
 539         TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \
 540                 msiz, nsz, (x)));                       \
 541         Renew(mbase, nsz, char);                \
 542         msiz = nsz;                                             \
 543         mptr = mbase + offset;                  \
 544         mend = mbase + nsz;                             \
 545   } STMT_END
 546
 547 #define MBUF_CHK(x)                             \
 548   STMT_START {                                          \
 549         if ((mptr + (x)) > mend)                \
 550                 MBUF_XTEND(x);                          \
 551   } STMT_END
 552
 553 #define MBUF_GETC(x)                            \
 554   STMT_START {                                          \
 555         if (mptr < mend)                                \
 556                 x = (int) (unsigned char) *mptr++;      \
 557         else                                                    \
 558                 return (SV *) 0;                        \
 559   } STMT_END
 560
 561 #ifdef CRAY_HACK
 562 #define MBUF_GETINT(x)                                  \
 563   STMT_START {                                                  \
 564         oC(x);                                                          \
 565         if ((mptr + 4) <= mend) {                       \
 566                 memcpy(oI(&x), mptr, 4);                \
 567                 mptr += 4;                                              \
 568         } else                                                          \
 569                 return (SV *) 0;                                \
 570   } STMT_END
 571 #else
 572 #define MBUF_GETINT(x)                                  \
 573   STMT_START {                                                  \
 574         if ((mptr + sizeof(int)) <= mend) {     \
 575                 if (int_aligned(mptr))                  \
 576                         x = *(int *) mptr;                      \
 577                 else                                                    \
 578                         memcpy(&x, mptr, sizeof(int));  \
 579                 mptr += sizeof(int);                    \
 580         } else                                                          \
 581                 return (SV *) 0;                                \
 582   } STMT_END
 583 #endif
 584
 585 #define MBUF_READ(x,s)                          \
 586   STMT_START {                                          \
 587         if ((mptr + (s)) <= mend) {             \
 588                 memcpy(x, mptr, s);                     \
 589                 mptr += s;                                      \
 590         } else                                                  \
 591                 return (SV *) 0;                        \
 592   } STMT_END
 593
 594 #define MBUF_SAFEREAD(x,s,z)            \
 595   STMT_START {                                          \
 596         if ((mptr + (s)) <= mend) {             \
 597                 memcpy(x, mptr, s);                     \
 598                 mptr += s;                                      \
 599         } else {                                                \
 600                 sv_free(z);                                     \
 601                 return (SV *) 0;                        \
 602         }                                                               \
 603   } STMT_END
 604
 605 #define MBUF_SAFEPVREAD(x,s,z)                  \
 606   STMT_START {                                  \
 607         if ((mptr + (s)) <= mend) {             \
 608                 memcpy(x, mptr, s);             \
 609                 mptr += s;                      \
 610         } else {                                \
 611                 Safefree(z);                    \
 612                 return (SV *) 0;                \
 613         }                                       \
 614   } STMT_END
 615
 616 #define MBUF_PUTC(c)                            \
 617   STMT_START {                                          \
 618         if (mptr < mend)                                \
 619                 *mptr++ = (char) c;                     \
 620         else {                                                  \
 621                 MBUF_XTEND(1);                          \
 622                 *mptr++ = (char) c;                     \
 623         }                                                               \
 624   } STMT_END
 625
 626 #ifdef CRAY_HACK
 627 #define MBUF_PUTINT(i)                          \
 628   STMT_START {                                          \
 629         MBUF_CHK(4);                                    \
 630         memcpy(mptr, oI(&i), 4);                \
 631         mptr += 4;                                              \
 632   } STMT_END
 633 #else
 634 #define MBUF_PUTINT(i)                          \
 635   STMT_START {                                          \
 636         MBUF_CHK(sizeof(int));                  \
 637         if (int_aligned(mptr))                  \
 638                 *(int *) mptr = i;                      \
 639         else                                                    \
 640                 memcpy(mptr, &i, sizeof(int));  \
 641         mptr += sizeof(int);                    \
 642   } STMT_END
 643 #endif
 644
 645 #define MBUF_WRITE(x,s)                         \
 646   STMT_START {                                          \
 647         MBUF_CHK(s);                                    \
 648         memcpy(mptr, x, s);                             \
 649         mptr += s;                                              \
 650   } STMT_END
 651
 652 /*
 653  * Possible return values for sv_type().
 654  */
 655
 656 #define svis_REF                0
 657 #define svis_SCALAR             1
 658 #define svis_ARRAY              2
 659 #define svis_HASH               3
 660 #define svis_TIED               4
 661 #define svis_TIED_ITEM  5
 662 #define svis_CODE               6
 663 #define svis_OTHER              7
 664
 665 /*
 666  * Flags for SX_HOOK.
 667  */
 668
 669 #define SHF_TYPE_MASK           0x03
 670 #define SHF_LARGE_CLASSLEN      0x04
 671 #define SHF_LARGE_STRLEN        0x08
 672 #define SHF_LARGE_LISTLEN       0x10
 673 #define SHF_IDX_CLASSNAME       0x20
 674 #define SHF_NEED_RECURSE        0x40
 675 #define SHF_HAS_LIST            0x80
 676
 677 /*
 678  * Types for SX_HOOK (last 2 bits in flags).
 679  */
 680
 681 #define SHT_SCALAR                      0
 682 #define SHT_ARRAY                       1
 683 #define SHT_HASH                        2
 684 #define SHT_EXTRA                       3               /* Read extra byte for type */
 685
 686 /*
 687  * The following are held in the "extra byte"...
 688  */
 689
 690 #define SHT_TSCALAR                     4               /* 4 + 0 -- tied scalar */
 691 #define SHT_TARRAY                      5               /* 4 + 1 -- tied array */
 692 #define SHT_THASH                       6               /* 4 + 2 -- tied hash */
 693
 694 /*
 695  * per hash flags for flagged hashes
 696  */
 697
 698 #define SHV_RESTRICTED          0x01
 699
 700 /*
 701  * per key flags for flagged hashes
 702  */
 703
 704 #define SHV_K_UTF8              0x01
 705 #define SHV_K_WASUTF8           0x02
 706 #define SHV_K_LOCKED            0x04
 707 #define SHV_K_ISSV              0x08
 708 #define SHV_K_PLACEHOLDER       0x10
 709
 710 /*
 711  * Before 0.6, the magic string was "perl-store" (binary version number 0).
 712  *
 713  * Since 0.6 introduced many binary incompatibilities, the magic string has
 714  * been changed to "pst0" to allow an old image to be properly retrieved by
 715  * a newer Storable, but ensure a newer image cannot be retrieved with an
 716  * older version.
 717  *
 718  * At 0.7, objects are given the ability to serialize themselves, and the
 719  * set of markers is extended, backward compatibility is not jeopardized,
 720  * so the binary version number could have remained unchanged.  To correctly
 721  * spot errors if a file making use of 0.7-specific extensions is given to
 722  * 0.6 for retrieval, the binary version was moved to "2".  And I'm introducing
 723  * a "minor" version, to better track this kind of evolution from now on.
 724  *
 725  */
 726 static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */
 727 static const char magicstr[] = "pst0";           /* Used as a magic number */
 728
 729 #define MAGICSTR_BYTES  'p','s','t','0'
 730 #define OLDMAGICSTR_BYTES  'p','e','r','l','-','s','t','o','r','e'
 731
 732 /* 5.6.x introduced the ability to have IVs as long long.
 733    However, Configure still defined BYTEORDER based on the size of a long.
 734    Storable uses the BYTEORDER value as part of the header, but doesn't
 735    explicitly store sizeof(IV) anywhere in the header.  Hence on 5.6.x built
 736    with IV as long long on a platform that uses Configure (ie most things
 737    except VMS and Windows) headers are identical for the different IV sizes,
 738    despite the files containing some fields based on sizeof(IV)
 739    Erk. Broken-ness.
 740    5.8 is consistent - the following redefinition kludge is only needed on
 741    5.6.x, but the interwork is needed on 5.8 while data survives in files
 742    with the 5.6 header.
 743
 744 */
 745
 746 #if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4)
 747 #ifndef NO_56_INTERWORK_KLUDGE
 748 #define USE_56_INTERWORK_KLUDGE
 749 #endif
 750 #if BYTEORDER == 0x1234
 751 #undef BYTEORDER
 752 #define BYTEORDER 0x12345678
 753 #else
 754 #if BYTEORDER == 0x4321
 755 #undef BYTEORDER
 756 #define BYTEORDER 0x87654321
 757 #endif
 758 #endif
 759 #endif
 760
 761 #if BYTEORDER == 0x1234
 762 #define BYTEORDER_BYTES  '1','2','3','4'
 763 #else
 764 #if BYTEORDER == 0x12345678
 765 #define BYTEORDER_BYTES  '1','2','3','4','5','6','7','8'
 766 #ifdef USE_56_INTERWORK_KLUDGE
 767 #define BYTEORDER_BYTES_56  '1','2','3','4'
 768 #endif
 769 #else
 770 #if BYTEORDER == 0x87654321
 771 #define BYTEORDER_BYTES  '8','7','6','5','4','3','2','1'
 772 #ifdef USE_56_INTERWORK_KLUDGE
 773 #define BYTEORDER_BYTES_56  '4','3','2','1'
 774 #endif
 775 #else
 776 #if BYTEORDER == 0x4321
 777 #define BYTEORDER_BYTES  '4','3','2','1'
 778 #else
 779 #error Unknown byteorder. Please append your byteorder to Storable.xs
 780 #endif
 781 #endif
 782 #endif
 783 #endif
 784
 785 static const char byteorderstr[] = {BYTEORDER_BYTES, 0};
 786 #ifdef USE_56_INTERWORK_KLUDGE
 787 static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
 788 #endif
 789
 790 #define STORABLE_BIN_MAJOR      2               /* Binary major "version" */
 791 #define STORABLE_BIN_MINOR      8               /* Binary minor "version" */
 792
 793 #if (PATCHLEVEL <= 5)
 794 #define STORABLE_BIN_WRITE_MINOR        4
 795 #else
 796 /*
 797  * Perl 5.6.0 onwards can do weak references.
 798 */
 799 #define STORABLE_BIN_WRITE_MINOR        8
 800 #endif /* (PATCHLEVEL <= 5) */
 801
 802 #if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1))
 803 #define PL_sv_placeholder PL_sv_undef
 804 #endif
 805
 806 /*
 807  * Useful store shortcuts...
 808  */
 809
 810 /*
 811  * Note that if you put more than one mark for storing a particular
 812  * type of thing, *and* in the retrieve_foo() function you mark both
 813  * the thingy's you get off with SEEN(), you *must* increase the
 814  * tagnum with cxt->tagnum++ along with this macro!
 815  *     - samv 20Jan04
 816  */
 817 #define PUTMARK(x)                                                      \
 818   STMT_START {                                                          \
 819         if (!cxt->fio)                                                  \
 820                 MBUF_PUTC(x);                                           \
 821         else if (PerlIO_putc(cxt->fio, x) == EOF)       \
 822                 return -1;                                                      \
 823   } STMT_END
 824
 825 #define WRITE_I32(x)                                    \
 826   STMT_START {                                                  \
 827         ASSERT(sizeof(x) == sizeof(I32), ("writing an I32"));   \
 828         if (!cxt->fio)                                          \
 829                 MBUF_PUTINT(x);                                 \
 830         else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
 831                 return -1;                                      \
 832   } STMT_END
 833
 834 #ifdef HAS_HTONL
 835 #define WLEN(x)                                         \
 836   STMT_START {                                          \
 837         if (cxt->netorder) {                    \
 838                 int y = (int) htonl(x);         \
 839                 if (!cxt->fio)                          \
 840                         MBUF_PUTINT(y);                 \
 841                 else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \
 842                         return -1;                              \
 843         } else {                                                \
 844                 if (!cxt->fio)                          \
 845                         MBUF_PUTINT(x);                 \
 846                 else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \
 847                         return -1;                              \
 848         }                                                               \
 849   } STMT_END
 850 #else
 851 #define WLEN(x) WRITE_I32(x)
 852 #endif
 853
 854 #define WRITE(x,y)                                                      \
 855   STMT_START {                                                          \
 856         if (!cxt->fio)                                                  \
 857                 MBUF_WRITE(x,y);                                        \
 858         else if (PerlIO_write(cxt->fio, x, y) != y)     \
 859                 return -1;                                                      \
 860   } STMT_END
 861
 862 #define STORE_PV_LEN(pv, len, small, large)                     \
 863   STMT_START {                                                  \
 864         if (len <= LG_SCALAR) {                         \
 865                 unsigned char clen = (unsigned char) len;       \
 866                 PUTMARK(small);                                 \
 867                 PUTMARK(clen);                                  \
 868                 if (len)                                                \
 869                         WRITE(pv, len);                         \
 870         } else {                                                        \
 871                 PUTMARK(large);                                 \
 872                 WLEN(len);                                              \
 873                 WRITE(pv, len);                                 \
 874         }                                                                       \
 875   } STMT_END
 876
 877 #define STORE_SCALAR(pv, len)   STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
 878
 879 /*
 880  * Store &PL_sv_undef in arrays without recursing through store().
 881  */
 882 #define STORE_SV_UNDEF()                                        \
 883   STMT_START {                                                  \
 884         cxt->tagnum++;                                          \
 885         PUTMARK(SX_SV_UNDEF);                                   \
 886   } STMT_END
 887
 888 /*
 889  * Useful retrieve shortcuts...
 890  */
 891
 892 #define GETCHAR() \
 893         (cxt->fio ? PerlIO_getc(cxt->fio) : (mptr >= mend ? EOF : (int) *mptr++))
 894
 895 #define GETMARK(x)                                                              \
 896   STMT_START {                                                                  \
 897         if (!cxt->fio)                                                          \
 898                 MBUF_GETC(x);                                                   \
 899         else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF)      \
 900                 return (SV *) 0;                                                \
 901   } STMT_END
 902
 903 #define READ_I32(x)                                             \
 904   STMT_START {                                                  \
 905         ASSERT(sizeof(x) == sizeof(I32), ("reading an I32"));   \
 906         oC(x);                                                          \
 907         if (!cxt->fio)                                          \
 908                 MBUF_GETINT(x);                                 \
 909         else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
 910                 return (SV *) 0;                                \
 911   } STMT_END
 912
 913 #ifdef HAS_NTOHL
 914 #define RLEN(x)                                                 \
 915   STMT_START {                                                  \
 916         oC(x);                                                          \
 917         if (!cxt->fio)                                          \
 918                 MBUF_GETINT(x);                                 \
 919         else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
 920                 return (SV *) 0;                                \
 921         if (cxt->netorder)                                      \
 922                 x = (int) ntohl(x);                             \
 923   } STMT_END
 924 #else
 925 #define RLEN(x) READ_I32(x)
 926 #endif
 927
 928 #define READ(x,y)                                                       \
 929   STMT_START {                                                          \
 930         if (!cxt->fio)                                                  \
 931                 MBUF_READ(x, y);                                        \
 932         else if (PerlIO_read(cxt->fio, x, y) != y)      \
 933                 return (SV *) 0;                                        \
 934   } STMT_END
 935
 936 #define SAFEREAD(x,y,z)                                                 \
 937   STMT_START {                                                                  \
 938         if (!cxt->fio)                                                          \
 939                 MBUF_SAFEREAD(x,y,z);                                   \
 940         else if (PerlIO_read(cxt->fio, x, y) != y)       {      \
 941                 sv_free(z);                                                             \
 942                 return (SV *) 0;                                                \
 943         }                                                                                       \
 944   } STMT_END
 945
 946 #define SAFEPVREAD(x,y,z)                                       \
 947   STMT_START {                                                  \
 948         if (!cxt->fio)                                          \
 949                 MBUF_SAFEPVREAD(x,y,z);                         \
 950         else if (PerlIO_read(cxt->fio, x, y) != y)       {      \
 951                 Safefree(z);                                    \
 952                 return (SV *) 0;                                \
 953         }                                                       \
 954   } STMT_END
 955
 956 /*
 957  * This macro is used at retrieve time, to remember where object 'y', bearing a
 958  * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
 959  * we'll therefore know where it has been retrieved and will be able to
 960  * share the same reference, as in the original stored memory image.
 961  *
 962  * We also need to bless objects ASAP for hooks (which may compute "ref $x"
 963  * on the objects given to STORABLE_thaw and expect that to be defined), and
 964  * also for overloaded objects (for which we might not find the stash if the
 965  * object is not blessed yet--this might occur for overloaded objects that
 966  * refer to themselves indirectly: if we blessed upon return from a sub
 967  * retrieve(), the SX_OBJECT marker we'd found could not have overloading
 968  * restored on it because the underlying object would not be blessed yet!).
 969  *
 970  * To achieve that, the class name of the last retrieved object is passed down
 971  * recursively, and the first SEEN() call for which the class name is not NULL
 972  * will bless the object.
 973  *
 974  * i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef)
 975  */
 976 #define SEEN(y,c,i)                                                     \
 977   STMT_START {                                                          \
 978         if (!y)                                                                 \
 979                 return (SV *) 0;                                        \
 980         if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) : SvREFCNT_inc(y)) == 0) \
 981                 return (SV *) 0;                                        \
 982         TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \
 983                  PTR2UV(y), SvREFCNT(y)-1));            \
 984         if (c)                                                                  \
 985                 BLESS((SV *) (y), c);                           \
 986   } STMT_END
 987
 988 /*
 989  * Bless `s' in `p', via a temporary reference, required by sv_bless().
 990  * "A" magic is added before the sv_bless for overloaded classes, this avoids
 991  * an expensive call to S_reset_amagic in sv_bless.
 992  */
 993 #define BLESS(s,p)                                                      \
 994   STMT_START {                                                          \
 995         SV *ref;                                                                \
 996         HV *stash;                                                              \
 997         TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \
 998         stash = gv_stashpv((p), GV_ADD);                        \
 999         ref = newRV_noinc(s);                                   \
1000         if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) \
1001         { \
1002             cxt->in_retrieve_overloaded = 0; \
1003                 SvAMAGIC_on(ref);                            \
1004         } \
1005         (void) sv_bless(ref, stash);                    \
1006         SvRV_set(ref, NULL);                                            \
1007         SvREFCNT_dec(ref);                                              \
1008   } STMT_END
1009 /*
1010  * sort (used in store_hash) - conditionally use qsort when
1011  * sortsv is not available ( <= 5.6.1 ).
1012  */
1013
1014 #if (PATCHLEVEL <= 6)
1015
1016 #if defined(USE_ITHREADS)
1017
1018 #define STORE_HASH_SORT \
1019         ENTER; { \
1020         PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \
1021         SAVESPTR(orig_perl); \
1022         PERL_SET_CONTEXT(aTHX); \
1023         qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); \
1024         } LEAVE;
1025
1026 #else /* ! USE_ITHREADS */
1027
1028 #define STORE_HASH_SORT \
1029         qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
1030
1031 #endif  /* USE_ITHREADS */
1032
1033 #else /* PATCHLEVEL > 6 */
1034
1035 #define STORE_HASH_SORT \
1036         sortsv(AvARRAY(av), len, Perl_sv_cmp);
1037
1038 #endif /* PATCHLEVEL <= 6 */
1039
1040 static int store(pTHX_ stcxt_t *cxt, SV *sv);
1041 static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname);
1042
1043 /*
1044  * Dynamic dispatching table for SV store.
1045  */
1046
1047 static int store_ref(pTHX_ stcxt_t *cxt, SV *sv);
1048 static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv);
1049 static int store_array(pTHX_ stcxt_t *cxt, AV *av);
1050 static int store_hash(pTHX_ stcxt_t *cxt, HV *hv);
1051 static int store_tied(pTHX_ stcxt_t *cxt, SV *sv);
1052 static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv);
1053 static int store_code(pTHX_ stcxt_t *cxt, CV *cv);
1054 static int store_other(pTHX_ stcxt_t *cxt, SV *sv);
1055 static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg);
1056
1057 typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv);
1058
1059 static const sv_store_t sv_store[] = {
1060         (sv_store_t)store_ref,          /* svis_REF */
1061         (sv_store_t)store_scalar,       /* svis_SCALAR */
1062         (sv_store_t)store_array,        /* svis_ARRAY */
1063         (sv_store_t)store_hash,         /* svis_HASH */
1064         (sv_store_t)store_tied,         /* svis_TIED */
1065         (sv_store_t)store_tied_item,    /* svis_TIED_ITEM */
1066         (sv_store_t)store_code,         /* svis_CODE */
1067         (sv_store_t)store_other,        /* svis_OTHER */
1068 };
1069
1070 #define SV_STORE(x)     (*sv_store[x])
1071
1072 /*
1073  * Dynamic dispatching tables for SV retrieval.
1074  */
1075
1076 static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname);
1077 static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname);
1078 static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
1079 static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
1080 static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname);
1081 static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname);
1082 static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname);
1083 static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname);
1084 static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname);
1085 static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname);
1086 static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname);
1087 static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname);
1088 static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname);
1089 static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname);
1090 static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname);
1091 static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname);
1092
1093 typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, const char *name);
1094
1095 static const sv_retrieve_t sv_old_retrieve[] = {
1096         0,                      /* SX_OBJECT -- entry unused dynamically */
1097         (sv_retrieve_t)retrieve_lscalar,        /* SX_LSCALAR */
1098         (sv_retrieve_t)old_retrieve_array,      /* SX_ARRAY -- for pre-0.6 binaries */
1099         (sv_retrieve_t)old_retrieve_hash,       /* SX_HASH -- for pre-0.6 binaries */
1100         (sv_retrieve_t)retrieve_ref,            /* SX_REF */
1101         (sv_retrieve_t)retrieve_undef,          /* SX_UNDEF */
1102         (sv_retrieve_t)retrieve_integer,        /* SX_INTEGER */
1103         (sv_retrieve_t)retrieve_double,         /* SX_DOUBLE */
1104         (sv_retrieve_t)retrieve_byte,           /* SX_BYTE */
1105         (sv_retrieve_t)retrieve_netint,         /* SX_NETINT */
1106         (sv_retrieve_t)retrieve_scalar,         /* SX_SCALAR */
1107         (sv_retrieve_t)retrieve_tied_array,     /* SX_ARRAY */
1108         (sv_retrieve_t)retrieve_tied_hash,      /* SX_HASH */
1109         (sv_retrieve_t)retrieve_tied_scalar,    /* SX_SCALAR */
1110         (sv_retrieve_t)retrieve_other,  /* SX_SV_UNDEF not supported */
1111         (sv_retrieve_t)retrieve_other,  /* SX_SV_YES not supported */
1112         (sv_retrieve_t)retrieve_other,  /* SX_SV_NO not supported */
1113         (sv_retrieve_t)retrieve_other,  /* SX_BLESS not supported */
1114         (sv_retrieve_t)retrieve_other,  /* SX_IX_BLESS not supported */
1115         (sv_retrieve_t)retrieve_other,  /* SX_HOOK not supported */
1116         (sv_retrieve_t)retrieve_other,  /* SX_OVERLOADED not supported */
1117         (sv_retrieve_t)retrieve_other,  /* SX_TIED_KEY not supported */
1118         (sv_retrieve_t)retrieve_other,  /* SX_TIED_IDX not supported */
1119         (sv_retrieve_t)retrieve_other,  /* SX_UTF8STR not supported */
1120         (sv_retrieve_t)retrieve_other,  /* SX_LUTF8STR not supported */
1121         (sv_retrieve_t)retrieve_other,  /* SX_FLAG_HASH not supported */
1122         (sv_retrieve_t)retrieve_other,  /* SX_CODE not supported */
1123         (sv_retrieve_t)retrieve_other,  /* SX_WEAKREF not supported */
1124         (sv_retrieve_t)retrieve_other,  /* SX_WEAKOVERLOAD not supported */
1125         (sv_retrieve_t)retrieve_other,  /* SX_ERROR */
1126 };
1127
1128 static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
1129 static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
1130 static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname);
1131 static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname);
1132 static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname);
1133 static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname);
1134 static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname);
1135 static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname);
1136 static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname);
1137 static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname);
1138 static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname);
1139 static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname);
1140 static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname);
1141 static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname);
1142 static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname);
1143
1144 static const sv_retrieve_t sv_retrieve[] = {
1145         0,                      /* SX_OBJECT -- entry unused dynamically */
1146         (sv_retrieve_t)retrieve_lscalar,        /* SX_LSCALAR */
1147         (sv_retrieve_t)retrieve_array,          /* SX_ARRAY */
1148         (sv_retrieve_t)retrieve_hash,           /* SX_HASH */
1149         (sv_retrieve_t)retrieve_ref,            /* SX_REF */
1150         (sv_retrieve_t)retrieve_undef,          /* SX_UNDEF */
1151         (sv_retrieve_t)retrieve_integer,        /* SX_INTEGER */
1152         (sv_retrieve_t)retrieve_double,         /* SX_DOUBLE */
1153         (sv_retrieve_t)retrieve_byte,           /* SX_BYTE */
1154         (sv_retrieve_t)retrieve_netint,         /* SX_NETINT */
1155         (sv_retrieve_t)retrieve_scalar,         /* SX_SCALAR */
1156         (sv_retrieve_t)retrieve_tied_array,     /* SX_ARRAY */
1157         (sv_retrieve_t)retrieve_tied_hash,      /* SX_HASH */
1158         (sv_retrieve_t)retrieve_tied_scalar,    /* SX_SCALAR */
1159         (sv_retrieve_t)retrieve_sv_undef,       /* SX_SV_UNDEF */
1160         (sv_retrieve_t)retrieve_sv_yes,         /* SX_SV_YES */
1161         (sv_retrieve_t)retrieve_sv_no,          /* SX_SV_NO */
1162         (sv_retrieve_t)retrieve_blessed,        /* SX_BLESS */
1163         (sv_retrieve_t)retrieve_idx_blessed,    /* SX_IX_BLESS */
1164         (sv_retrieve_t)retrieve_hook,           /* SX_HOOK */
1165         (sv_retrieve_t)retrieve_overloaded,     /* SX_OVERLOAD */
1166         (sv_retrieve_t)retrieve_tied_key,       /* SX_TIED_KEY */
1167         (sv_retrieve_t)retrieve_tied_idx,       /* SX_TIED_IDX */
1168         (sv_retrieve_t)retrieve_utf8str,        /* SX_UTF8STR  */
1169         (sv_retrieve_t)retrieve_lutf8str,       /* SX_LUTF8STR */
1170         (sv_retrieve_t)retrieve_flag_hash,      /* SX_HASH */
1171         (sv_retrieve_t)retrieve_code,           /* SX_CODE */
1172         (sv_retrieve_t)retrieve_weakref,        /* SX_WEAKREF */
1173         (sv_retrieve_t)retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */
1174         (sv_retrieve_t)retrieve_other,          /* SX_ERROR */
1175 };
1176
1177 #define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)])
1178
1179 static SV *mbuf2sv(pTHX);
1180
1181 /***
1182  *** Context management.
1183  ***/
1184
1185 /*
1186  * init_perinterp
1187  *
1188  * Called once per "thread" (interpreter) to initialize some global context.
1189  */
1190 static void init_perinterp(pTHX)
1191 {
1192     INIT_STCXT;
1193
1194     cxt->netorder = 0;          /* true if network order used */
1195     cxt->forgive_me = -1;       /* whether to be forgiving... */
1196     cxt->accept_future_minor = -1; /* would otherwise occur too late */
1197 }
1198
1199 /*
1200  * reset_context
1201  *
1202  * Called at the end of every context cleaning, to perform common reset
1203  * operations.
1204  */
1205 static void reset_context(stcxt_t *cxt)
1206 {
1207         cxt->entry = 0;
1208         cxt->s_dirty = 0;
1209         cxt->optype &= ~(ST_STORE|ST_RETRIEVE);         /* Leave ST_CLONE alone */
1210 }
1211
1212 /*
1213  * init_store_context
1214  *
1215  * Initialize a new store context for real recursion.
1216  */
1217 static void init_store_context(
1218         pTHX_
1219         stcxt_t *cxt,
1220         PerlIO *f,
1221         int optype,
1222         int network_order)
1223 {
1224         TRACEME(("init_store_context"));
1225
1226         cxt->netorder = network_order;
1227         cxt->forgive_me = -1;                   /* Fetched from perl if needed */
1228         cxt->deparse = -1;                              /* Idem */
1229         cxt->eval = NULL;                               /* Idem */
1230         cxt->canonical = -1;                    /* Idem */
1231         cxt->tagnum = -1;                               /* Reset tag numbers */
1232         cxt->classnum = -1;                             /* Reset class numbers */
1233         cxt->fio = f;                                   /* Where I/O are performed */
1234         cxt->optype = optype;                   /* A store, or a deep clone */
1235         cxt->entry = 1;                                 /* No recursion yet */
1236
1237         /*
1238          * The `hseen' table is used to keep track of each SV stored and their
1239          * associated tag numbers is special. It is "abused" because the
1240          * values stored are not real SV, just integers cast to (SV *),
1241          * which explains the freeing below.
1242          *
1243          * It is also one possible bottleneck to achieve good storing speed,
1244          * so the "shared keys" optimization is turned off (unlikely to be
1245          * of any use here), and the hash table is "pre-extended". Together,
1246          * those optimizations increase the throughput by 12%.
1247          */
1248
1249 #ifdef USE_PTR_TABLE
1250         cxt->pseen = ptr_table_new();
1251         cxt->hseen = 0;
1252 #else
1253         cxt->hseen = newHV();                   /* Table where seen objects are stored */
1254         HvSHAREKEYS_off(cxt->hseen);
1255 #endif
1256         /*
1257          * The following does not work well with perl5.004_04, and causes
1258          * a core dump later on, in a completely unrelated spot, which
1259          * makes me think there is a memory corruption going on.
1260          *
1261          * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking
1262          * it below does not make any difference. It seems to work fine
1263          * with perl5.004_68 but given the probable nature of the bug,
1264          * that does not prove anything.
1265          *
1266          * It's a shame because increasing the amount of buckets raises
1267          * store() throughput by 5%, but until I figure this out, I can't
1268          * allow for this to go into production.
1269          *
1270          * It is reported fixed in 5.005, hence the #if.
1271          */
1272 #if PERL_VERSION >= 5
1273 #define HBUCKETS        4096                            /* Buckets for %hseen */
1274 #ifndef USE_PTR_TABLE
1275         HvMAX(cxt->hseen) = HBUCKETS - 1;       /* keys %hseen = $HBUCKETS; */
1276 #endif
1277 #endif
1278
1279         /*
1280          * The `hclass' hash uses the same settings as `hseen' above, but it is
1281          * used to assign sequential tags (numbers) to class names for blessed
1282          * objects.
1283          *
1284          * We turn the shared key optimization on.
1285          */
1286
1287         cxt->hclass = newHV();                  /* Where seen classnames are stored */
1288
1289 #if PERL_VERSION >= 5
1290         HvMAX(cxt->hclass) = HBUCKETS - 1;      /* keys %hclass = $HBUCKETS; */
1291 #endif
1292
1293         /*
1294          * The `hook' hash table is used to keep track of the references on
1295          * the STORABLE_freeze hook routines, when found in some class name.
1296          *
1297          * It is assumed that the inheritance tree will not be changed during
1298          * storing, and that no new method will be dynamically created by the
1299          * hooks.
1300          */
1301
1302         cxt->hook = newHV();                    /* Table where hooks are cached */
1303
1304         /*
1305          * The `hook_seen' array keeps track of all the SVs returned by
1306          * STORABLE_freeze hooks for us to serialize, so that they are not
1307          * reclaimed until the end of the serialization process.  Each SV is
1308          * only stored once, the first time it is seen.
1309          */
1310
1311         cxt->hook_seen = newAV();               /* Lists SVs returned by STORABLE_freeze */
1312 }
1313
1314 /*
1315  * clean_store_context
1316  *
1317  * Clean store context by
1318  */
1319 static void clean_store_context(pTHX_ stcxt_t *cxt)
1320 {
1321         HE *he;
1322
1323         TRACEME(("clean_store_context"));
1324
1325         ASSERT(cxt->optype & ST_STORE, ("was performing a store()"));
1326
1327         /*
1328          * Insert real values into hashes where we stored faked pointers.
1329          */
1330
1331 #ifndef USE_PTR_TABLE
1332         if (cxt->hseen) {
1333                 hv_iterinit(cxt->hseen);
1334                 while ((he = hv_iternext(cxt->hseen)))  /* Extra () for -Wall, grr.. */
1335                         HeVAL(he) = &PL_sv_undef;
1336         }
1337 #endif
1338
1339         if (cxt->hclass) {
1340                 hv_iterinit(cxt->hclass);
1341                 while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall, grr.. */
1342                         HeVAL(he) = &PL_sv_undef;
1343         }
1344
1345         /*
1346          * And now dispose of them...
1347          *
1348          * The surrounding if() protection has been added because there might be
1349          * some cases where this routine is called more than once, during
1350          * exceptional events.  This was reported by Marc Lehmann when Storable
1351          * is executed from mod_perl, and the fix was suggested by him.
1352          *              -- RAM, 20/12/2000
1353          */
1354
1355 #ifdef USE_PTR_TABLE
1356         if (cxt->pseen) {
1357                 struct ptr_tbl *pseen = cxt->pseen;
1358                 cxt->pseen = 0;
1359                 ptr_table_free(pseen);
1360         }
1361         assert(!cxt->hseen);
1362 #else
1363         if (cxt->hseen) {
1364                 HV *hseen = cxt->hseen;
1365                 cxt->hseen = 0;
1366                 hv_undef(hseen);
1367                 sv_free((SV *) hseen);
1368         }
1369 #endif
1370
1371         if (cxt->hclass) {
1372                 HV *hclass = cxt->hclass;
1373                 cxt->hclass = 0;
1374                 hv_undef(hclass);
1375                 sv_free((SV *) hclass);
1376         }
1377
1378         if (cxt->hook) {
1379                 HV *hook = cxt->hook;
1380                 cxt->hook = 0;
1381                 hv_undef(hook);
1382                 sv_free((SV *) hook);
1383         }
1384
1385         if (cxt->hook_seen) {
1386                 AV *hook_seen = cxt->hook_seen;
1387                 cxt->hook_seen = 0;
1388                 av_undef(hook_seen);
1389                 sv_free((SV *) hook_seen);
1390         }
1391
1392         cxt->forgive_me = -1;                   /* Fetched from perl if needed */
1393         cxt->deparse = -1;                              /* Idem */
1394         if (cxt->eval) {
1395             SvREFCNT_dec(cxt->eval);
1396         }
1397         cxt->eval = NULL;                               /* Idem */
1398         cxt->canonical = -1;                    /* Idem */
1399
1400         reset_context(cxt);
1401 }
1402
1403 /*
1404  * init_retrieve_context
1405  *
1406  * Initialize a new retrieve context for real recursion.
1407  */
1408 static void init_retrieve_context(pTHX_ stcxt_t *cxt, int optype, int is_tainted)
1409 {
1410         TRACEME(("init_retrieve_context"));
1411
1412         /*
1413          * The hook hash table is used to keep track of the references on
1414          * the STORABLE_thaw hook routines, when found in some class name.
1415          *
1416          * It is assumed that the inheritance tree will not be changed during
1417          * storing, and that no new method will be dynamically created by the
1418          * hooks.
1419          */
1420
1421         cxt->hook  = newHV();                   /* Caches STORABLE_thaw */
1422
1423 #ifdef USE_PTR_TABLE
1424         cxt->pseen = 0;
1425 #endif
1426
1427         /*
1428          * If retrieving an old binary version, the cxt->retrieve_vtbl variable
1429          * was set to sv_old_retrieve. We'll need a hash table to keep track of
1430          * the correspondence between the tags and the tag number used by the
1431          * new retrieve routines.
1432          */
1433
1434         cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve)
1435                       ? newHV() : 0);
1436
1437         cxt->aseen = newAV();                   /* Where retrieved objects are kept */
1438         cxt->where_is_undef = -1;               /* Special case for PL_sv_undef */
1439         cxt->aclass = newAV();                  /* Where seen classnames are kept */
1440         cxt->tagnum = 0;                                /* Have to count objects... */
1441         cxt->classnum = 0;                              /* ...and class names as well */
1442         cxt->optype = optype;
1443         cxt->s_tainted = is_tainted;
1444         cxt->entry = 1;                                 /* No recursion yet */
1445 #ifndef HAS_RESTRICTED_HASHES
1446         cxt->derestrict = -1;           /* Fetched from perl if needed */
1447 #endif
1448 #ifndef HAS_UTF8_ALL
1449         cxt->use_bytes = -1;            /* Fetched from perl if needed */
1450 #endif
1451         cxt->accept_future_minor = -1;  /* Fetched from perl if needed */
1452         cxt->in_retrieve_overloaded = 0;
1453 }
1454
1455 /*
1456  * clean_retrieve_context
1457  *
1458  * Clean retrieve context by
1459  */
1460 static void clean_retrieve_context(pTHX_ stcxt_t *cxt)
1461 {
1462         TRACEME(("clean_retrieve_context"));
1463
1464         ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
1465
1466         if (cxt->aseen) {
1467                 AV *aseen = cxt->aseen;
1468                 cxt->aseen = 0;
1469                 av_undef(aseen);
1470                 sv_free((SV *) aseen);
1471         }
1472         cxt->where_is_undef = -1;
1473
1474         if (cxt->aclass) {
1475                 AV *aclass = cxt->aclass;
1476                 cxt->aclass = 0;
1477                 av_undef(aclass);
1478                 sv_free((SV *) aclass);
1479         }
1480
1481         if (cxt->hook) {
1482                 HV *hook = cxt->hook;
1483                 cxt->hook = 0;
1484                 hv_undef(hook);
1485                 sv_free((SV *) hook);
1486         }
1487
1488         if (cxt->hseen) {
1489                 HV *hseen = cxt->hseen;
1490                 cxt->hseen = 0;
1491                 hv_undef(hseen);
1492                 sv_free((SV *) hseen);          /* optional HV, for backward compat. */
1493         }
1494
1495 #ifndef HAS_RESTRICTED_HASHES
1496         cxt->derestrict = -1;           /* Fetched from perl if needed */
1497 #endif
1498 #ifndef HAS_UTF8_ALL
1499         cxt->use_bytes = -1;            /* Fetched from perl if needed */
1500 #endif
1501         cxt->accept_future_minor = -1;  /* Fetched from perl if needed */
1502
1503         cxt->in_retrieve_overloaded = 0;
1504         reset_context(cxt);
1505 }
1506
1507 /*
1508  * clean_context
1509  *
1510  * A workaround for the CROAK bug: cleanup the last context.
1511  */
1512 static void clean_context(pTHX_ stcxt_t *cxt)
1513 {
1514         TRACEME(("clean_context"));
1515
1516         ASSERT(cxt->s_dirty, ("dirty context"));
1517
1518         if (cxt->membuf_ro)
1519                 MBUF_RESTORE();
1520
1521         ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
1522
1523         if (cxt->optype & ST_RETRIEVE)
1524                 clean_retrieve_context(aTHX_ cxt);
1525         else if (cxt->optype & ST_STORE)
1526                 clean_store_context(aTHX_ cxt);
1527         else
1528                 reset_context(cxt);
1529
1530         ASSERT(!cxt->s_dirty, ("context is clean"));
1531         ASSERT(cxt->entry == 0, ("context is reset"));
1532 }
1533
1534 /*
1535  * allocate_context
1536  *
1537  * Allocate a new context and push it on top of the parent one.
1538  * This new context is made globally visible via SET_STCXT().
1539  */
1540 static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt)
1541 {
1542         stcxt_t *cxt;
1543
1544         TRACEME(("allocate_context"));
1545
1546         ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
1547
1548         NEW_STORABLE_CXT_OBJ(cxt);
1549         cxt->prev = parent_cxt->my_sv;
1550         SET_STCXT(cxt);
1551
1552         ASSERT(!cxt->s_dirty, ("clean context"));
1553
1554         return cxt;
1555 }
1556
1557 /*
1558  * free_context
1559  *
1560  * Free current context, which cannot be the "root" one.
1561  * Make the context underneath globally visible via SET_STCXT().
1562  */
1563 static void free_context(pTHX_ stcxt_t *cxt)
1564 {
1565         stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0);
1566
1567         TRACEME(("free_context"));
1568
1569         ASSERT(!cxt->s_dirty, ("clean context"));
1570         ASSERT(prev, ("not freeing root context"));
1571
1572         SvREFCNT_dec(cxt->my_sv);
1573         SET_STCXT(prev);
1574
1575         ASSERT(cxt, ("context not void"));
1576 }
1577
1578 /***
1579  *** Predicates.
1580  ***/
1581
1582 /*
1583  * is_storing
1584  *
1585  * Tells whether we're in the middle of a store operation.
1586  */
1587 static int is_storing(pTHX)
1588 {
1589         dSTCXT;
1590
1591         return cxt->entry && (cxt->optype & ST_STORE);
1592 }
1593
1594 /*
1595  * is_retrieving
1596  *
1597  * Tells whether we're in the middle of a retrieve operation.
1598  */
1599 static int is_retrieving(pTHX)
1600 {
1601         dSTCXT;
1602
1603         return cxt->entry && (cxt->optype & ST_RETRIEVE);
1604 }
1605
1606 /*
1607  * last_op_in_netorder
1608  *
1609  * Returns whether last operation was made using network order.
1610  *
1611  * This is typically out-of-band information that might prove useful
1612  * to people wishing to convert native to network order data when used.
1613  */
1614 static int last_op_in_netorder(pTHX)
1615 {
1616         dSTCXT;
1617
1618         return cxt->netorder;
1619 }
1620
1621 /***
1622  *** Hook lookup and calling routines.
1623  ***/
1624
1625 /*
1626  * pkg_fetchmeth
1627  *
1628  * A wrapper on gv_fetchmethod_autoload() which caches results.
1629  *
1630  * Returns the routine reference as an SV*, or null if neither the package
1631  * nor its ancestors know about the method.
1632  */
1633 static SV *pkg_fetchmeth(
1634         pTHX_
1635         HV *cache,
1636         HV *pkg,
1637         const char *method)
1638 {
1639         GV *gv;
1640         SV *sv;
1641         const char *hvname = HvNAME_get(pkg);
1642
1643
1644         /*
1645          * The following code is the same as the one performed by UNIVERSAL::can
1646          * in the Perl core.
1647          */
1648
1649         gv = gv_fetchmethod_autoload(pkg, method, FALSE);
1650         if (gv && isGV(gv)) {
1651                 sv = newRV((SV*) GvCV(gv));
1652                 TRACEME(("%s->%s: 0x%"UVxf, hvname, method, PTR2UV(sv)));
1653         } else {
1654                 sv = newSVsv(&PL_sv_undef);
1655                 TRACEME(("%s->%s: not found", hvname, method));
1656         }
1657
1658         /*
1659          * Cache the result, ignoring failure: if we can't store the value,
1660          * it just won't be cached.
1661          */
1662
1663         (void) hv_store(cache, hvname, strlen(hvname), sv, 0);
1664
1665         return SvOK(sv) ? sv : (SV *) 0;
1666 }
1667
1668 /*
1669  * pkg_hide
1670  *
1671  * Force cached value to be undef: hook ignored even if present.
1672  */
1673 static void pkg_hide(
1674         pTHX_
1675         HV *cache,
1676         HV *pkg,
1677         const char *method)
1678 {
1679         const char *hvname = HvNAME_get(pkg);
1680         PERL_UNUSED_ARG(method);
1681         (void) hv_store(cache,
1682                 hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0);
1683 }
1684
1685 /*
1686  * pkg_uncache
1687  *
1688  * Discard cached value: a whole fetch loop will be retried at next lookup.
1689  */
1690 static void pkg_uncache(
1691         pTHX_
1692         HV *cache,
1693         HV *pkg,
1694         const char *method)
1695 {
1696         const char *hvname = HvNAME_get(pkg);
1697         PERL_UNUSED_ARG(method);
1698         (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
1699 }
1700
1701 /*
1702  * pkg_can
1703  *
1704  * Our own "UNIVERSAL::can", which caches results.
1705  *
1706  * Returns the routine reference as an SV*, or null if the object does not
1707  * know about the method.
1708  */
1709 static SV *pkg_can(
1710         pTHX_
1711         HV *cache,
1712         HV *pkg,
1713         const char *method)
1714 {
1715         SV **svh;
1716         SV *sv;
1717         const char *hvname = HvNAME_get(pkg);
1718
1719         TRACEME(("pkg_can for %s->%s", hvname, method));
1720
1721         /*
1722          * Look into the cache to see whether we already have determined
1723          * where the routine was, if any.
1724          *
1725          * NOTA BENE: we don't use `method' at all in our lookup, since we know
1726          * that only one hook (i.e. always the same) is cached in a given cache.
1727          */
1728
1729         svh = hv_fetch(cache, hvname, strlen(hvname), FALSE);
1730         if (svh) {
1731                 sv = *svh;
1732                 if (!SvOK(sv)) {
1733                         TRACEME(("cached %s->%s: not found", hvname, method));
1734                         return (SV *) 0;
1735                 } else {
1736                         TRACEME(("cached %s->%s: 0x%"UVxf,
1737                                 hvname, method, PTR2UV(sv)));
1738                         return sv;
1739                 }
1740         }
1741
1742         TRACEME(("not cached yet"));
1743         return pkg_fetchmeth(aTHX_ cache, pkg, method);         /* Fetch and cache */
1744 }
1745
1746 /*
1747  * scalar_call
1748  *
1749  * Call routine as obj->hook(av) in scalar context.
1750  * Propagates the single returned value if not called in void context.
1751  */
1752 static SV *scalar_call(
1753         pTHX_
1754         SV *obj,
1755         SV *hook,
1756         int cloning,
1757         AV *av,
1758         I32 flags)
1759 {
1760         dSP;
1761         int count;
1762         SV *sv = 0;
1763
1764         TRACEME(("scalar_call (cloning=%d)", cloning));
1765
1766         ENTER;
1767         SAVETMPS;
1768
1769         PUSHMARK(sp);
1770         XPUSHs(obj);
1771         XPUSHs(sv_2mortal(newSViv(cloning)));           /* Cloning flag */
1772         if (av) {
1773                 SV **ary = AvARRAY(av);
1774                 int cnt = AvFILLp(av) + 1;
1775                 int i;
1776                 XPUSHs(ary[0]);                                                 /* Frozen string */
1777                 for (i = 1; i < cnt; i++) {
1778                         TRACEME(("pushing arg #%d (0x%"UVxf")...",
1779                                  i, PTR2UV(ary[i])));
1780                         XPUSHs(sv_2mortal(newRV(ary[i])));
1781                 }
1782         }
1783         PUTBACK;
1784
1785         TRACEME(("calling..."));
1786         count = perl_call_sv(hook, flags);              /* Go back to Perl code */
1787         TRACEME(("count = %d", count));
1788
1789         SPAGAIN;
1790
1791         if (count) {
1792                 sv = POPs;
1793                 SvREFCNT_inc(sv);               /* We're returning it, must stay alive! */
1794         }
1795
1796         PUTBACK;
1797         FREETMPS;
1798         LEAVE;
1799
1800         return sv;
1801 }
1802
1803 /*
1804  * array_call
1805  *
1806  * Call routine obj->hook(cloning) in list context.
1807  * Returns the list of returned values in an array.
1808  */
1809 static AV *array_call(
1810         pTHX_
1811         SV *obj,
1812         SV *hook,
1813         int cloning)
1814 {
1815         dSP;
1816         int count;
1817         AV *av;
1818         int i;
1819
1820         TRACEME(("array_call (cloning=%d)", cloning));
1821
1822         ENTER;
1823         SAVETMPS;
1824
1825         PUSHMARK(sp);
1826         XPUSHs(obj);                                                            /* Target object */
1827         XPUSHs(sv_2mortal(newSViv(cloning)));           /* Cloning flag */
1828         PUTBACK;
1829
1830         count = perl_call_sv(hook, G_ARRAY);            /* Go back to Perl code */
1831
1832         SPAGAIN;
1833
1834         av = newAV();
1835         for (i = count - 1; i >= 0; i--) {
1836                 SV *sv = POPs;
1837                 av_store(av, i, SvREFCNT_inc(sv));
1838         }
1839
1840         PUTBACK;
1841         FREETMPS;
1842         LEAVE;
1843
1844         return av;
1845 }
1846
1847 /*
1848  * known_class
1849  *
1850  * Lookup the class name in the `hclass' table and either assign it a new ID
1851  * or return the existing one, by filling in `classnum'.
1852  *
1853  * Return true if the class was known, false if the ID was just generated.
1854  */
1855 static int known_class(
1856         pTHX_
1857         stcxt_t *cxt,
1858         char *name,             /* Class name */
1859         int len,                /* Name length */
1860         I32 *classnum)
1861 {
1862         SV **svh;
1863         HV *hclass = cxt->hclass;
1864
1865         TRACEME(("known_class (%s)", name));
1866
1867         /*
1868          * Recall that we don't store pointers in this hash table, but tags.
1869          * Therefore, we need LOW_32BITS() to extract the relevant parts.
1870          */
1871
1872         svh = hv_fetch(hclass, name, len, FALSE);
1873         if (svh) {
1874                 *classnum = LOW_32BITS(*svh);
1875                 return TRUE;
1876         }
1877
1878         /*
1879          * Unknown classname, we need to record it.
1880          */
1881
1882         cxt->classnum++;
1883         if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0))
1884                 CROAK(("Unable to record new classname"));
1885
1886         *classnum = cxt->classnum;
1887         return FALSE;
1888 }
1889
1890 /***
1891  *** Specific store routines.
1892  ***/
1893
1894 /*
1895  * store_ref
1896  *
1897  * Store a reference.
1898  * Layout is SX_REF <object> or SX_OVERLOAD <object>.
1899  */
1900 static int store_ref(pTHX_ stcxt_t *cxt, SV *sv)
1901 {
1902         int is_weak = 0;
1903         TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv)));
1904
1905         /*
1906          * Follow reference, and check if target is overloaded.
1907          */
1908
1909 #ifdef SvWEAKREF
1910         if (SvWEAKREF(sv))
1911                 is_weak = 1;
1912         TRACEME(("ref (0x%"UVxf") is%s weak", PTR2UV(sv), is_weak ? "" : "n't"));
1913 #endif
1914         sv = SvRV(sv);
1915
1916         if (SvOBJECT(sv)) {
1917                 HV *stash = (HV *) SvSTASH(sv);
1918                 if (stash && Gv_AMG(stash)) {
1919                         TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv)));
1920                         PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD);
1921                 } else
1922                         PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
1923         } else
1924                 PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
1925
1926         return store(aTHX_ cxt, sv);
1927 }
1928
1929 /*
1930  * store_scalar
1931  *
1932  * Store a scalar.
1933  *
1934  * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
1935  * The <data> section is omitted if <length> is 0.
1936  *
1937  * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
1938  * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
1939  */
1940 static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
1941 {
1942         IV iv;
1943         char *pv;
1944         STRLEN len;
1945         U32 flags = SvFLAGS(sv);                        /* "cc -O" may put it in register */
1946
1947         TRACEME(("store_scalar (0x%"UVxf")", PTR2UV(sv)));
1948
1949         /*
1950          * For efficiency, break the SV encapsulation by peaking at the flags
1951          * directly without using the Perl macros to avoid dereferencing
1952          * sv->sv_flags each time we wish to check the flags.
1953          */
1954
1955         if (!(flags & SVf_OK)) {                        /* !SvOK(sv) */
1956                 if (sv == &PL_sv_undef) {
1957                         TRACEME(("immortal undef"));
1958                         PUTMARK(SX_SV_UNDEF);
1959                 } else {
1960                         TRACEME(("undef at 0x%"UVxf, PTR2UV(sv)));
1961                         PUTMARK(SX_UNDEF);
1962                 }
1963                 return 0;
1964         }
1965
1966         /*
1967          * Always store the string representation of a scalar if it exists.
1968          * Gisle Aas provided me with this test case, better than a long speach:
1969          *
1970          *  perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)'
1971          *  SV = PVNV(0x80c8520)
1972          *       REFCNT = 1
1973          *       FLAGS = (NOK,POK,pNOK,pPOK)
1974          *       IV = 0
1975          *       NV = 0
1976          *       PV = 0x80c83d0 "abc"\0
1977          *       CUR = 3
1978          *       LEN = 4
1979          *
1980          * Write SX_SCALAR, length, followed by the actual data.
1981          *
1982          * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as
1983          * appropriate, followed by the actual (binary) data. A double
1984          * is written as a string if network order, for portability.
1985          *
1986          * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv).
1987          * The reason is that when the scalar value is tainted, the SvNOK(sv)
1988          * value is false.
1989          *
1990          * The test for a read-only scalar with both POK and NOK set is meant
1991          * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the
1992          * address comparison for each scalar we store.
1993          */
1994
1995 #define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK)
1996
1997         if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) {
1998                 if (sv == &PL_sv_yes) {
1999                         TRACEME(("immortal yes"));
2000                         PUTMARK(SX_SV_YES);
2001                 } else if (sv == &PL_sv_no) {
2002                         TRACEME(("immortal no"));
2003                         PUTMARK(SX_SV_NO);
2004                 } else {
2005                         pv = SvPV(sv, len);                     /* We know it's SvPOK */
2006                         goto string;                            /* Share code below */
2007                 }
2008         } else if (flags & SVf_POK) {
2009             /* public string - go direct to string read.  */
2010             goto string_readlen;
2011         } else if (
2012 #if (PATCHLEVEL <= 6)
2013             /* For 5.6 and earlier NV flag trumps IV flag, so only use integer
2014                direct if NV flag is off.  */
2015             (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK
2016 #else
2017             /* 5.7 rules are that if IV public flag is set, IV value is as
2018                good, if not better, than NV value.  */
2019             flags & SVf_IOK
2020 #endif
2021             ) {
2022             iv = SvIV(sv);
2023             /*
2024              * Will come here from below with iv set if double is an integer.
2025              */
2026           integer:
2027
2028             /* Sorry. This isn't in 5.005_56 (IIRC) or earlier.  */
2029 #ifdef SVf_IVisUV
2030             /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1
2031              * (for example) and that ends up in the optimised small integer
2032              * case.
2033              */
2034             if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) {
2035                 TRACEME(("large unsigned integer as string, value = %"UVuf, SvUV(sv)));
2036                 goto string_readlen;
2037             }
2038 #endif
2039             /*
2040              * Optimize small integers into a single byte, otherwise store as
2041              * a real integer (converted into network order if they asked).
2042              */
2043
2044             if (iv >= -128 && iv <= 127) {
2045                 unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
2046                 PUTMARK(SX_BYTE);
2047                 PUTMARK(siv);
2048                 TRACEME(("small integer stored as %d", siv));
2049             } else if (cxt->netorder) {
2050 #ifndef HAS_HTONL
2051                 TRACEME(("no htonl, fall back to string for integer"));
2052                 goto string_readlen;
2053 #else
2054                 I32 niv;
2055
2056
2057 #if IVSIZE > 4
2058                 if (
2059 #ifdef SVf_IVisUV
2060                     /* Sorry. This isn't in 5.005_56 (IIRC) or earlier.  */
2061                     ((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) ||
2062 #endif
2063                     (iv > (IV)0x7FFFFFFF) || (iv < -(IV)0x80000000)) {
2064                     /* Bigger than 32 bits.  */
2065                     TRACEME(("large network order integer as string, value = %"IVdf, iv));
2066                     goto string_readlen;
2067                 }
2068 #endif
2069
2070                 niv = (I32) htonl((I32) iv);
2071                 TRACEME(("using network order"));
2072                 PUTMARK(SX_NETINT);
2073                 WRITE_I32(niv);
2074 #endif
2075             } else {
2076                 PUTMARK(SX_INTEGER);
2077                 WRITE(&iv, sizeof(iv));
2078             }
2079
2080             TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
2081         } else if (flags & SVf_NOK) {
2082             NV nv;
2083 #if (PATCHLEVEL <= 6)
2084             nv = SvNV(sv);
2085             /*
2086              * Watch for number being an integer in disguise.
2087              */
2088             if (nv == (NV) (iv = I_V(nv))) {
2089                 TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv));
2090                 goto integer;           /* Share code above */
2091             }
2092 #else
2093
2094             SvIV_please(sv);
2095             if (SvIOK_notUV(sv)) {
2096                 iv = SvIV(sv);
2097                 goto integer;           /* Share code above */
2098             }
2099             nv = SvNV(sv);
2100 #endif
2101
2102             if (cxt->netorder) {
2103                 TRACEME(("double %"NVff" stored as string", nv));
2104                 goto string_readlen;            /* Share code below */
2105             }
2106
2107             PUTMARK(SX_DOUBLE);
2108             WRITE(&nv, sizeof(nv));
2109
2110             TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
2111
2112         } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) {
2113             I32 wlen; /* For 64-bit machines */
2114
2115           string_readlen:
2116             pv = SvPV(sv, len);
2117
2118             /*
2119              * Will come here from above  if it was readonly, POK and NOK but
2120              * neither &PL_sv_yes nor &PL_sv_no.
2121              */
2122           string:
2123
2124             wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
2125             if (SvUTF8 (sv))
2126                 STORE_UTF8STR(pv, wlen);
2127             else
2128                 STORE_SCALAR(pv, wlen);
2129             TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
2130                      PTR2UV(sv), SvPVX(sv), (IV)len));
2131         } else
2132             CROAK(("Can't determine type of %s(0x%"UVxf")",
2133                    sv_reftype(sv, FALSE),
2134                    PTR2UV(sv)));
2135         return 0;               /* Ok, no recursion on scalars */
2136 }
2137
2138 /*
2139  * store_array
2140  *
2141  * Store an array.
2142  *
2143  * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
2144  * Each item is stored as <object>.
2145  */
2146 static int store_array(pTHX_ stcxt_t *cxt, AV *av)
2147 {
2148         SV **sav;
2149         I32 len = av_len(av) + 1;
2150         I32 i;
2151         int ret;
2152
2153         TRACEME(("store_array (0x%"UVxf")", PTR2UV(av)));
2154
2155         /*
2156          * Signal array by emitting SX_ARRAY, followed by the array length.
2157          */
2158
2159         PUTMARK(SX_ARRAY);
2160         WLEN(len);
2161         TRACEME(("size = %d", len));
2162
2163         /*
2164          * Now store each item recursively.
2165          */
2166
2167         for (i = 0; i < len; i++) {
2168                 sav = av_fetch(av, i, 0);
2169                 if (!sav) {
2170                         TRACEME(("(#%d) undef item", i));
2171                         STORE_SV_UNDEF();
2172                         continue;
2173                 }
2174                 TRACEME(("(#%d) item", i));
2175                 if ((ret = store(aTHX_ cxt, *sav)))     /* Extra () for -Wall, grr... */
2176                         return ret;
2177         }
2178
2179         TRACEME(("ok (array)"));
2180
2181         return 0;
2182 }
2183
2184
2185 #if (PATCHLEVEL <= 6)
2186
2187 /*
2188  * sortcmp
2189  *
2190  * Sort two SVs
2191  * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
2192  */
2193 static int
2194 sortcmp(const void *a, const void *b)
2195 {
2196 #if defined(USE_ITHREADS)
2197         dTHX;
2198 #endif /* USE_ITHREADS */
2199         return sv_cmp(*(SV * const *) a, *(SV * const *) b);
2200 }
2201
2202 #endif /* PATCHLEVEL <= 6 */
2203
2204 /*
2205  * store_hash
2206  *
2207  * Store a hash table.
2208  *
2209  * For a "normal" hash (not restricted, no utf8 keys):
2210  *
2211  * Layout is SX_HASH <size> followed by each key/value pair, in random order.
2212  * Values are stored as <object>.
2213  * Keys are stored as <length> <data>, the <data> section being omitted
2214  * if length is 0.
2215  *
2216  * For a "fancy" hash (restricted or utf8 keys):
2217  *
2218  * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair,
2219  * in random order.
2220  * Values are stored as <object>.
2221  * Keys are stored as <flags> <length> <data>, the <data> section being omitted
2222  * if length is 0.
2223  * Currently the only hash flag is "restricted"
2224  * Key flags are as for hv.h
2225  */
2226 static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
2227 {
2228         dVAR;
2229         I32 len = HvTOTALKEYS(hv);
2230         I32 i;
2231         int ret = 0;
2232         I32 riter;
2233         HE *eiter;
2234         int flagged_hash = ((SvREADONLY(hv)
2235 #ifdef HAS_HASH_KEY_FLAGS
2236                              || HvHASKFLAGS(hv)
2237 #endif
2238                                 ) ? 1 : 0);
2239         unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
2240
2241         if (flagged_hash) {
2242             /* needs int cast for C++ compilers, doesn't it?  */
2243             TRACEME(("store_hash (0x%"UVxf") (flags %x)", PTR2UV(hv),
2244                      (int) hash_flags));
2245         } else {
2246             TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv)));
2247         }
2248
2249         /*
2250          * Signal hash by emitting SX_HASH, followed by the table length.
2251          */
2252
2253         if (flagged_hash) {
2254             PUTMARK(SX_FLAG_HASH);
2255             PUTMARK(hash_flags);
2256         } else {
2257             PUTMARK(SX_HASH);
2258         }
2259         WLEN(len);
2260         TRACEME(("size = %d", len));
2261
2262         /*
2263          * Save possible iteration state via each() on that table.
2264          */
2265
2266         riter = HvRITER_get(hv);
2267         eiter = HvEITER_get(hv);
2268         hv_iterinit(hv);
2269
2270         /*
2271          * Now store each item recursively.
2272          *
2273      * If canonical is defined to some true value then store each
2274      * key/value pair in sorted order otherwise the order is random.
2275          * Canonical order is irrelevant when a deep clone operation is performed.
2276          *
2277          * Fetch the value from perl only once per store() operation, and only
2278          * when needed.
2279          */
2280
2281         if (
2282                 !(cxt->optype & ST_CLONE) && (cxt->canonical == 1 ||
2283                 (cxt->canonical < 0 && (cxt->canonical =
2284                         (SvTRUE(perl_get_sv("Storable::canonical", GV_ADD)) ? 1 : 0))))
2285         ) {
2286                 /*
2287                  * Storing in order, sorted by key.
2288                  * Run through the hash, building up an array of keys in a
2289                  * mortal array, sort the array and then run through the
2290                  * array.
2291                  */
2292
2293                 AV *av = newAV();
2294
2295                 /*av_extend (av, len);*/
2296
2297                 TRACEME(("using canonical order"));
2298
2299                 for (i = 0; i < len; i++) {
2300 #ifdef HAS_RESTRICTED_HASHES
2301                         HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
2302 #else
2303                         HE *he = hv_iternext(hv);
2304 #endif
2305                         SV *key;
2306
2307                         if (!he)
2308                                 CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, (int)len, (int)i));
2309                         key = hv_iterkeysv(he);
2310                         av_store(av, AvFILLp(av)+1, key);       /* av_push(), really */
2311                 }
2312
2313                 STORE_HASH_SORT;
2314
2315                 for (i = 0; i < len; i++) {
2316 #ifdef HAS_RESTRICTED_HASHES
2317                         int placeholders = (int)HvPLACEHOLDERS_get(hv);
2318 #endif
2319                         unsigned char flags = 0;
2320                         char *keyval;
2321                         STRLEN keylen_tmp;
2322                         I32 keylen;
2323                         SV *key = av_shift(av);
2324                         /* This will fail if key is a placeholder.
2325                            Track how many placeholders we have, and error if we
2326                            "see" too many.  */
2327                         HE *he  = hv_fetch_ent(hv, key, 0, 0);
2328                         SV *val;
2329
2330                         if (he) {
2331                                 if (!(val =  HeVAL(he))) {
2332                                         /* Internal error, not I/O error */
2333                                         return 1;
2334                                 }
2335                         } else {
2336 #ifdef HAS_RESTRICTED_HASHES
2337                                 /* Should be a placeholder.  */
2338                                 if (placeholders-- < 0) {
2339                                         /* This should not happen - number of
2340                                            retrieves should be identical to
2341                                            number of placeholders.  */
2342                                         return 1;
2343                                 }
2344                                 /* Value is never needed, and PL_sv_undef is
2345                                    more space efficient to store.  */
2346                                 val = &PL_sv_undef;
2347                                 ASSERT (flags == 0,
2348                                         ("Flags not 0 but %d", flags));
2349                                 flags = SHV_K_PLACEHOLDER;
2350 #else
2351                                 return 1;
2352 #endif
2353                         }
2354
2355                         /*
2356                          * Store value first.
2357                          */
2358
2359                         TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
2360
2361                         if ((ret = store(aTHX_ cxt, val)))      /* Extra () for -Wall, grr... */
2362                                 goto out;
2363
2364                         /*
2365                          * Write key string.
2366                          * Keys are written after values to make sure retrieval
2367                          * can be optimal in terms of memory usage, where keys are
2368                          * read into a fixed unique buffer called kbuf.
2369                          * See retrieve_hash() for details.
2370                          */
2371
2372                         /* Implementation of restricted hashes isn't nicely
2373                            abstracted:  */
2374                         if ((hash_flags & SHV_RESTRICTED)
2375                          && SvREADONLY(val) && !SvIsCOW(val)) {
2376                                 flags |= SHV_K_LOCKED;
2377                         }
2378
2379                         keyval = SvPV(key, keylen_tmp);
2380                         keylen = keylen_tmp;
2381 #ifdef HAS_UTF8_HASHES
2382                         /* If you build without optimisation on pre 5.6
2383                            then nothing spots that SvUTF8(key) is always 0,
2384                            so the block isn't optimised away, at which point
2385                            the linker dislikes the reference to
2386                            bytes_from_utf8.  */
2387                         if (SvUTF8(key)) {
2388                             const char *keysave = keyval;
2389                             bool is_utf8 = TRUE;
2390
2391                             /* Just casting the &klen to (STRLEN) won't work
2392                                well if STRLEN and I32 are of different widths.
2393                                --jhi */
2394                             keyval = (char*)bytes_from_utf8((U8*)keyval,
2395                                                             &keylen_tmp,
2396                                                             &is_utf8);
2397
2398                             /* If we were able to downgrade here, then than
2399                                means that we have  a key which only had chars
2400                                0-255, but was utf8 encoded.  */
2401
2402                             if (keyval != keysave) {
2403                                 keylen = keylen_tmp;
2404                                 flags |= SHV_K_WASUTF8;
2405                             } else {
2406                                 /* keylen_tmp can't have changed, so no need
2407                                    to assign back to keylen.  */
2408                                 flags |= SHV_K_UTF8;
2409                             }
2410                         }
2411 #endif
2412
2413                         if (flagged_hash) {
2414                             PUTMARK(flags);
2415                             TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval));
2416                         } else {
2417                             /* This is a workaround for a bug in 5.8.0
2418                                that causes the HEK_WASUTF8 flag to be
2419                                set on an HEK without the hash being
2420                                marked as having key flags. We just
2421                                cross our fingers and drop the flag.
2422                                AMS 20030901 */
2423                             assert (flags == 0 || flags == SHV_K_WASUTF8);
2424                             TRACEME(("(#%d) key '%s'", i, keyval));
2425                         }
2426                         WLEN(keylen);
2427                         if (keylen)
2428                                 WRITE(keyval, keylen);
2429                         if (flags & SHV_K_WASUTF8)
2430                             Safefree (keyval);
2431                 }
2432
2433                 /*
2434                  * Free up the temporary array
2435                  */
2436
2437                 av_undef(av);
2438                 sv_free((SV *) av);
2439
2440         } else {
2441
2442                 /*
2443                  * Storing in "random" order (in the order the keys are stored
2444                  * within the hash).  This is the default and will be faster!
2445                  */
2446
2447                 for (i = 0; i < len; i++) {
2448                         char *key = 0;
2449                         I32 len;
2450                         unsigned char flags;
2451 #ifdef HV_ITERNEXT_WANTPLACEHOLDERS
2452                         HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
2453 #else
2454                         HE *he = hv_iternext(hv);
2455 #endif
2456                         SV *val = (he ? hv_iterval(hv, he) : 0);
2457                         SV *key_sv = NULL;
2458                         HEK *hek;
2459
2460                         if (val == 0)
2461                                 return 1;               /* Internal error, not I/O error */
2462
2463                         /* Implementation of restricted hashes isn't nicely
2464                            abstracted:  */
2465                         flags
2466                             = (((hash_flags & SHV_RESTRICTED)
2467                                 && SvREADONLY(val) && !SvIsCOW(val))
2468                                              ? SHV_K_LOCKED : 0);
2469
2470                         if (val == &PL_sv_placeholder) {
2471                             flags |= SHV_K_PLACEHOLDER;
2472                             val = &PL_sv_undef;
2473                         }
2474
2475                         /*
2476                          * Store value first.
2477                          */
2478
2479                         TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
2480
2481                         if ((ret = store(aTHX_ cxt, val)))      /* Extra () for -Wall, grr... */
2482                                 goto out;
2483
2484
2485                         hek = HeKEY_hek(he);
2486                         len = HEK_LEN(hek);
2487                         if (len == HEf_SVKEY) {
2488                             /* This is somewhat sick, but the internal APIs are
2489                              * such that XS code could put one of these in in
2490                              * a regular hash.
2491                              * Maybe we should be capable of storing one if
2492                              * found.
2493                              */
2494                             key_sv = HeKEY_sv(he);
2495                             flags |= SHV_K_ISSV;
2496                         } else {
2497                             /* Regular string key. */
2498 #ifdef HAS_HASH_KEY_FLAGS
2499                             if (HEK_UTF8(hek))
2500                                 flags |= SHV_K_UTF8;
2501                             if (HEK_WASUTF8(hek))
2502                                 flags |= SHV_K_WASUTF8;
2503 #endif
2504                             key = HEK_KEY(hek);
2505                         }
2506                         /*
2507                          * Write key string.
2508                          * Keys are written after values to make sure retrieval
2509                          * can be optimal in terms of memory usage, where keys are
2510                          * read into a fixed unique buffer called kbuf.
2511                          * See retrieve_hash() for details.
2512                          */
2513
2514                         if (flagged_hash) {
2515                             PUTMARK(flags);
2516                             TRACEME(("(#%d) key '%s' flags %x", i, key, flags));
2517                         } else {
2518                             /* This is a workaround for a bug in 5.8.0
2519                                that causes the HEK_WASUTF8 flag to be
2520                                set on an HEK without the hash being
2521                                marked as having key flags. We just
2522                                cross our fingers and drop the flag.
2523                                AMS 20030901 */
2524                             assert (flags == 0 || flags == SHV_K_WASUTF8);
2525                             TRACEME(("(#%d) key '%s'", i, key));
2526                         }
2527                         if (flags & SHV_K_ISSV) {
2528                             store(aTHX_ cxt, key_sv);
2529                         } else {
2530                             WLEN(len);
2531                             if (len)
2532                                 WRITE(key, len);
2533                         }
2534                 }
2535     }
2536
2537         TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv)));
2538
2539 out:
2540         HvRITER_set(hv, riter);         /* Restore hash iterator state */
2541         HvEITER_set(hv, eiter);
2542
2543         return ret;
2544 }
2545
2546 /*
2547  * store_code
2548  *
2549  * Store a code reference.
2550  *
2551  * Layout is SX_CODE <length> followed by a scalar containing the perl
2552  * source code of the code reference.
2553  */
2554 static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
2555 {
2556 #if PERL_VERSION < 6
2557     /*
2558          * retrieve_code does not work with perl 5.005 or less
2559          */
2560         return store_other(aTHX_ cxt, (SV*)cv);
2561 #else
2562         dSP;
2563         I32 len;
2564         int count, reallen;
2565         SV *text, *bdeparse;
2566
2567         TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv)));
2568
2569         if (
2570                 cxt->deparse == 0 ||
2571                 (cxt->deparse < 0 && !(cxt->deparse =
2572                         SvTRUE(perl_get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0))
2573         ) {
2574                 return store_other(aTHX_ cxt, (SV*)cv);
2575         }
2576
2577         /*
2578          * Require B::Deparse. At least B::Deparse 0.61 is needed for
2579          * blessed code references.
2580          */
2581         /* Ownership of both SVs is passed to load_module, which frees them. */
2582         load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61));
2583         SPAGAIN;
2584
2585         ENTER;
2586         SAVETMPS;
2587
2588         /*
2589          * create the B::Deparse object
2590          */
2591
2592         PUSHMARK(sp);
2593         XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP));
2594         PUTBACK;
2595         count = call_method("new", G_SCALAR);
2596         SPAGAIN;
2597         if (count != 1)
2598                 CROAK(("Unexpected return value from B::Deparse::new\n"));
2599         bdeparse = POPs;
2600
2601         /*
2602          * call the coderef2text method
2603          */
2604
2605         PUSHMARK(sp);
2606         XPUSHs(bdeparse); /* XXX is this already mortal? */
2607         XPUSHs(sv_2mortal(newRV_inc((SV*)cv)));
2608         PUTBACK;
2609         count = call_method("coderef2text", G_SCALAR);
2610         SPAGAIN;
2611         if (count != 1)
2612                 CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
2613
2614         text = POPs;
2615         len = SvCUR(text);
2616         reallen = strlen(SvPV_nolen(text));
2617
2618         /*
2619          * Empty code references or XS functions are deparsed as
2620          * "(prototype) ;" or ";".
2621          */
2622
2623         if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') {
2624             CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
2625         }
2626
2627         /*
2628          * Signal code by emitting SX_CODE.
2629          */
2630
2631         PUTMARK(SX_CODE);
2632         cxt->tagnum++;   /* necessary, as SX_CODE is a SEEN() candidate */
2633         TRACEME(("size = %d", len));
2634         TRACEME(("code = %s", SvPV_nolen(text)));
2635
2636         /*
2637          * Now store the source code.
2638          */
2639
2640         if(SvUTF8 (text))
2641                 STORE_UTF8STR(SvPV_nolen(text), len);
2642         else
2643                 STORE_SCALAR(SvPV_nolen(text), len);
2644
2645         FREETMPS;
2646         LEAVE;
2647
2648         TRACEME(("ok (code)"));
2649
2650         return 0;
2651 #endif
2652 }
2653
2654 /*
2655  * store_tied
2656  *
2657  * When storing a tied object (be it a tied scalar, array or hash), we lay out
2658  * a special mark, followed by the underlying tied object. For instance, when
2659  * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
2660  * <hash object> stands for the serialization of the tied hash.
2661  */
2662 static int store_tied(pTHX_ stcxt_t *cxt, SV *sv)
2663 {
2664         MAGIC *mg;
2665         SV *obj = NULL;
2666         int ret = 0;
2667         int svt = SvTYPE(sv);
2668         char mtype = 'P';
2669
2670         TRACEME(("store_tied (0x%"UVxf")", PTR2UV(sv)));
2671
2672         /*
2673          * We have a small run-time penalty here because we chose to factorise
2674          * all tieds objects into the same routine, and not have a store_tied_hash,
2675          * a store_tied_array, etc...
2676          *
2677          * Don't use a switch() statement, as most compilers don't optimize that
2678          * well for 2/3 values. An if() else if() cascade is just fine. We put
2679          * tied hashes first, as they are the most likely beasts.
2680          */
2681
2682         if (svt == SVt_PVHV) {
2683                 TRACEME(("tied hash"));
2684                 PUTMARK(SX_TIED_HASH);                  /* Introduces tied hash */
2685         } else if (svt == SVt_PVAV) {
2686                 TRACEME(("tied array"));
2687                 PUTMARK(SX_TIED_ARRAY);                 /* Introduces tied array */
2688         } else {
2689                 TRACEME(("tied scalar"));
2690                 PUTMARK(SX_TIED_SCALAR);                /* Introduces tied scalar */
2691                 mtype = 'q';
2692         }
2693
2694         if (!(mg = mg_find(sv, mtype)))
2695                 CROAK(("No magic '%c' found while storing tied %s", mtype,
2696                         (svt == SVt_PVHV) ? "hash" :
2697                                 (svt == SVt_PVAV) ? "array" : "scalar"));
2698
2699         /*
2700          * The mg->mg_obj found by mg_find() above actually points to the
2701          * underlying tied Perl object implementation. For instance, if the
2702          * original SV was that of a tied array, then mg->mg_obj is an AV.
2703          *
2704          * Note that we store the Perl object as-is. We don't call its FETCH
2705          * method along the way. At retrieval time, we won't call its STORE
2706          * method either, but the tieing magic will be re-installed. In itself,
2707          * that ensures that the tieing semantics are preserved since further
2708          * accesses on the retrieved object will indeed call the magic methods...
2709          */
2710
2711         /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
2712         obj = mg->mg_obj ? mg->mg_obj : newSV(0);
2713         if ((ret = store(aTHX_ cxt, obj)))
2714                 return ret;
2715
2716         TRACEME(("ok (tied)"));
2717
2718         return 0;
2719 }
2720
2721 /*
2722  * store_tied_item
2723  *
2724  * Stores a reference to an item within a tied structure:
2725  *
2726  *  . \$h{key}, stores both the (tied %h) object and 'key'.
2727  *  . \$a[idx], stores both the (tied @a) object and 'idx'.
2728  *
2729  * Layout is therefore either:
2730  *     SX_TIED_KEY <object> <key>
2731  *     SX_TIED_IDX <object> <index>
2732  */
2733 static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv)
2734 {
2735         MAGIC *mg;
2736         int ret;
2737
2738         TRACEME(("store_tied_item (0x%"UVxf")", PTR2UV(sv)));
2739
2740         if (!(mg = mg_find(sv, 'p')))
2741                 CROAK(("No magic 'p' found while storing reference to tied item"));
2742
2743         /*
2744          * We discriminate between \$h{key} and \$a[idx] via mg_ptr.
2745          */
2746
2747         if (mg->mg_ptr) {
2748                 TRACEME(("store_tied_item: storing a ref to a tied hash item"));
2749                 PUTMARK(SX_TIED_KEY);
2750                 TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
2751
2752                 if ((ret = store(aTHX_ cxt, mg->mg_obj)))               /* Extra () for -Wall, grr... */
2753                         return ret;
2754
2755                 TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
2756
2757                 if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr)))        /* Idem, for -Wall */
2758                         return ret;
2759         } else {
2760                 I32 idx = mg->mg_len;
2761
2762                 TRACEME(("store_tied_item: storing a ref to a tied array item "));
2763                 PUTMARK(SX_TIED_IDX);
2764                 TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
2765
2766                 if ((ret = store(aTHX_ cxt, mg->mg_obj)))               /* Idem, for -Wall */
2767                         return ret;
2768
2769                 TRACEME(("store_tied_item: storing IDX %d", idx));
2770
2771                 WLEN(idx);
2772         }
2773
2774         TRACEME(("ok (tied item)"));
2775
2776         return 0;
2777 }
2778
2779 /*
2780  * store_hook           -- dispatched manually, not via sv_store[]
2781  *
2782  * The blessed SV is serialized by a hook.
2783  *
2784  * Simple Layout is:
2785  *
2786  *     SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
2787  *
2788  * where <flags> indicates how long <len>, <len2> and <len3> are, whether
2789  * the trailing part [] is present, the type of object (scalar, array or hash).
2790  * There is also a bit which says how the classname is stored between:
2791  *
2792  *     <len> <classname>
2793  *     <index>
2794  *
2795  * and when the <index> form is used (classname already seen), the "large
2796  * classname" bit in <flags> indicates how large the <index> is.
2797  *
2798  * The serialized string returned by the hook is of length <len2> and comes
2799  * next.  It is an opaque string for us.
2800  *
2801  * Those <len3> object IDs which are listed last represent the extra references
2802  * not directly serialized by the hook, but which are linked to the object.
2803  *
2804  * When recursion is mandated to resolve object-IDs not yet seen, we have
2805  * instead, with <header> being flags with bits set to indicate the object type
2806  * and that recursion was indeed needed:
2807  *
2808  *     SX_HOOK <header> <object> <header> <object> <flags>
2809  *
2810  * that same header being repeated between serialized objects obtained through
2811  * recursion, until we reach flags indicating no recursion, at which point
2812  * we know we've resynchronized with a single layout, after <flags>.
2813  *
2814  * When storing a blessed ref to a tied variable, the following format is
2815  * used:
2816  *
2817  *     SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
2818  *
2819  * The first <flags> indication carries an object of type SHT_EXTRA, and the
2820  * real object type is held in the <extra> flag.  At the very end of the
2821  * serialization stream, the underlying magic object is serialized, just like
2822  * any other tied variable.
2823  */
2824 static int store_hook(
2825         pTHX_
2826         stcxt_t *cxt,
2827         SV *sv,
2828         int type,
2829         HV *pkg,
2830         SV *hook)
2831 {
2832         I32 len;
2833         char *classname;
2834         STRLEN len2;
2835         SV *ref;
2836         AV *av;
2837         SV **ary;
2838         int count;                              /* really len3 + 1 */
2839         unsigned char flags;
2840         char *pv;
2841         int i;
2842         int recursed = 0;               /* counts recursion */
2843         int obj_type;                   /* object type, on 2 bits */
2844         I32 classnum;
2845         int ret;
2846         int clone = cxt->optype & ST_CLONE;
2847         char mtype = '\0';                              /* for blessed ref to tied structures */
2848         unsigned char eflags = '\0';    /* used when object type is SHT_EXTRA */
2849
2850         TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum));
2851
2852         /*
2853          * Determine object type on 2 bits.
2854          */
2855
2856         switch (type) {
2857         case svis_SCALAR:
2858                 obj_type = SHT_SCALAR;
2859                 break;
2860         case svis_ARRAY:
2861                 obj_type = SHT_ARRAY;
2862                 break;
2863         case svis_HASH:
2864                 obj_type = SHT_HASH;
2865                 break;
2866         case svis_TIED:
2867                 /*
2868                  * Produced by a blessed ref to a tied data structure, $o in the
2869                  * following Perl code.
2870                  *
2871                  *      my %h;
2872                  *  tie %h, 'FOO';
2873                  *      my $o = bless \%h, 'BAR';
2874                  *
2875                  * Signal the tie-ing magic by setting the object type as SHT_EXTRA
2876                  * (since we have only 2 bits in <flags> to store the type), and an
2877                  * <extra> byte flag will be emitted after the FIRST <flags> in the
2878                  * stream, carrying what we put in `eflags'.
2879                  */
2880                 obj_type = SHT_EXTRA;
2881                 switch (SvTYPE(sv)) {
2882                 case SVt_PVHV:
2883                         eflags = (unsigned char) SHT_THASH;
2884                         mtype = 'P';
2885                         break;
2886                 case SVt_PVAV:
2887                         eflags = (unsigned char) SHT_TARRAY;
2888                         mtype = 'P';
2889                         break;
2890                 default:
2891                         eflags = (unsigned char) SHT_TSCALAR;
2892                         mtype = 'q';
2893                         break;
2894                 }
2895                 break;
2896         default:
2897                 CROAK(("Unexpected object type (%d) in store_hook()", type));
2898         }
2899         flags = SHF_NEED_RECURSE | obj_type;
2900
2901         classname = HvNAME_get(pkg);
2902         len = strlen(classname);
2903
2904         /*
2905          * To call the hook, we need to fake a call like:
2906          *
2907          *    $object->STORABLE_freeze($cloning);
2908          *
2909          * but we don't have the $object here.  For instance, if $object is
2910          * a blessed array, what we have in `sv' is the array, and we can't
2911          * call a method on those.
2912          *
2913          * Therefore, we need to create a temporary reference to the object and
2914          * make the call on that reference.
2915          */
2916
2917         TRACEME(("about to call STORABLE_freeze on class %s", classname));
2918
2919         ref = newRV_noinc(sv);                          /* Temporary reference */
2920         av = array_call(aTHX_ ref, hook, clone);        /* @a = $object->STORABLE_freeze($c) */
2921         SvRV_set(ref, NULL);
2922         SvREFCNT_dec(ref);                                      /* Reclaim temporary reference */
2923
2924         count = AvFILLp(av) + 1;
2925         TRACEME(("store_hook, array holds %d items", count));
2926
2927         /*
2928          * If they return an empty list, it means they wish to ignore the
2929          * hook for this class (and not just this instance -- that's for them
2930          * to handle if they so wish).
2931          *
2932          * Simply disable the cached entry for the hook (it won't be recomputed
2933          * since it's present in the cache) and recurse to store_blessed().
2934          */
2935
2936         if (!count) {
2937                 /*
2938                  * They must not change their mind in the middle of a serialization.
2939                  */
2940
2941                 if (hv_fetch(cxt->hclass, classname, len, FALSE))
2942                         CROAK(("Too late to ignore hooks for %s class \"%s\"",
2943                                 (cxt->optype & ST_CLONE) ? "cloning" : "storing", classname));
2944
2945                 pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
2946
2947                 ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
2948                 TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname));
2949
2950                 return store_blessed(aTHX_ cxt, sv, type, pkg);
2951         }
2952
2953         /*
2954          * Get frozen string.
2955          */
2956
2957         ary = AvARRAY(av);
2958         pv = SvPV(ary[0], len2);
2959         /* We can't use pkg_can here because it only caches one method per
2960          * package */
2961         {
2962             GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE);
2963             if (gv && isGV(gv)) {
2964                 if (count > 1)
2965                     CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname));
2966                 goto check_done;
2967             }
2968         }
2969
2970         /*
2971          * If they returned more than one item, we need to serialize some
2972          * extra references if not already done.
2973          *
2974          * Loop over the array, starting at position #1, and for each item,
2975          * ensure it is a reference, serialize it if not already done, and
2976          * replace the entry with the tag ID of the corresponding serialized
2977          * object.
2978          *
2979          * We CHEAT by not calling av_fetch() and read directly within the
2980          * array, for speed.
2981          */
2982
2983         for (i = 1; i < count; i++) {
2984 #ifdef USE_PTR_TABLE
2985                 char *fake_tag;
2986 #else
2987                 SV **svh;
2988 #endif
2989                 SV *rsv = ary[i];
2990                 SV *xsv;
2991                 SV *tag;
2992                 AV *av_hook = cxt->hook_seen;
2993
2994                 if (!SvROK(rsv))
2995                         CROAK(("Item #%d returned by STORABLE_freeze "
2996                                 "for %s is not a reference", i, classname));
2997                 xsv = SvRV(rsv);                /* Follow ref to know what to look for */
2998
2999                 /*
3000                  * Look in hseen and see if we have a tag already.
3001                  * Serialize entry if not done already, and get its tag.
3002                  */
3003
3004 #ifdef USE_PTR_TABLE
3005                 /* Fakery needed because ptr_table_fetch returns zero for a
3006                    failure, whereas the existing code assumes that it can
3007                    safely store a tag zero. So for ptr_tables we store tag+1
3008                 */
3009                 if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv)))
3010                         goto sv_seen;           /* Avoid moving code too far to the right */
3011 #else
3012                 if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
3013                         goto sv_seen;           /* Avoid moving code too far to the right */
3014 #endif
3015
3016                 TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
3017
3018                 /*
3019                  * We need to recurse to store that object and get it to be known
3020                  * so that we can resolve the list of object-IDs at retrieve time.
3021                  *
3022                  * The first time we do this, we need to emit the proper header
3023                  * indicating that we recursed, and what the type of object is (the
3024                  * object we're storing via a user-hook).  Indeed, during retrieval,
3025                  * we'll have to create the object before recursing to retrieve the
3026                  * others, in case those would point back at that object.
3027                  */
3028
3029                 /* [SX_HOOK] <flags> [<extra>] <object>*/
3030                 if (!recursed++) {
3031                         PUTMARK(SX_HOOK);
3032                         PUTMARK(flags);
3033                         if (obj_type == SHT_EXTRA)
3034                                 PUTMARK(eflags);
3035                 } else
3036                         PUTMARK(flags);
3037
3038                 if ((ret = store(aTHX_ cxt, xsv)))      /* Given by hook for us to store */
3039                         return ret;
3040
3041 #ifdef USE_PTR_TABLE
3042                 fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv);
3043                 if (!sv)
3044                         CROAK(("Could not serialize item #%d from hook in %s", i, classname));
3045 #else
3046                 svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
3047                 if (!svh)
3048                         CROAK(("Could not serialize item #%d from hook in %s", i, classname));
3049 #endif
3050                 /*
3051                  * It was the first time we serialized `xsv'.
3052                  *
3053                  * Keep this SV alive until the end of the serialization: if we
3054                  * disposed of it right now by decrementing its refcount, and it was
3055                  * a temporary value, some next temporary value allocated during
3056                  * another STORABLE_freeze might take its place, and we'd wrongly
3057                  * assume that new SV was already serialized, based on its presence
3058                  * in cxt->hseen.
3059                  *
3060                  * Therefore, push it away in cxt->hook_seen.
3061                  */
3062
3063                 av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv));
3064
3065         sv_seen:
3066                 /*
3067                  * Dispose of the REF they returned.  If we saved the `xsv' away
3068                  * in the array of returned SVs, that will not cause the underlying
3069                  * referenced SV to be reclaimed.
3070                  */
3071
3072                 ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF"));
3073                 SvREFCNT_dec(rsv);                      /* Dispose of reference */
3074
3075                 /*
3076                  * Replace entry with its tag (not a real SV, so no refcnt increment)
3077                  */
3078
3079 #ifdef USE_PTR_TABLE
3080                 tag = (SV *)--fake_tag;
3081 #else
3082                 tag = *svh;
3083 #endif
3084                 ary[i] = tag;
3085                 TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf,
3086                          i-1, PTR2UV(xsv), PTR2UV(tag)));
3087         }
3088
3089         /*
3090          * Allocate a class ID if not already done.
3091          *
3092          * This needs to be done after the recursion above, since at retrieval
3093          * time, we'll see the inner objects first.  Many thanks to
3094          * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and
3095          * proposed the right fix.  -- RAM, 15/09/2000
3096          */
3097
3098 check_done:
3099         if (!known_class(aTHX_ cxt, classname, len, &classnum)) {
3100                 TRACEME(("first time we see class %s, ID = %d", classname, classnum));
3101                 classnum = -1;                          /* Mark: we must store classname */
3102         } else {
3103                 TRACEME(("already seen class %s, ID = %d", classname, classnum));
3104         }
3105
3106         /*
3107          * Compute leading flags.
3108          */
3109
3110         flags = obj_type;
3111         if (((classnum == -1) ? len : classnum) > LG_SCALAR)
3112                 flags |= SHF_LARGE_CLASSLEN;
3113         if (classnum != -1)
3114                 flags |= SHF_IDX_CLASSNAME;
3115         if (len2 > LG_SCALAR)
3116                 flags |= SHF_LARGE_STRLEN;
3117         if (count > 1)
3118                 flags |= SHF_HAS_LIST;
3119         if (count > (LG_SCALAR + 1))
3120                 flags |= SHF_LARGE_LISTLEN;
3121
3122         /*
3123          * We're ready to emit either serialized form:
3124          *
3125          *   SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
3126          *   SX_HOOK <flags> <index>           <len2> <str> [<len3> <object-IDs>]
3127          *
3128          * If we recursed, the SX_HOOK has already been emitted.
3129          */
3130
3131         TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
3132                         "class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d",
3133                  recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
3134
3135         /* SX_HOOK <flags> [<extra>] */
3136         if (!recursed) {
3137                 PUTMARK(SX_HOOK);
3138                 PUTMARK(flags);
3139                 if (obj_type == SHT_EXTRA)
3140                         PUTMARK(eflags);
3141         } else
3142                 PUTMARK(flags);
3143
3144         /* <len> <classname> or <index> */
3145         if (flags & SHF_IDX_CLASSNAME) {
3146                 if (flags & SHF_LARGE_CLASSLEN)
3147                         WLEN(classnum);
3148                 else {
3149                         unsigned char cnum = (unsigned char) classnum;
3150                         PUTMARK(cnum);
3151                 }
3152         } else {
3153                 if (flags & SHF_LARGE_CLASSLEN)
3154                         WLEN(len);
3155                 else {
3156                         unsigned char clen = (unsigned char) len;
3157                         PUTMARK(clen);
3158                 }
3159                 WRITE(classname, len);          /* Final \0 is omitted */
3160         }
3161
3162         /* <len2> <frozen-str> */
3163         if (flags & SHF_LARGE_STRLEN) {
3164                 I32 wlen2 = len2;               /* STRLEN might be 8 bytes */
3165                 WLEN(wlen2);                    /* Must write an I32 for 64-bit machines */
3166         } else {
3167                 unsigned char clen = (unsigned char) len2;
3168                 PUTMARK(clen);
3169         }
3170         if (len2)
3171                 WRITE(pv, (SSize_t)len2);       /* Final \0 is omitted */
3172
3173         /* [<len3> <object-IDs>] */
3174         if (flags & SHF_HAS_LIST) {
3175                 int len3 = count - 1;
3176                 if (flags & SHF_LARGE_LISTLEN)
3177                         WLEN(len3);
3178                 else {
3179                         unsigned char clen = (unsigned char) len3;
3180                         PUTMARK(clen);
3181                 }
3182
3183                 /*
3184                  * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a
3185                  * real pointer, rather a tag number, well under the 32-bit limit.
3186                  */
3187
3188                 for (i = 1; i < count; i++) {
3189                         I32 tagval = htonl(LOW_32BITS(ary[i]));
3190                         WRITE_I32(tagval);
3191                         TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
3192                 }
3193         }
3194
3195         /*
3196          * Free the array.  We need extra care for indices after 0, since they
3197          * don't hold real SVs but integers cast.
3198          */
3199
3200         if (count > 1)
3201                 AvFILLp(av) = 0;        /* Cheat, nothing after 0 interests us */
3202         av_undef(av);
3203         sv_free((SV *) av);
3204
3205         /*
3206          * If object was tied, need to insert serialization of the magic object.
3207          */
3208
3209         if (obj_type == SHT_EXTRA) {
3210                 MAGIC *mg;
3211
3212                 if (!(mg = mg_find(sv, mtype))) {
3213                         int svt = SvTYPE(sv);
3214                         CROAK(("No magic '%c' found while storing ref to tied %s with hook",
3215                                 mtype, (svt == SVt_PVHV) ? "hash" :
3216                                         (svt == SVt_PVAV) ? "array" : "scalar"));
3217                 }
3218
3219                 TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf,
3220                         PTR2UV(mg->mg_obj), PTR2UV(sv)));
3221
3222                 /*
3223                  * [<magic object>]
3224                  */
3225
3226                 if ((ret = store(aTHX_ cxt, mg->mg_obj)))       /* Extra () for -Wall, grr... */
3227                         return ret;
3228         }
3229
3230         return 0;
3231 }
3232
3233 /*
3234  * store_blessed        -- dispatched manually, not via sv_store[]
3235  *
3236  * Check whether there is a STORABLE_xxx hook defined in the class or in one
3237  * of its ancestors.  If there is, then redispatch to store_hook();
3238  *
3239  * Otherwise, the blessed SV is stored using the following layout:
3240  *
3241  *    SX_BLESS <flag> <len> <classname> <object>
3242  *
3243  * where <flag> indicates whether <len> is stored on 0 or 4 bytes, depending
3244  * on the high-order bit in flag: if 1, then length follows on 4 bytes.
3245  * Otherwise, the low order bits give the length, thereby giving a compact
3246  * representation for class names less than 127 chars long.
3247  *
3248  * Each <classname> seen is remembered and indexed, so that the next time
3249  * an object in the blessed in the same <classname> is stored, the following
3250  * will be emitted:
3251  *
3252  *    SX_IX_BLESS <flag> <index> <object>
3253  *
3254  * where <index> is the classname index, stored on 0 or 4 bytes depending
3255  * on the high-order bit in flag (same encoding as above for <len>).
3256  */
3257 static int store_blessed(
3258         pTHX_
3259         stcxt_t *cxt,
3260         SV *sv,
3261         int type,
3262         HV *pkg)
3263 {
3264         SV *hook;
3265         I32 len;
3266         char *classname;
3267         I32 classnum;
3268
3269         TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg)));
3270
3271         /*
3272          * Look for a hook for this blessed SV and redirect to store_hook()
3273          * if needed.
3274          */
3275
3276         hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
3277         if (hook)
3278                 return store_hook(aTHX_ cxt, sv, type, pkg, hook);
3279
3280         /*
3281          * This is a blessed SV without any serialization hook.
3282          */
3283
3284         classname = HvNAME_get(pkg);
3285         len = strlen(classname);
3286
3287         TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d",
3288                  PTR2UV(sv), classname, cxt->tagnum));
3289
3290         /*
3291          * Determine whether it is the first time we see that class name (in which
3292          * case it will be stored in the SX_BLESS form), or whether we already
3293          * saw that class name before (in which case the SX_IX_BLESS form will be
3294          * used).
3295          */
3296
3297         if (known_class(aTHX_ cxt, classname, len, &classnum)) {
3298                 TRACEME(("already seen class %s, ID = %d", classname, classnum));
3299                 PUTMARK(SX_IX_BLESS);
3300                 if (classnum <= LG_BLESS) {
3301                         unsigned char cnum = (unsigned char) classnum;
3302                         PUTMARK(cnum);
3303                 } else {
3304                         unsigned char flag = (unsigned char) 0x80;
3305                         PUTMARK(flag);
3306                         WLEN(classnum);
3307                 }
3308         } else {
3309                 TRACEME(("first time we see class %s, ID = %d", classname, classnum));
3310                 PUTMARK(SX_BLESS);
3311                 if (len <= LG_BLESS) {
3312                         unsigned char clen = (unsigned char) len;
3313                         PUTMARK(clen);
3314                 } else {
3315                         unsigned char flag = (unsigned char) 0x80;
3316                         PUTMARK(flag);
3317                         WLEN(len);                                      /* Don't BER-encode, this should be rare */
3318                 }
3319                 WRITE(classname, len);                          /* Final \0 is omitted */
3320         }
3321
3322         /*
3323          * Now emit the <object> part.
3324          */
3325
3326         return SV_STORE(type)(aTHX_ cxt, sv);
3327 }
3328
3329 /*
3330  * store_other
3331  *
3332  * We don't know how to store the item we reached, so return an error condition.
3333  * (it's probably a GLOB, some CODE reference, etc...)
3334  *
3335  * If they defined the `forgive_me' variable at the Perl level to some
3336  * true value, then don't croak, just warn, and store a placeholder string
3337  * instead.
3338  */
3339 static int store_other(pTHX_ stcxt_t *cxt, SV *sv)
3340 {
3341         I32 len;
3342         char buf[80];
3343
3344         TRACEME(("store_other"));
3345
3346         /*
3347          * Fetch the value from perl only once per store() operation.
3348          */
3349
3350         if (
3351                 cxt->forgive_me == 0 ||
3352                 (cxt->forgive_me < 0 && !(cxt->forgive_me =
3353                         SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
3354         )
3355                 CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
3356
3357         warn("Can't store item %s(0x%"UVxf")",
3358                 sv_reftype(sv, FALSE), PTR2UV(sv));
3359
3360         /*
3361          * Store placeholder string as a scalar instead...
3362          */
3363
3364         (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE),
3365                        PTR2UV(sv), (char) 0);
3366
3367         len = strlen(buf);
3368         STORE_SCALAR(buf, len);
3369         TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, (IV) len));
3370
3371         return 0;
3372 }
3373
3374 /***
3375  *** Store driving routines
3376  ***/
3377
3378 /*
3379  * sv_type
3380  *
3381  * WARNING: partially duplicates Perl's sv_reftype for speed.
3382  *
3383  * Returns the type of the SV, identified by an integer. That integer
3384  * may then be used to index the dynamic routine dispatch table.
3385  */
3386 static int sv_type(pTHX_ SV *sv)
3387 {
3388         switch (SvTYPE(sv)) {
3389         case SVt_NULL:
3390 #if PERL_VERSION <= 10
3391         case SVt_IV:
3392 #endif
3393         case SVt_NV:
3394                 /*
3395                  * No need to check for ROK, that can't be set here since there
3396                  * is no field capable of hodling the xrv_rv reference.
3397                  */
3398                 return svis_SCALAR;
3399         case SVt_PV:
3400 #if PERL_VERSION <= 10
3401         case SVt_RV:
3402 #else
3403         case SVt_IV:
3404 #endif
3405         case SVt_PVIV:
3406         case SVt_PVNV:
3407                 /*
3408                  * Starting from SVt_PV, it is possible to have the ROK flag
3409                  * set, the pointer to the other SV being either stored in
3410                  * the xrv_rv (in the case of a pure SVt_RV), or as the
3411                  * xpv_pv field of an SVt_PV and its heirs.
3412                  *
3413                  * However, those SV cannot be magical or they would be an
3414                  * SVt_PVMG at least.
3415                  */
3416                 return SvROK(sv) ? svis_REF : svis_SCALAR;
3417         case SVt_PVMG:
3418         case SVt_PVLV:          /* Workaround for perl5.004_04 "LVALUE" bug */
3419                 if (SvRMAGICAL(sv) && (mg_find(sv, 'p')))
3420                         return svis_TIED_ITEM;
3421                 /* FALL THROUGH */
3422 #if PERL_VERSION < 9
3423         case SVt_PVBM:
3424 #endif
3425                 if (SvRMAGICAL(sv) && (mg_find(sv, 'q')))
3426                         return svis_TIED;
3427                 return SvROK(sv) ? svis_REF : svis_SCALAR;
3428         case SVt_PVAV:
3429                 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
3430                         return svis_TIED;
3431                 return svis_ARRAY;
3432         case SVt_PVHV:
3433                 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
3434                         return svis_TIED;
3435                 return svis_HASH;
3436         case SVt_PVCV:
3437                 return svis_CODE;
3438 #if PERL_VERSION > 8
3439         /* case SVt_BIND: */
3440 #endif
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 = (SV **)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", GV_ADD))) {
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 behind 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  *** Memory stores.
3798  ***/
3799
3800 /*
3801  * mbuf2sv
3802  *
3803  * Build a new SV out of the content of the internal memory buffer.
3804  */
3805 static SV *mbuf2sv(pTHX)
3806 {
3807         dSTCXT;
3808
3809         return newSVpv(mbase, MBUF_SIZE());
3810 }
3811
3812 /***
3813  *** Specific retrieve callbacks.
3814  ***/
3815
3816 /*
3817  * retrieve_other
3818  *
3819  * Return an error via croak, since it is not possible that we get here
3820  * under normal conditions, when facing a file produced via pstore().
3821  */
3822 static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname)
3823 {
3824         PERL_UNUSED_ARG(cname);
3825         if (
3826                 cxt->ver_major != STORABLE_BIN_MAJOR &&
3827                 cxt->ver_minor != STORABLE_BIN_MINOR
3828         ) {
3829                 CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d",
3830                         cxt->fio ? "file" : "string",
3831                         cxt->ver_major, cxt->ver_minor,
3832                         STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
3833         } else {
3834                 CROAK(("Corrupted storable %s (binary v%d.%d)",
3835                         cxt->fio ? "file" : "string",
3836                         cxt->ver_major, cxt->ver_minor));
3837         }
3838
3839         return (SV *) 0;                /* Just in case */
3840 }
3841
3842 /*
3843  * retrieve_idx_blessed
3844  *
3845  * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
3846  * <index> can be coded on either 1 or 5 bytes.
3847  */
3848 static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname)
3849 {
3850         I32 idx;
3851         const char *classname;
3852         SV **sva;
3853         SV *sv;
3854
3855         PERL_UNUSED_ARG(cname);
3856         TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum));
3857         ASSERT(!cname, ("no bless-into class given here, got %s", cname));
3858
3859         GETMARK(idx);                   /* Index coded on a single char? */
3860         if (idx & 0x80)
3861                 RLEN(idx);
3862
3863         /*
3864          * Fetch classname in `aclass'
3865          */
3866
3867         sva = av_fetch(cxt->aclass, idx, FALSE);
3868         if (!sva)
3869                 CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx));
3870
3871         classname = SvPVX(*sva);        /* We know it's a PV, by construction */
3872
3873         TRACEME(("class ID %d => %s", idx, classname));
3874
3875         /*
3876          * Retrieve object and bless it.
3877          */
3878
3879         sv = retrieve(aTHX_ cxt, classname);    /* First SV which is SEEN will be blessed */
3880
3881         return sv;
3882 }
3883
3884 /*
3885  * retrieve_blessed
3886  *
3887  * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
3888  * <len> can be coded on either 1 or 5 bytes.
3889  */
3890 static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
3891 {
3892         I32 len;
3893         SV *sv;
3894         char buf[LG_BLESS + 1];         /* Avoid malloc() if possible */
3895         char *classname = buf;
3896         char *malloced_classname = NULL;
3897
3898         PERL_UNUSED_ARG(cname);
3899         TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
3900         ASSERT(!cname, ("no bless-into class given here, got %s", cname));
3901
3902         /*
3903          * Decode class name length and read that name.
3904          *
3905          * Short classnames have two advantages: their length is stored on one
3906          * single byte, and the string can be read on the stack.
3907          */
3908
3909         GETMARK(len);                   /* Length coded on a single char? */
3910         if (len & 0x80) {
3911                 RLEN(len);
3912                 TRACEME(("** allocating %d bytes for class name", len+1));
3913                 New(10003, classname, len+1, char);
3914                 malloced_classname = classname;
3915         }
3916         SAFEPVREAD(classname, len, malloced_classname);
3917         classname[len] = '\0';          /* Mark string end */
3918
3919         /*
3920          * It's a new classname, otherwise it would have been an SX_IX_BLESS.
3921          */
3922
3923         TRACEME(("new class name \"%s\" will bear ID = %d", classname, cxt->classnum));
3924
3925         if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) {
3926                 Safefree(malloced_classname);
3927                 return (SV *) 0;
3928         }
3929
3930         /*
3931          * Retrieve object and bless it.
3932          */
3933
3934         sv = retrieve(aTHX_ cxt, classname);    /* First SV which is SEEN will be blessed */
3935         if (malloced_classname)
3936                 Safefree(malloced_classname);
3937
3938         return sv;
3939 }
3940
3941 /*
3942  * retrieve_hook
3943  *
3944  * Layout: SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
3945  * with leading mark already read, as usual.
3946  *
3947  * When recursion was involved during serialization of the object, there
3948  * is an unknown amount of serialized objects after the SX_HOOK mark.  Until
3949  * we reach a <flags> marker with the recursion bit cleared.