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