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