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