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