This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #92432] Storable::nfreeze shouldn't stringify ints
[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) > (UV)0x7FFFFFFF) ||
2121 #endif
2122                     (iv > (IV)0x7FFFFFFF) || (iv < -(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             HvUSEDKEYS(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)
2439                          && SvREADONLY(val) && !SvIsCOW(val)) {
2440                                 flags |= SHV_K_LOCKED;
2441                         }
2442
2443                         keyval = SvPV(key, keylen_tmp);
2444                         keylen = keylen_tmp;
2445 #ifdef HAS_UTF8_HASHES
2446                         /* If you build without optimisation on pre 5.6
2447                            then nothing spots that SvUTF8(key) is always 0,
2448                            so the block isn't optimised away, at which point
2449                            the linker dislikes the reference to
2450                            bytes_from_utf8.  */
2451                         if (SvUTF8(key)) {
2452                             const char *keysave = keyval;
2453                             bool is_utf8 = TRUE;
2454
2455                             /* Just casting the &klen to (STRLEN) won't work
2456                                well if STRLEN and I32 are of different widths.
2457                                --jhi */
2458                             keyval = (char*)bytes_from_utf8((U8*)keyval,
2459                                                             &keylen_tmp,
2460                                                             &is_utf8);
2461
2462                             /* If we were able to downgrade here, then than
2463                                means that we have  a key which only had chars
2464                                0-255, but was utf8 encoded.  */
2465
2466                             if (keyval != keysave) {
2467                                 keylen = keylen_tmp;
2468                                 flags |= SHV_K_WASUTF8;
2469                             } else {
2470                                 /* keylen_tmp can't have changed, so no need
2471                                    to assign back to keylen.  */
2472                                 flags |= SHV_K_UTF8;
2473                             }
2474                         }
2475 #endif
2476
2477                         if (flagged_hash) {
2478                             PUTMARK(flags);
2479                             TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval));
2480                         } else {
2481                             /* This is a workaround for a bug in 5.8.0
2482                                that causes the HEK_WASUTF8 flag to be
2483                                set on an HEK without the hash being
2484                                marked as having key flags. We just
2485                                cross our fingers and drop the flag.
2486                                AMS 20030901 */
2487                             assert (flags == 0 || flags == SHV_K_WASUTF8);
2488                             TRACEME(("(#%d) key '%s'", i, keyval));
2489                         }
2490                         WLEN(keylen);
2491                         if (keylen)
2492                                 WRITE(keyval, keylen);
2493                         if (flags & SHV_K_WASUTF8)
2494                             Safefree (keyval);
2495                 }
2496
2497                 /* 
2498                  * Free up the temporary array
2499                  */
2500
2501                 av_undef(av);
2502                 sv_free((SV *) av);
2503
2504         } else {
2505
2506                 /*
2507                  * Storing in "random" order (in the order the keys are stored
2508                  * within the hash).  This is the default and will be faster!
2509                  */
2510   
2511                 for (i = 0; i < len; i++) {
2512                         char *key = 0;
2513                         I32 len;
2514                         unsigned char flags;
2515 #ifdef HV_ITERNEXT_WANTPLACEHOLDERS
2516                         HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
2517 #else
2518                         HE *he = hv_iternext(hv);
2519 #endif
2520                         SV *val = (he ? hv_iterval(hv, he) : 0);
2521                         SV *key_sv = NULL;
2522                         HEK *hek;
2523
2524                         if (val == 0)
2525                                 return 1;               /* Internal error, not I/O error */
2526
2527                         /* Implementation of restricted hashes isn't nicely
2528                            abstracted:  */
2529                         flags
2530                             = (((hash_flags & SHV_RESTRICTED)
2531                                 && SvREADONLY(val) && !SvIsCOW(val))
2532                                              ? SHV_K_LOCKED : 0);
2533
2534                         if (val == &PL_sv_placeholder) {
2535                             flags |= SHV_K_PLACEHOLDER;
2536                             val = &PL_sv_undef;
2537                         }
2538
2539                         /*
2540                          * Store value first.
2541                          */
2542
2543                         TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
2544
2545                         if ((ret = store(aTHX_ cxt, val)))      /* Extra () for -Wall, grr... */
2546                                 goto out;
2547
2548
2549                         hek = HeKEY_hek(he);
2550                         len = HEK_LEN(hek);
2551                         if (len == HEf_SVKEY) {
2552                             /* This is somewhat sick, but the internal APIs are
2553                              * such that XS code could put one of these in in
2554                              * a regular hash.
2555                              * Maybe we should be capable of storing one if
2556                              * found.
2557                              */
2558                             key_sv = HeKEY_sv(he);
2559                             flags |= SHV_K_ISSV;
2560                         } else {
2561                             /* Regular string key. */
2562 #ifdef HAS_HASH_KEY_FLAGS
2563                             if (HEK_UTF8(hek))
2564                                 flags |= SHV_K_UTF8;
2565                             if (HEK_WASUTF8(hek))
2566                                 flags |= SHV_K_WASUTF8;
2567 #endif
2568                             key = HEK_KEY(hek);
2569                         }
2570                         /*
2571                          * Write key string.
2572                          * Keys are written after values to make sure retrieval
2573                          * can be optimal in terms of memory usage, where keys are
2574                          * read into a fixed unique buffer called kbuf.
2575                          * See retrieve_hash() for details.
2576                          */
2577
2578                         if (flagged_hash) {
2579                             PUTMARK(flags);
2580                             TRACEME(("(#%d) key '%s' flags %x", i, key, flags));
2581                         } else {
2582                             /* This is a workaround for a bug in 5.8.0
2583                                that causes the HEK_WASUTF8 flag to be
2584                                set on an HEK without the hash being
2585                                marked as having key flags. We just
2586                                cross our fingers and drop the flag.
2587                                AMS 20030901 */
2588                             assert (flags == 0 || flags == SHV_K_WASUTF8);
2589                             TRACEME(("(#%d) key '%s'", i, key));
2590                         }
2591                         if (flags & SHV_K_ISSV) {
2592                             store(aTHX_ cxt, key_sv);
2593                         } else {
2594                             WLEN(len);
2595                             if (len)
2596                                 WRITE(key, len);
2597                         }
2598                 }
2599     }
2600
2601         TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv)));
2602
2603 out:
2604         HvRITER_set(hv, riter);         /* Restore hash iterator state */
2605         HvEITER_set(hv, eiter);
2606
2607         return ret;
2608 }
2609
2610 /*
2611  * store_code
2612  *
2613  * Store a code reference.
2614  *
2615  * Layout is SX_CODE <length> followed by a scalar containing the perl
2616  * source code of the code reference.
2617  */
2618 static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
2619 {
2620 #if PERL_VERSION < 6
2621     /*
2622          * retrieve_code does not work with perl 5.005 or less
2623          */
2624         return store_other(aTHX_ cxt, (SV*)cv);
2625 #else
2626         dSP;
2627         I32 len;
2628         int count, reallen;
2629         SV *text, *bdeparse;
2630
2631         TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv)));
2632
2633         if (
2634                 cxt->deparse == 0 ||
2635                 (cxt->deparse < 0 && !(cxt->deparse =
2636                         SvTRUE(perl_get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0))
2637         ) {
2638                 return store_other(aTHX_ cxt, (SV*)cv);
2639         }
2640
2641         /*
2642          * Require B::Deparse. At least B::Deparse 0.61 is needed for
2643          * blessed code references.
2644          */
2645         /* Ownership of both SVs is passed to load_module, which frees them. */
2646         load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61));
2647         SPAGAIN;
2648
2649         ENTER;
2650         SAVETMPS;
2651
2652         /*
2653          * create the B::Deparse object
2654          */
2655
2656         PUSHMARK(sp);
2657         XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP));
2658         PUTBACK;
2659         count = call_method("new", G_SCALAR);
2660         SPAGAIN;
2661         if (count != 1)
2662                 CROAK(("Unexpected return value from B::Deparse::new\n"));
2663         bdeparse = POPs;
2664
2665         /*
2666          * call the coderef2text method
2667          */
2668
2669         PUSHMARK(sp);
2670         XPUSHs(bdeparse); /* XXX is this already mortal? */
2671         XPUSHs(sv_2mortal(newRV_inc((SV*)cv)));
2672         PUTBACK;
2673         count = call_method("coderef2text", G_SCALAR);
2674         SPAGAIN;
2675         if (count != 1)
2676                 CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
2677
2678         text = POPs;
2679         len = SvCUR(text);
2680         reallen = strlen(SvPV_nolen(text));
2681
2682         /*
2683          * Empty code references or XS functions are deparsed as
2684          * "(prototype) ;" or ";".
2685          */
2686
2687         if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') {
2688             CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
2689         }
2690
2691         /* 
2692          * Signal code by emitting SX_CODE.
2693          */
2694
2695         PUTMARK(SX_CODE);
2696         cxt->tagnum++;   /* necessary, as SX_CODE is a SEEN() candidate */
2697         TRACEME(("size = %d", len));
2698         TRACEME(("code = %s", SvPV_nolen(text)));
2699
2700         /*
2701          * Now store the source code.
2702          */
2703
2704         if(SvUTF8 (text))
2705                 STORE_UTF8STR(SvPV_nolen(text), len);
2706         else
2707                 STORE_SCALAR(SvPV_nolen(text), len);
2708
2709         FREETMPS;
2710         LEAVE;
2711
2712         TRACEME(("ok (code)"));
2713
2714         return 0;
2715 #endif
2716 }
2717
2718 /*
2719  * store_tied
2720  *
2721  * When storing a tied object (be it a tied scalar, array or hash), we lay out
2722  * a special mark, followed by the underlying tied object. For instance, when
2723  * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
2724  * <hash object> stands for the serialization of the tied hash.
2725  */
2726 static int store_tied(pTHX_ stcxt_t *cxt, SV *sv)
2727 {
2728         MAGIC *mg;
2729         SV *obj = NULL;
2730         int ret = 0;
2731         int svt = SvTYPE(sv);
2732         char mtype = 'P';
2733
2734         TRACEME(("store_tied (0x%"UVxf")", PTR2UV(sv)));
2735
2736         /*
2737          * We have a small run-time penalty here because we chose to factorise
2738          * all tieds objects into the same routine, and not have a store_tied_hash,
2739          * a store_tied_array, etc...
2740          *
2741          * Don't use a switch() statement, as most compilers don't optimize that
2742          * well for 2/3 values. An if() else if() cascade is just fine. We put
2743          * tied hashes first, as they are the most likely beasts.
2744          */
2745
2746         if (svt == SVt_PVHV) {
2747                 TRACEME(("tied hash"));
2748                 PUTMARK(SX_TIED_HASH);                  /* Introduces tied hash */
2749         } else if (svt == SVt_PVAV) {
2750                 TRACEME(("tied array"));
2751                 PUTMARK(SX_TIED_ARRAY);                 /* Introduces tied array */
2752         } else {
2753                 TRACEME(("tied scalar"));
2754                 PUTMARK(SX_TIED_SCALAR);                /* Introduces tied scalar */
2755                 mtype = 'q';
2756         }
2757
2758         if (!(mg = mg_find(sv, mtype)))
2759                 CROAK(("No magic '%c' found while storing tied %s", mtype,
2760                         (svt == SVt_PVHV) ? "hash" :
2761                                 (svt == SVt_PVAV) ? "array" : "scalar"));
2762
2763         /*
2764          * The mg->mg_obj found by mg_find() above actually points to the
2765          * underlying tied Perl object implementation. For instance, if the
2766          * original SV was that of a tied array, then mg->mg_obj is an AV.
2767          *
2768          * Note that we store the Perl object as-is. We don't call its FETCH
2769          * method along the way. At retrieval time, we won't call its STORE
2770          * method either, but the tieing magic will be re-installed. In itself,
2771          * that ensures that the tieing semantics are preserved since further
2772          * accesses on the retrieved object will indeed call the magic methods...
2773          */
2774
2775         /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
2776         obj = mg->mg_obj ? mg->mg_obj : newSV(0);
2777         if ((ret = store(aTHX_ cxt, obj)))
2778                 return ret;
2779
2780         TRACEME(("ok (tied)"));
2781
2782         return 0;
2783 }
2784
2785 /*
2786  * store_tied_item
2787  *
2788  * Stores a reference to an item within a tied structure:
2789  *
2790  *  . \$h{key}, stores both the (tied %h) object and 'key'.
2791  *  . \$a[idx], stores both the (tied @a) object and 'idx'.
2792  *
2793  * Layout is therefore either:
2794  *     SX_TIED_KEY <object> <key>
2795  *     SX_TIED_IDX <object> <index>
2796  */
2797 static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv)
2798 {
2799         MAGIC *mg;
2800         int ret;
2801
2802         TRACEME(("store_tied_item (0x%"UVxf")", PTR2UV(sv)));
2803
2804         if (!(mg = mg_find(sv, 'p')))
2805                 CROAK(("No magic 'p' found while storing reference to tied item"));
2806
2807         /*
2808          * We discriminate between \$h{key} and \$a[idx] via mg_ptr.
2809          */
2810
2811         if (mg->mg_ptr) {
2812                 TRACEME(("store_tied_item: storing a ref to a tied hash item"));
2813                 PUTMARK(SX_TIED_KEY);
2814                 TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
2815
2816                 if ((ret = store(aTHX_ cxt, mg->mg_obj)))               /* Extra () for -Wall, grr... */
2817                         return ret;
2818
2819                 TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
2820
2821                 if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr)))        /* Idem, for -Wall */
2822                         return ret;
2823         } else {
2824                 I32 idx = mg->mg_len;
2825
2826                 TRACEME(("store_tied_item: storing a ref to a tied array item "));
2827                 PUTMARK(SX_TIED_IDX);
2828                 TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
2829
2830                 if ((ret = store(aTHX_ cxt, mg->mg_obj)))               /* Idem, for -Wall */
2831                         return ret;
2832
2833                 TRACEME(("store_tied_item: storing IDX %d", idx));
2834
2835                 WLEN(idx);
2836         }
2837
2838         TRACEME(("ok (tied item)"));
2839
2840         return 0;
2841 }
2842
2843 /*
2844  * store_hook           -- dispatched manually, not via sv_store[]
2845  *
2846  * The blessed SV is serialized by a hook.
2847  *
2848  * Simple Layout is:
2849  *
2850  *     SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
2851  *
2852  * where <flags> indicates how long <len>, <len2> and <len3> are, whether
2853  * the trailing part [] is present, the type of object (scalar, array or hash).
2854  * There is also a bit which says how the classname is stored between:
2855  *
2856  *     <len> <classname>
2857  *     <index>
2858  *
2859  * and when the <index> form is used (classname already seen), the "large
2860  * classname" bit in <flags> indicates how large the <index> is.
2861  * 
2862  * The serialized string returned by the hook is of length <len2> and comes
2863  * next.  It is an opaque string for us.
2864  *
2865  * Those <len3> object IDs which are listed last represent the extra references
2866  * not directly serialized by the hook, but which are linked to the object.
2867  *
2868  * When recursion is mandated to resolve object-IDs not yet seen, we have
2869  * instead, with <header> being flags with bits set to indicate the object type
2870  * and that recursion was indeed needed:
2871  *
2872  *     SX_HOOK <header> <object> <header> <object> <flags>
2873  *
2874  * that same header being repeated between serialized objects obtained through
2875  * recursion, until we reach flags indicating no recursion, at which point
2876  * we know we've resynchronized with a single layout, after <flags>.
2877  *
2878  * When storing a blessed ref to a tied variable, the following format is
2879  * used:
2880  *
2881  *     SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
2882  *
2883  * The first <flags> indication carries an object of type SHT_EXTRA, and the
2884  * real object type is held in the <extra> flag.  At the very end of the
2885  * serialization stream, the underlying magic object is serialized, just like
2886  * any other tied variable.
2887  */
2888 static int store_hook(
2889         pTHX_
2890         stcxt_t *cxt,
2891         SV *sv,
2892         int type,
2893         HV *pkg,
2894         SV *hook)
2895 {
2896         I32 len;
2897         char *classname;
2898         STRLEN len2;
2899         SV *ref;
2900         AV *av;
2901         SV **ary;
2902         int count;                              /* really len3 + 1 */
2903         unsigned char flags;
2904         char *pv;
2905         int i;
2906         int recursed = 0;               /* counts recursion */
2907         int obj_type;                   /* object type, on 2 bits */
2908         I32 classnum;
2909         int ret;
2910         int clone = cxt->optype & ST_CLONE;
2911         char mtype = '\0';                              /* for blessed ref to tied structures */
2912         unsigned char eflags = '\0';    /* used when object type is SHT_EXTRA */
2913
2914         TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum));
2915
2916         /*
2917          * Determine object type on 2 bits.
2918          */
2919
2920         switch (type) {
2921         case svis_SCALAR:
2922                 obj_type = SHT_SCALAR;
2923                 break;
2924         case svis_ARRAY:
2925                 obj_type = SHT_ARRAY;
2926                 break;
2927         case svis_HASH:
2928                 obj_type = SHT_HASH;
2929                 break;
2930         case svis_TIED:
2931                 /*
2932                  * Produced by a blessed ref to a tied data structure, $o in the
2933                  * following Perl code.
2934                  *
2935                  *      my %h;
2936                  *  tie %h, 'FOO';
2937                  *      my $o = bless \%h, 'BAR';
2938                  *
2939                  * Signal the tie-ing magic by setting the object type as SHT_EXTRA
2940                  * (since we have only 2 bits in <flags> to store the type), and an
2941                  * <extra> byte flag will be emitted after the FIRST <flags> in the
2942                  * stream, carrying what we put in `eflags'.
2943                  */
2944                 obj_type = SHT_EXTRA;
2945                 switch (SvTYPE(sv)) {
2946                 case SVt_PVHV:
2947                         eflags = (unsigned char) SHT_THASH;
2948                         mtype = 'P';
2949                         break;
2950                 case SVt_PVAV:
2951                         eflags = (unsigned char) SHT_TARRAY;
2952                         mtype = 'P';
2953                         break;
2954                 default:
2955                         eflags = (unsigned char) SHT_TSCALAR;
2956                         mtype = 'q';
2957                         break;
2958                 }
2959                 break;
2960         default:
2961                 CROAK(("Unexpected object type (%d) in store_hook()", type));
2962         }
2963         flags = SHF_NEED_RECURSE | obj_type;
2964
2965         classname = HvNAME_get(pkg);
2966         len = strlen(classname);
2967
2968         /*
2969          * To call the hook, we need to fake a call like:
2970          *
2971          *    $object->STORABLE_freeze($cloning);
2972          *
2973          * but we don't have the $object here.  For instance, if $object is
2974          * a blessed array, what we have in `sv' is the array, and we can't
2975          * call a method on those.
2976          *
2977          * Therefore, we need to create a temporary reference to the object and
2978          * make the call on that reference.
2979          */
2980
2981         TRACEME(("about to call STORABLE_freeze on class %s", classname));
2982
2983         ref = newRV_noinc(sv);                          /* Temporary reference */
2984         av = array_call(aTHX_ ref, hook, clone);        /* @a = $object->STORABLE_freeze($c) */
2985         SvRV_set(ref, NULL);
2986         SvREFCNT_dec(ref);                                      /* Reclaim temporary reference */
2987
2988         count = AvFILLp(av) + 1;
2989         TRACEME(("store_hook, array holds %d items", count));
2990
2991         /*
2992          * If they return an empty list, it means they wish to ignore the
2993          * hook for this class (and not just this instance -- that's for them
2994          * to handle if they so wish).
2995          *
2996          * Simply disable the cached entry for the hook (it won't be recomputed
2997          * since it's present in the cache) and recurse to store_blessed().
2998          */
2999
3000         if (!count) {
3001                 /*
3002                  * They must not change their mind in the middle of a serialization.
3003                  */
3004
3005                 if (hv_fetch(cxt->hclass, classname, len, FALSE))
3006                         CROAK(("Too late to ignore hooks for %s class \"%s\"",
3007                                 (cxt->optype & ST_CLONE) ? "cloning" : "storing", classname));
3008         
3009                 pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
3010
3011                 ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
3012                 TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname));
3013
3014                 return store_blessed(aTHX_ cxt, sv, type, pkg);
3015         }
3016
3017         /*
3018          * Get frozen string.
3019          */
3020
3021         ary = AvARRAY(av);
3022         pv = SvPV(ary[0], len2);
3023         /* We can't use pkg_can here because it only caches one method per
3024          * package */
3025         { 
3026             GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE);
3027             if (gv && isGV(gv)) {
3028                 if (count > 1)
3029                     CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname));
3030                 goto check_done;
3031             }
3032         }
3033
3034         /*
3035          * If they returned more than one item, we need to serialize some
3036          * extra references if not already done.
3037          *
3038          * Loop over the array, starting at position #1, and for each item,
3039          * ensure it is a reference, serialize it if not already done, and
3040          * replace the entry with the tag ID of the corresponding serialized
3041          * object.
3042          *
3043          * We CHEAT by not calling av_fetch() and read directly within the
3044          * array, for speed.
3045          */
3046
3047         for (i = 1; i < count; i++) {
3048 #ifdef USE_PTR_TABLE
3049                 char *fake_tag;
3050 #else
3051                 SV **svh;
3052 #endif
3053                 SV *rsv = ary[i];
3054                 SV *xsv;
3055                 SV *tag;
3056                 AV *av_hook = cxt->hook_seen;
3057
3058                 if (!SvROK(rsv))
3059                         CROAK(("Item #%d returned by STORABLE_freeze "
3060                                 "for %s is not a reference", i, classname));
3061                 xsv = SvRV(rsv);                /* Follow ref to know what to look for */
3062
3063                 /*
3064                  * Look in hseen and see if we have a tag already.
3065                  * Serialize entry if not done already, and get its tag.
3066                  */
3067         
3068 #ifdef USE_PTR_TABLE
3069                 /* Fakery needed because ptr_table_fetch returns zero for a
3070                    failure, whereas the existing code assumes that it can
3071                    safely store a tag zero. So for ptr_tables we store tag+1
3072                 */
3073                 if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv)))
3074                         goto sv_seen;           /* Avoid moving code too far to the right */
3075 #else
3076                 if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
3077                         goto sv_seen;           /* Avoid moving code too far to the right */
3078 #endif
3079
3080                 TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
3081
3082                 /*
3083                  * We need to recurse to store that object and get it to be known
3084                  * so that we can resolve the list of object-IDs at retrieve time.
3085                  *
3086                  * The first time we do this, we need to emit the proper header
3087                  * indicating that we recursed, and what the type of object is (the
3088                  * object we're storing via a user-hook).  Indeed, during retrieval,
3089                  * we'll have to create the object before recursing to retrieve the
3090                  * others, in case those would point back at that object.
3091                  */
3092
3093                 /* [SX_HOOK] <flags> [<extra>] <object>*/
3094                 if (!recursed++) {
3095                         PUTMARK(SX_HOOK);
3096                         PUTMARK(flags);
3097                         if (obj_type == SHT_EXTRA)
3098                                 PUTMARK(eflags);
3099                 } else
3100                         PUTMARK(flags);
3101
3102                 if ((ret = store(aTHX_ cxt, xsv)))      /* Given by hook for us to store */
3103                         return ret;
3104
3105 #ifdef USE_PTR_TABLE
3106                 fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv);
3107                 if (!sv)
3108                         CROAK(("Could not serialize item #%d from hook in %s", i, classname));
3109 #else
3110                 svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
3111                 if (!svh)
3112                         CROAK(("Could not serialize item #%d from hook in %s", i, classname));
3113 #endif
3114                 /*
3115                  * It was the first time we serialized `xsv'.
3116                  *
3117                  * Keep this SV alive until the end of the serialization: if we
3118                  * disposed of it right now by decrementing its refcount, and it was
3119                  * a temporary value, some next temporary value allocated during
3120                  * another STORABLE_freeze might take its place, and we'd wrongly
3121                  * assume that new SV was already serialized, based on its presence
3122                  * in cxt->hseen.
3123                  *
3124                  * Therefore, push it away in cxt->hook_seen.
3125                  */
3126
3127                 av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv));
3128
3129         sv_seen:
3130                 /*
3131                  * Dispose of the REF they returned.  If we saved the `xsv' away
3132                  * in the array of returned SVs, that will not cause the underlying
3133                  * referenced SV to be reclaimed.
3134                  */
3135
3136                 ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF"));
3137                 SvREFCNT_dec(rsv);                      /* Dispose of reference */
3138
3139                 /*
3140                  * Replace entry with its tag (not a real SV, so no refcnt increment)
3141                  */
3142
3143 #ifdef USE_PTR_TABLE
3144                 tag = (SV *)--fake_tag;
3145 #else
3146                 tag = *svh;
3147 #endif
3148                 ary[i] = tag;
3149                 TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf,
3150                          i-1, PTR2UV(xsv), PTR2UV(tag)));
3151         }
3152
3153         /*
3154          * Allocate a class ID if not already done.
3155          *
3156          * This needs to be done after the recursion above, since at retrieval
3157          * time, we'll see the inner objects first.  Many thanks to
3158          * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and
3159          * proposed the right fix.  -- RAM, 15/09/2000
3160          */
3161
3162 check_done:
3163         if (!known_class(aTHX_ cxt, classname, len, &classnum)) {
3164                 TRACEME(("first time we see class %s, ID = %d", classname, classnum));
3165                 classnum = -1;                          /* Mark: we must store classname */
3166         } else {
3167                 TRACEME(("already seen class %s, ID = %d", classname, classnum));
3168         }
3169
3170         /*
3171          * Compute leading flags.
3172          */
3173
3174         flags = obj_type;
3175         if (((classnum == -1) ? len : classnum) > LG_SCALAR)
3176                 flags |= SHF_LARGE_CLASSLEN;
3177         if (classnum != -1)
3178                 flags |= SHF_IDX_CLASSNAME;
3179         if (len2 > LG_SCALAR)
3180                 flags |= SHF_LARGE_STRLEN;
3181         if (count > 1)
3182                 flags |= SHF_HAS_LIST;
3183         if (count > (LG_SCALAR + 1))
3184                 flags |= SHF_LARGE_LISTLEN;
3185
3186         /* 
3187          * We're ready to emit either serialized form:
3188          *
3189          *   SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
3190          *   SX_HOOK <flags> <index>           <len2> <str> [<len3> <object-IDs>]
3191          *
3192          * If we recursed, the SX_HOOK has already been emitted.
3193          */
3194
3195         TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
3196                         "class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d",
3197                  recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
3198
3199         /* SX_HOOK <flags> [<extra>] */
3200         if (!recursed) {
3201                 PUTMARK(SX_HOOK);
3202                 PUTMARK(flags);
3203                 if (obj_type == SHT_EXTRA)
3204                         PUTMARK(eflags);
3205         } else
3206                 PUTMARK(flags);
3207
3208         /* <len> <classname> or <index> */
3209         if (flags & SHF_IDX_CLASSNAME) {
3210                 if (flags & SHF_LARGE_CLASSLEN)
3211                         WLEN(classnum);
3212                 else {
3213                         unsigned char cnum = (unsigned char) classnum;
3214                         PUTMARK(cnum);
3215                 }
3216         } else {
3217                 if (flags & SHF_LARGE_CLASSLEN)
3218                         WLEN(len);
3219                 else {
3220                         unsigned char clen = (unsigned char) len;
3221                         PUTMARK(clen);
3222                 }
3223                 WRITE(classname, len);          /* Final \0 is omitted */
3224         }
3225
3226         /* <len2> <frozen-str> */
3227         if (flags & SHF_LARGE_STRLEN) {
3228                 I32 wlen2 = len2;               /* STRLEN might be 8 bytes */
3229                 WLEN(wlen2);                    /* Must write an I32 for 64-bit machines */
3230         } else {
3231                 unsigned char clen = (unsigned char) len2;
3232                 PUTMARK(clen);
3233         }
3234         if (len2)
3235                 WRITE(pv, (SSize_t)len2);       /* Final \0 is omitted */
3236
3237         /* [<len3> <object-IDs>] */
3238         if (flags & SHF_HAS_LIST) {
3239                 int len3 = count - 1;
3240                 if (flags & SHF_LARGE_LISTLEN)
3241                         WLEN(len3);
3242                 else {
3243                         unsigned char clen = (unsigned char) len3;
3244                         PUTMARK(clen);
3245                 }
3246
3247                 /*
3248                  * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a
3249                  * real pointer, rather a tag number, well under the 32-bit limit.
3250                  */
3251
3252                 for (i = 1; i < count; i++) {
3253                         I32 tagval = htonl(LOW_32BITS(ary[i]));
3254                         WRITE_I32(tagval);
3255                         TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
3256                 }
3257         }
3258
3259         /*
3260          * Free the array.  We need extra care for indices after 0, since they
3261          * don't hold real SVs but integers cast.
3262          */
3263
3264         if (count > 1)
3265                 AvFILLp(av) = 0;        /* Cheat, nothing after 0 interests us */
3266         av_undef(av);
3267         sv_free((SV *) av);
3268
3269         /*
3270          * If object was tied, need to insert serialization of the magic object.
3271          */
3272
3273         if (obj_type == SHT_EXTRA) {
3274                 MAGIC *mg;
3275
3276                 if (!(mg = mg_find(sv, mtype))) {
3277                         int svt = SvTYPE(sv);
3278                         CROAK(("No magic '%c' found while storing ref to tied %s with hook",
3279                                 mtype, (svt == SVt_PVHV) ? "hash" :
3280                                         (svt == SVt_PVAV) ? "array" : "scalar"));
3281                 }
3282
3283                 TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf,
3284                         PTR2UV(mg->mg_obj), PTR2UV(sv)));
3285
3286                 /*
3287                  * [<magic object>]
3288                  */
3289
3290                 if ((ret = store(aTHX_ cxt, mg->mg_obj)))       /* Extra () for -Wall, grr... */
3291                         return ret;
3292         }
3293
3294         return 0;
3295 }
3296
3297 /*
3298  * store_blessed        -- dispatched manually, not via sv_store[]
3299  *
3300  * Check whether there is a STORABLE_xxx hook defined in the class or in one
3301  * of its ancestors.  If there is, then redispatch to store_hook();
3302  *
3303  * Otherwise, the blessed SV is stored using the following layout:
3304  *
3305  *    SX_BLESS <flag> <len> <classname> <object>
3306  *
3307  * where <flag> indicates whether <len> is stored on 0 or 4 bytes, depending
3308  * on the high-order bit in flag: if 1, then length follows on 4 bytes.
3309  * Otherwise, the low order bits give the length, thereby giving a compact
3310  * representation for class names less than 127 chars long.
3311  *
3312  * Each <classname> seen is remembered and indexed, so that the next time
3313  * an object in the blessed in the same <classname> is stored, the following
3314  * will be emitted:
3315  *
3316  *    SX_IX_BLESS <flag> <index> <object>
3317  *
3318  * where <index> is the classname index, stored on 0 or 4 bytes depending
3319  * on the high-order bit in flag (same encoding as above for <len>).
3320  */
3321 static int store_blessed(
3322         pTHX_
3323         stcxt_t *cxt,
3324         SV *sv,
3325         int type,
3326         HV *pkg)
3327 {
3328         SV *hook;
3329         I32 len;
3330         char *classname;
3331         I32 classnum;
3332
3333         TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg)));
3334
3335         /*
3336          * Look for a hook for this blessed SV and redirect to store_hook()
3337          * if needed.
3338          */
3339
3340         hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
3341         if (hook)
3342                 return store_hook(aTHX_ cxt, sv, type, pkg, hook);
3343
3344         /*
3345          * This is a blessed SV without any serialization hook.
3346          */
3347
3348         classname = HvNAME_get(pkg);
3349         len = strlen(classname);
3350
3351         TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d",
3352                  PTR2UV(sv), classname, cxt->tagnum));
3353
3354         /*
3355          * Determine whether it is the first time we see that class name (in which
3356          * case it will be stored in the SX_BLESS form), or whether we already
3357          * saw that class name before (in which case the SX_IX_BLESS form will be
3358          * used).
3359          */
3360
3361         if (known_class(aTHX_ cxt, classname, len, &classnum)) {
3362                 TRACEME(("already seen class %s, ID = %d", classname, classnum));
3363                 PUTMARK(SX_IX_BLESS);
3364                 if (classnum <= LG_BLESS) {
3365                         unsigned char cnum = (unsigned char) classnum;
3366                         PUTMARK(cnum);
3367                 } else {
3368                         unsigned char flag = (unsigned char) 0x80;
3369                         PUTMARK(flag);
3370                         WLEN(classnum);
3371                 }
3372         } else {
3373                 TRACEME(("first time we see class %s, ID = %d", classname, classnum));
3374                 PUTMARK(SX_BLESS);
3375                 if (len <= LG_BLESS) {
3376                         unsigned char clen = (unsigned char) len;
3377                         PUTMARK(clen);
3378                 } else {
3379                         unsigned char flag = (unsigned char) 0x80;
3380                         PUTMARK(flag);
3381                         WLEN(len);                                      /* Don't BER-encode, this should be rare */
3382                 }
3383                 WRITE(classname, len);                          /* Final \0 is omitted */
3384         }
3385
3386         /*
3387          * Now emit the <object> part.
3388          */
3389
3390         return SV_STORE(type)(aTHX_ cxt, sv);
3391 }
3392
3393 /*
3394  * store_other
3395  *
3396  * We don't know how to store the item we reached, so return an error condition.
3397  * (it's probably a GLOB, some CODE reference, etc...)
3398  *
3399  * If they defined the `forgive_me' variable at the Perl level to some
3400  * true value, then don't croak, just warn, and store a placeholder string
3401  * instead.
3402  */
3403 static int store_other(pTHX_ stcxt_t *cxt, SV *sv)
3404 {
3405         I32 len;
3406         char buf[80];
3407
3408         TRACEME(("store_other"));
3409
3410         /*
3411          * Fetch the value from perl only once per store() operation.
3412          */
3413
3414         if (
3415                 cxt->forgive_me == 0 ||
3416                 (cxt->forgive_me < 0 && !(cxt->forgive_me =
3417                         SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
3418         )
3419                 CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
3420
3421         warn("Can't store item %s(0x%"UVxf")",
3422                 sv_reftype(sv, FALSE), PTR2UV(sv));
3423
3424         /*
3425          * Store placeholder string as a scalar instead...
3426          */
3427
3428         (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE),
3429                        PTR2UV(sv), (char) 0);
3430
3431         len = strlen(buf);
3432         STORE_SCALAR(buf, len);
3433         TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, (IV) len));
3434
3435         return 0;
3436 }
3437
3438 /***
3439  *** Store driving routines
3440  ***/
3441
3442 /*
3443  * sv_type
3444  *
3445  * WARNING: partially duplicates Perl's sv_reftype for speed.
3446  *
3447  * Returns the type of the SV, identified by an integer. That integer
3448  * may then be used to index the dynamic routine dispatch table.
3449  */
3450 static int sv_type(pTHX_ SV *sv)
3451 {
3452         switch (SvTYPE(sv)) {
3453         case SVt_NULL:
3454 #if PERL_VERSION <= 10
3455         case SVt_IV:
3456 #endif
3457         case SVt_NV:
3458                 /*
3459                  * No need to check for ROK, that can't be set here since there
3460                  * is no field capable of hodling the xrv_rv reference.
3461                  */
3462                 return svis_SCALAR;
3463         case SVt_PV:
3464 #if PERL_VERSION <= 10
3465         case SVt_RV:
3466 #else
3467         case SVt_IV:
3468 #endif
3469         case SVt_PVIV:
3470         case SVt_PVNV:
3471                 /*
3472                  * Starting from SVt_PV, it is possible to have the ROK flag
3473                  * set, the pointer to the other SV being either stored in
3474                  * the xrv_rv (in the case of a pure SVt_RV), or as the
3475                  * xpv_pv field of an SVt_PV and its heirs.
3476                  *
3477                  * However, those SV cannot be magical or they would be an
3478                  * SVt_PVMG at least.
3479                  */
3480                 return SvROK(sv) ? svis_REF : svis_SCALAR;
3481         case SVt_PVMG:
3482         case SVt_PVLV:          /* Workaround for perl5.004_04 "LVALUE" bug */
3483                 if (SvRMAGICAL(sv) && (mg_find(sv, 'p')))
3484                         return svis_TIED_ITEM;
3485                 /* FALL THROUGH */
3486 #if PERL_VERSION < 9
3487         case SVt_PVBM:
3488 #endif
3489                 if (SvRMAGICAL(sv) && (mg_find(sv, 'q')))
3490                         return svis_TIED;
3491                 return SvROK(sv) ? svis_REF : svis_SCALAR;
3492         case SVt_PVAV:
3493                 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
3494                         return svis_TIED;
3495                 return svis_ARRAY;
3496         case SVt_PVHV:
3497                 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
3498                         return svis_TIED;
3499                 return svis_HASH;
3500         case SVt_PVCV:
3501                 return svis_CODE;
3502 #if PERL_VERSION > 8
3503         /* case SVt_BIND: */
3504 #endif
3505         default:
3506                 break;
3507         }
3508
3509         return svis_OTHER;
3510 }
3511
3512 /*
3513  * store
3514  *
3515  * Recursively store objects pointed to by the sv to the specified file.
3516  *
3517  * Layout is <content> or SX_OBJECT <tagnum> if we reach an already stored
3518  * object (one for which storage has started -- it may not be over if we have
3519  * a self-referenced structure). This data set forms a stored <object>.
3520  */
3521 static int store(pTHX_ stcxt_t *cxt, SV *sv)
3522 {
3523         SV **svh;
3524         int ret;
3525         int type;
3526 #ifdef USE_PTR_TABLE
3527         struct ptr_tbl *pseen = cxt->pseen;
3528 #else
3529         HV *hseen = cxt->hseen;
3530 #endif
3531
3532         TRACEME(("store (0x%"UVxf")", PTR2UV(sv)));
3533
3534         /*
3535          * If object has already been stored, do not duplicate data.
3536          * Simply emit the SX_OBJECT marker followed by its tag data.
3537          * The tag is always written in network order.
3538          *
3539          * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a
3540          * real pointer, rather a tag number (watch the insertion code below).
3541          * That means it probably safe to assume it is well under the 32-bit limit,
3542          * and makes the truncation safe.
3543          *              -- RAM, 14/09/1999
3544          */
3545
3546 #ifdef USE_PTR_TABLE
3547         svh = (SV **)ptr_table_fetch(pseen, sv);
3548 #else
3549         svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
3550 #endif
3551         if (svh) {
3552                 I32 tagval;
3553
3554                 if (sv == &PL_sv_undef) {
3555                         /* We have seen PL_sv_undef before, but fake it as
3556                            if we have not.
3557
3558                            Not the simplest solution to making restricted
3559                            hashes work on 5.8.0, but it does mean that
3560                            repeated references to the one true undef will
3561                            take up less space in the output file.
3562                         */
3563                         /* Need to jump past the next hv_store, because on the
3564                            second store of undef the old hash value will be
3565                            SvREFCNT_dec()ed, and as Storable cheats horribly
3566                            by storing non-SVs in the hash a SEGV will ensure.
3567                            Need to increase the tag number so that the
3568                            receiver has no idea what games we're up to.  This
3569                            special casing doesn't affect hooks that store
3570                            undef, as the hook routine does its own lookup into
3571                            hseen.  Also this means that any references back
3572                            to PL_sv_undef (from the pathological case of hooks
3573                            storing references to it) will find the seen hash
3574                            entry for the first time, as if we didn't have this
3575                            hackery here. (That hseen lookup works even on 5.8.0
3576                            because it's a key of &PL_sv_undef and a value
3577                            which is a tag number, not a value which is
3578                            PL_sv_undef.)  */
3579                         cxt->tagnum++;
3580                         type = svis_SCALAR;
3581                         goto undef_special_case;
3582                 }
3583                 
3584 #ifdef USE_PTR_TABLE
3585                 tagval = htonl(LOW_32BITS(((char *)svh)-1));
3586 #else
3587                 tagval = htonl(LOW_32BITS(*svh));
3588 #endif
3589
3590                 TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval)));
3591
3592                 PUTMARK(SX_OBJECT);
3593                 WRITE_I32(tagval);
3594                 return 0;
3595         }
3596
3597         /*
3598          * Allocate a new tag and associate it with the address of the sv being
3599          * stored, before recursing...
3600          *
3601          * In order to avoid creating new SvIVs to hold the tagnum we just
3602          * cast the tagnum to an SV pointer and store that in the hash.  This
3603          * means that we must clean up the hash manually afterwards, but gives
3604          * us a 15% throughput increase.
3605          *
3606          */
3607
3608         cxt->tagnum++;
3609 #ifdef USE_PTR_TABLE
3610         ptr_table_store(pseen, sv, INT2PTR(SV*, 1 + cxt->tagnum));
3611 #else
3612         if (!hv_store(hseen,
3613                         (char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0))
3614                 return -1;
3615 #endif
3616
3617         /*
3618          * Store `sv' and everything beneath it, using appropriate routine.
3619          * Abort immediately if we get a non-zero status back.
3620          */
3621
3622         type = sv_type(aTHX_ sv);
3623
3624 undef_special_case:
3625         TRACEME(("storing 0x%"UVxf" tag #%d, type %d...",
3626                  PTR2UV(sv), cxt->tagnum, type));
3627
3628         if (SvOBJECT(sv)) {
3629                 HV *pkg = SvSTASH(sv);
3630                 ret = store_blessed(aTHX_ cxt, sv, type, pkg);
3631         } else
3632                 ret = SV_STORE(type)(aTHX_ cxt, sv);
3633
3634         TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)",
3635                 ret ? "FAILED" : "ok", PTR2UV(sv),
3636                 SvREFCNT(sv), sv_reftype(sv, FALSE)));
3637
3638         return ret;
3639 }
3640
3641 /*
3642  * magic_write
3643  *
3644  * Write magic number and system information into the file.
3645  * Layout is <magic> <network> [<len> <byteorder> <sizeof int> <sizeof long>
3646  * <sizeof ptr>] where <len> is the length of the byteorder hexa string.
3647  * All size and lenghts are written as single characters here.
3648  *
3649  * Note that no byte ordering info is emitted when <network> is true, since
3650  * integers will be emitted in network order in that case.
3651  */
3652 static int magic_write(pTHX_ stcxt_t *cxt)
3653 {
3654     /*
3655      * Starting with 0.6, the "use_network_order" byte flag is also used to
3656      * indicate the version number of the binary image, encoded in the upper
3657      * bits. The bit 0 is always used to indicate network order.
3658      */
3659     /*
3660      * Starting with 0.7, a full byte is dedicated to the minor version of
3661      * the binary format, which is incremented only when new markers are
3662      * introduced, for instance, but when backward compatibility is preserved.
3663      */
3664
3665     /* Make these at compile time.  The WRITE() macro is sufficiently complex
3666        that it saves about 200 bytes doing it this way and only using it
3667        once.  */
3668     static const unsigned char network_file_header[] = {
3669         MAGICSTR_BYTES,
3670         (STORABLE_BIN_MAJOR << 1) | 1,
3671         STORABLE_BIN_WRITE_MINOR
3672     };
3673     static const unsigned char file_header[] = {
3674         MAGICSTR_BYTES,
3675         (STORABLE_BIN_MAJOR << 1) | 0,
3676         STORABLE_BIN_WRITE_MINOR,
3677         /* sizeof the array includes the 0 byte at the end:  */
3678         (char) sizeof (byteorderstr) - 1,
3679         BYTEORDER_BYTES,
3680         (unsigned char) sizeof(int),
3681         (unsigned char) sizeof(long),
3682         (unsigned char) sizeof(char *),
3683         (unsigned char) sizeof(NV)
3684     };
3685 #ifdef USE_56_INTERWORK_KLUDGE
3686     static const unsigned char file_header_56[] = {
3687         MAGICSTR_BYTES,
3688         (STORABLE_BIN_MAJOR << 1) | 0,
3689         STORABLE_BIN_WRITE_MINOR,
3690         /* sizeof the array includes the 0 byte at the end:  */
3691         (char) sizeof (byteorderstr_56) - 1,
3692         BYTEORDER_BYTES_56,
3693         (unsigned char) sizeof(int),
3694         (unsigned char) sizeof(long),
3695         (unsigned char) sizeof(char *),
3696         (unsigned char) sizeof(NV)
3697     };
3698 #endif
3699     const unsigned char *header;
3700     SSize_t length;
3701
3702     TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) : -1));
3703
3704     if (cxt->netorder) {
3705         header = network_file_header;
3706         length = sizeof (network_file_header);
3707     } else {
3708 #ifdef USE_56_INTERWORK_KLUDGE
3709         if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) {
3710             header = file_header_56;
3711             length = sizeof (file_header_56);
3712         } else
3713 #endif
3714         {
3715             header = file_header;
3716             length = sizeof (file_header);
3717         }
3718     }        
3719
3720     if (!cxt->fio) {
3721         /* sizeof the array includes the 0 byte at the end.  */
3722         header += sizeof (magicstr) - 1;
3723         length -= sizeof (magicstr) - 1;
3724     }        
3725
3726     WRITE( (unsigned char*) header, length);
3727
3728     if (!cxt->netorder) {
3729         TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
3730                  (unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1,
3731                  (int) sizeof(int), (int) sizeof(long),
3732                  (int) sizeof(char *), (int) sizeof(NV)));
3733     }
3734     return 0;
3735 }
3736
3737 /*
3738  * do_store
3739  *
3740  * Common code for store operations.
3741  *
3742  * When memory store is requested (f = NULL) and a non null SV* is given in
3743  * `res', it is filled with a new SV created out of the memory buffer.
3744  *
3745  * It is required to provide a non-null `res' when the operation type is not
3746  * dclone() and store() is performed to memory.
3747  */
3748 static int do_store(
3749         pTHX_
3750         PerlIO *f,
3751         SV *sv,
3752         int optype,
3753         int network_order,
3754         SV **res)
3755 {
3756         dSTCXT;
3757         int status;
3758
3759         ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res,
3760                 ("must supply result SV pointer for real recursion to memory"));
3761
3762         TRACEME(("do_store (optype=%d, netorder=%d)",
3763                 optype, network_order));
3764
3765         optype |= ST_STORE;
3766
3767         /*
3768          * Workaround for CROAK leak: if they enter with a "dirty" context,
3769          * free up memory for them now.
3770          */
3771
3772         if (cxt->s_dirty)
3773                 clean_context(aTHX_ cxt);
3774
3775         /*
3776          * Now that STORABLE_xxx hooks exist, it is possible that they try to
3777          * re-enter store() via the hooks.  We need to stack contexts.
3778          */
3779
3780         if (cxt->entry)
3781                 cxt = allocate_context(aTHX_ cxt);
3782
3783         cxt->entry++;
3784
3785         ASSERT(cxt->entry == 1, ("starting new recursion"));
3786         ASSERT(!cxt->s_dirty, ("clean context"));
3787
3788         /*
3789          * Ensure sv is actually a reference. From perl, we called something
3790          * like:
3791          *       pstore(aTHX_ FILE, \@array);
3792          * so we must get the scalar value behind that reference.
3793          */
3794
3795         if (!SvROK(sv))
3796                 CROAK(("Not a reference"));
3797         sv = SvRV(sv);                  /* So follow it to know what to store */
3798
3799         /* 
3800          * If we're going to store to memory, reset the buffer.
3801          */
3802
3803         if (!f)
3804                 MBUF_INIT(0);
3805
3806         /*
3807          * Prepare context and emit headers.
3808          */
3809
3810         init_store_context(aTHX_ cxt, f, optype, network_order);
3811
3812         if (-1 == magic_write(aTHX_ cxt))               /* Emit magic and ILP info */
3813                 return 0;                                       /* Error */
3814
3815         /*
3816          * Recursively store object...
3817          */
3818
3819         ASSERT(is_storing(aTHX), ("within store operation"));
3820
3821         status = store(aTHX_ cxt, sv);          /* Just do it! */
3822
3823         /*
3824          * If they asked for a memory store and they provided an SV pointer,
3825          * make an SV string out of the buffer and fill their pointer.
3826          *
3827          * When asking for ST_REAL, it's MANDATORY for the caller to provide
3828          * an SV, since context cleanup might free the buffer if we did recurse.
3829          * (unless caller is dclone(), which is aware of that).
3830          */
3831
3832         if (!cxt->fio && res)
3833                 *res = mbuf2sv(aTHX);
3834
3835         /*
3836          * Final cleanup.
3837          *
3838          * The "root" context is never freed, since it is meant to be always
3839          * handy for the common case where no recursion occurs at all (i.e.
3840          * we enter store() outside of any Storable code and leave it, period).
3841          * We know it's the "root" context because there's nothing stacked
3842          * underneath it.
3843          *
3844          * OPTIMIZATION:
3845          *
3846          * When deep cloning, we don't free the context: doing so would force
3847          * us to copy the data in the memory buffer.  Sicne we know we're
3848          * about to enter do_retrieve...
3849          */
3850
3851         clean_store_context(aTHX_ cxt);
3852         if (cxt->prev && !(cxt->optype & ST_CLONE))
3853                 free_context(aTHX_ cxt);
3854
3855         TRACEME(("do_store returns %d", status));
3856
3857         return status == 0;
3858 }
3859
3860 /***
3861  *** Memory stores.
3862  ***/
3863
3864 /*
3865  * mbuf2sv
3866  *
3867  * Build a new SV out of the content of the internal memory buffer.
3868  */
3869 static SV *mbuf2sv(pTHX)
3870 {
3871         dSTCXT;
3872
3873         return newSVpv(mbase, MBUF_SIZE());
3874 }
3875
3876 /***
3877  *** Specific retrieve callbacks.
3878  ***/
3879
3880 /*
3881  * retrieve_other
3882  *
3883  * Return an error via croak, since it is not possible that we get here
3884  * under normal conditions, when facing a file produced via pstore().
3885  */
3886 static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname)
3887 {
3888         PERL_UNUSED_ARG(cname);
3889         if (
3890                 cxt->ver_major != STORABLE_BIN_MAJOR &&
3891                 cxt->ver_minor != STORABLE_BIN_MINOR
3892         ) {
3893                 CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d",
3894                         cxt->fio ? "file" : "string",
3895                         cxt->ver_major, cxt->ver_minor,
3896                         STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
3897         } else {
3898                 CROAK(("Corrupted storable %s (binary v%d.%d)",
3899                         cxt->fio ? "file" : "string",
3900                         cxt->ver_major, cxt->ver_minor));
3901         }
3902
3903         return (SV *) 0;                /* Just in case */
3904 }
3905
3906 /*
3907  * retrieve_idx_blessed
3908  *
3909  * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
3910  * <index> can be coded on either 1 or 5 bytes.
3911  */
3912 static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname)
3913 {
3914         I32 idx;
3915         const char *classname;
3916         SV **sva;
3917         SV *sv;
3918
3919         PERL_UNUSED_ARG(cname);
3920         TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum));
3921         ASSERT(!cname, ("no bless-into class given here, got %s", cname));
3922
3923         GETMARK(idx);                   /* Index coded on a single char? */
3924         if (idx & 0x80)
3925                 RLEN(idx);
3926
3927         /*
3928          * Fetch classname in `aclass'
3929          */
3930
3931         sva = av_fetch(cxt->aclass, idx, FALSE);
3932         if (!sva)
3933                 CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx));
3934
3935         classname = SvPVX(*sva);        /* We know it's a PV, by construction */
3936
3937         TRACEME(("class ID %d => %s", idx, classname));
3938
3939         /*
3940          * Retrieve object and bless it.
3941          */
3942
3943         sv = retrieve(aTHX_ cxt, classname);    /* First SV which is SEEN will be blessed */
3944
3945         return sv;
3946 }
3947
3948 /*
3949  * retrieve_blessed
3950  *
3951  * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
3952  * <len> can be coded on either 1 or 5 bytes.
3953  */
3954 static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
3955 {
3956         I32 len;
3957         SV *sv;
3958         char buf[LG_BLESS + 1];         /* Avoid malloc() if possible */
3959         char *classname = buf;
3960         char *malloced_classname = NULL;
3961
3962         PERL_UNUSED_ARG(cname);
3963         TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
3964         ASSERT(!cname, ("no bless-into&nb