dist/Storable/Storable.xs

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