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