ext/Storable/Storable.xs

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