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