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