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