ext/Storable/Storable.xs

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