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