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