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