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