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