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