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