ext/Storable/Storable.xs

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