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