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