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