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