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