This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix a null pointer dereference segfault in Storable.
[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; \
741002cc 1049 TRACEME(("aseen(#%d) = 0x%" UVxf " (refcnt=%d)", cxt->tagnum-1, \
997ca471
DM
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; \
741002cc 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));
741002cc 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 {
741002cc 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++) {
741002cc 1882 TRACEME(("pushing arg #%d (0x%" UVxf ")...",
43d061fe 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;
741002cc 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;
741002cc
KW
2016 TRACEME(("ref (0x%" UVxf ") is%s weak", PTR2UV(sv), is_weak
2017 ? ""
2018 : "n't"));
c3c53033 2019#endif
7a6a85bf
RG
2020 sv = SvRV(sv);
2021
2022 if (SvOBJECT(sv)) {
2023 HV *stash = (HV *) SvSTASH(sv);
2024 if (stash && Gv_AMG(stash)) {
741002cc 2025 TRACEME(("ref (0x%" UVxf ") is overloaded", PTR2UV(sv)));
c3c53033 2026 PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD);
7a6a85bf 2027 } else
c3c53033 2028 PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
7a6a85bf 2029 } else
c3c53033 2030 PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
7a6a85bf 2031
138ec36d 2032 return store(aTHX_ cxt, sv);
7a6a85bf
RG
2033}
2034
2035/*
2036 * store_scalar
2037 *
2038 * Store a scalar.
2039 *
e16e2ff8 2040 * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
a137b8e5 2041 * SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings.
7a6a85bf
RG
2042 * The <data> section is omitted if <length> is 0.
2043 *
e00e3c3e
FC
2044 * For vstrings, the vstring portion is stored first with
2045 * SX_LVSTRING <length> <data> or SX_VSTRING <length> <data>, followed by
2046 * SX_(L)SCALAR or SX_(L)UTF8STR with the actual PV.
2047 *
7a6a85bf
RG
2048 * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
2049 * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
2050 */
138ec36d 2051static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
7a6a85bf
RG
2052{
2053 IV iv;
2054 char *pv;
2055 STRLEN len;
2056 U32 flags = SvFLAGS(sv); /* "cc -O" may put it in register */
2057
741002cc 2058 TRACEME(("store_scalar (0x%" UVxf ")", PTR2UV(sv)));
7a6a85bf
RG
2059
2060 /*
2061 * For efficiency, break the SV encapsulation by peaking at the flags
2062 * directly without using the Perl macros to avoid dereferencing
2063 * sv->sv_flags each time we wish to check the flags.
2064 */
2065
2066 if (!(flags & SVf_OK)) { /* !SvOK(sv) */
2067 if (sv == &PL_sv_undef) {
2068 TRACEME(("immortal undef"));
2069 PUTMARK(SX_SV_UNDEF);
2070 } else {
741002cc 2071 TRACEME(("undef at 0x%" UVxf, PTR2UV(sv)));
7a6a85bf
RG
2072 PUTMARK(SX_UNDEF);
2073 }
2074 return 0;
2075 }
2076
2077 /*
2078 * Always store the string representation of a scalar if it exists.
2079 * Gisle Aas provided me with this test case, better than a long speach:
2080 *
2081 * perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)'
2082 * SV = PVNV(0x80c8520)
2083 * REFCNT = 1
2084 * FLAGS = (NOK,POK,pNOK,pPOK)
2085 * IV = 0
2086 * NV = 0
2087 * PV = 0x80c83d0 "abc"\0
2088 * CUR = 3
2089 * LEN = 4
2090 *
2091 * Write SX_SCALAR, length, followed by the actual data.
2092 *
2093 * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as
2094 * appropriate, followed by the actual (binary) data. A double
2095 * is written as a string if network order, for portability.
2096 *
2097 * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv).
2098 * The reason is that when the scalar value is tainted, the SvNOK(sv)
2099 * value is false.
2100 *
2101 * The test for a read-only scalar with both POK and NOK set is meant
2102 * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the
2103 * address comparison for each scalar we store.
2104 */
2105
2106#define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK)
2107
2108 if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) {
2109 if (sv == &PL_sv_yes) {
2110 TRACEME(("immortal yes"));
2111 PUTMARK(SX_SV_YES);
2112 } else if (sv == &PL_sv_no) {
2113 TRACEME(("immortal no"));
2114 PUTMARK(SX_SV_NO);
2115 } else {
2116 pv = SvPV(sv, len); /* We know it's SvPOK */
2117 goto string; /* Share code below */
2118 }
db670f21
NC
2119 } else if (flags & SVf_POK) {
2120 /* public string - go direct to string read. */
2121 goto string_readlen;
2122 } else if (
2123#if (PATCHLEVEL <= 6)
2124 /* For 5.6 and earlier NV flag trumps IV flag, so only use integer
2125 direct if NV flag is off. */
2126 (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK
2127#else
2128 /* 5.7 rules are that if IV public flag is set, IV value is as
2129 good, if not better, than NV value. */
2130 flags & SVf_IOK
2131#endif
2132 ) {
2133 iv = SvIV(sv);
2134 /*
2135 * Will come here from below with iv set if double is an integer.
2136 */
2137 integer:
7a6a85bf 2138
db670f21
NC
2139 /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
2140#ifdef SVf_IVisUV
2141 /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1
2142 * (for example) and that ends up in the optimised small integer
2143 * case.
2144 */
2145 if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) {
741002cc
KW
2146 TRACEME(("large unsigned integer as string, value = %" UVuf,
2147 SvUV(sv)));
db670f21
NC
2148 goto string_readlen;
2149 }
2150#endif
2151 /*
2152 * Optimize small integers into a single byte, otherwise store as
2153 * a real integer (converted into network order if they asked).
2154 */
7a6a85bf 2155
db670f21
NC
2156 if (iv >= -128 && iv <= 127) {
2157 unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
2158 PUTMARK(SX_BYTE);
2159 PUTMARK(siv);
2160 TRACEME(("small integer stored as %d", siv));
2161 } else if (cxt->netorder) {
2162#ifndef HAS_HTONL
2163 TRACEME(("no htonl, fall back to string for integer"));
2164 goto string_readlen;
2165#else
2166 I32 niv;
7a6a85bf 2167
7a6a85bf 2168
db670f21
NC
2169#if IVSIZE > 4
2170 if (
2171#ifdef SVf_IVisUV
2172 /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
41c44503 2173 ((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) ||
db670f21 2174#endif
41c44503 2175 (iv > (IV)0x7FFFFFFF) || (iv < -(IV)0x80000000)) {
db670f21 2176 /* Bigger than 32 bits. */
741002cc
KW
2177 TRACEME(("large network order integer as string, value = %"
2178 IVdf, iv));
db670f21
NC
2179 goto string_readlen;
2180 }
2181#endif
7a6a85bf 2182
db670f21
NC
2183 niv = (I32) htonl((I32) iv);
2184 TRACEME(("using network order"));
2185 PUTMARK(SX_NETINT);
2186 WRITE_I32(niv);
2187#endif
2188 } else {
2189 PUTMARK(SX_INTEGER);
2190 WRITE(&iv, sizeof(iv));
2191 }
2192
741002cc
KW
2193 TRACEME(("ok (integer 0x%" UVxf ", value = %" IVdf ")",
2194 PTR2UV(sv), iv));
db670f21
NC
2195 } else if (flags & SVf_NOK) {
2196 NV nv;
2197#if (PATCHLEVEL <= 6)
2198 nv = SvNV(sv);
2199 /*
2200 * Watch for number being an integer in disguise.
2201 */
2202 if (nv == (NV) (iv = I_V(nv))) {
741002cc 2203 TRACEME(("double %" NVff " is actually integer %" IVdf, nv, iv));
db670f21
NC
2204 goto integer; /* Share code above */
2205 }
2206#else
7a6a85bf 2207
db670f21 2208 SvIV_please(sv);
3ddd445a 2209 if (SvIOK_notUV(sv)) {
db670f21
NC
2210 iv = SvIV(sv);
2211 goto integer; /* Share code above */
2212 }
2213 nv = SvNV(sv);
2214#endif
7a6a85bf 2215
db670f21 2216 if (cxt->netorder) {
741002cc 2217 TRACEME(("double %" NVff " stored as string", nv));
db670f21
NC
2218 goto string_readlen; /* Share code below */
2219 }
7a6a85bf 2220
db670f21
NC
2221 PUTMARK(SX_DOUBLE);
2222 WRITE(&nv, sizeof(nv));
7a6a85bf 2223
741002cc
KW
2224 TRACEME(("ok (double 0x%" UVxf ", value = %" NVff ")",
2225 PTR2UV(sv), nv));
7a6a85bf 2226
db670f21 2227 } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) {
e00e3c3e
FC
2228#ifdef SvVOK
2229 MAGIC *mg;
2230#endif
db670f21 2231 I32 wlen; /* For 64-bit machines */
7a6a85bf 2232
db670f21
NC
2233 string_readlen:
2234 pv = SvPV(sv, len);
7a6a85bf 2235
db670f21
NC
2236 /*
2237 * Will come here from above if it was readonly, POK and NOK but
2238 * neither &PL_sv_yes nor &PL_sv_no.
2239 */
2240 string:
2241
e00e3c3e 2242#ifdef SvVOK
d2af8e81
NC
2243 if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) {
2244 /* The macro passes this by address, not value, and a lot of
0cc24529 2245 called code assumes that it's 32 bits without checking. */
d2af8e81 2246 const int len = mg->mg_len;
e00e3c3e 2247 STORE_PV_LEN((const char *)mg->mg_ptr,
d2af8e81
NC
2248 len, SX_VSTRING, SX_LVSTRING);
2249 }
e00e3c3e
FC
2250#endif
2251
db670f21
NC
2252 wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
2253 if (SvUTF8 (sv))
2254 STORE_UTF8STR(pv, wlen);
2255 else
2256 STORE_SCALAR(pv, wlen);
741002cc 2257 TRACEME(("ok (scalar 0x%" UVxf " '%s', length = %" IVdf ")",
db670f21 2258 PTR2UV(sv), SvPVX(sv), (IV)len));
7a6a85bf 2259 } else
741002cc 2260 CROAK(("Can't determine type of %s(0x%" UVxf ")",
db670f21
NC
2261 sv_reftype(sv, FALSE),
2262 PTR2UV(sv)));
2263 return 0; /* Ok, no recursion on scalars */
7a6a85bf
RG
2264}
2265
2266/*
2267 * store_array
2268 *
2269 * Store an array.
2270 *
c4a6f826 2271 * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
7a6a85bf
RG
2272 * Each item is stored as <object>.
2273 */
138ec36d 2274static int store_array(pTHX_ stcxt_t *cxt, AV *av)
7a6a85bf
RG
2275{
2276 SV **sav;
2277 I32 len = av_len(av) + 1;
2278 I32 i;
2279 int ret;
2280
741002cc 2281 TRACEME(("store_array (0x%" UVxf ")", PTR2UV(av)));
7a6a85bf
RG
2282
2283 /*
2284 * Signal array by emitting SX_ARRAY, followed by the array length.
2285 */
2286
2287 PUTMARK(SX_ARRAY);
2288 WLEN(len);
2289 TRACEME(("size = %d", len));
2290
2291 /*
2292 * Now store each item recursively.
2293 */
2294
2295 for (i = 0; i < len; i++) {
2296 sav = av_fetch(av, i, 0);
2297 if (!sav) {
ce0d59fd 2298 TRACEME(("(#%d) nonexistent item", i));
20bb3f55 2299 STORE_SV_UNDEF();
7a6a85bf
RG
2300 continue;
2301 }
ce0d59fd
FC
2302#if PATCHLEVEL >= 19
2303 /* In 5.19.3 and up, &PL_sv_undef can actually be stored in
2304 * an array; it no longer represents nonexistent elements.
2305 * Historically, we have used SX_SV_UNDEF in arrays for
2306 * nonexistent elements, so we use SX_SVUNDEF_ELEM for
2307 * &PL_sv_undef itself. */
2308 if (*sav == &PL_sv_undef) {
2309 TRACEME(("(#%d) undef item", i));
2310 cxt->tagnum++;
2311 PUTMARK(SX_SVUNDEF_ELEM);
2312 continue;
2313 }
2314#endif
7a6a85bf 2315 TRACEME(("(#%d) item", i));
138ec36d 2316 if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
2317 return ret;
2318 }
2319
2320 TRACEME(("ok (array)"));
2321
2322 return 0;
2323}
2324
138ec36d 2325
2326#if (PATCHLEVEL <= 6)
2327
7a6a85bf
RG
2328/*
2329 * sortcmp
2330 *
2331 * Sort two SVs
2332 * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
2333 */
2334static int
f0ffaed8 2335sortcmp(const void *a, const void *b)
7a6a85bf 2336{
138ec36d 2337#if defined(USE_ITHREADS)
2338 dTHX;
2339#endif /* USE_ITHREADS */
2340 return sv_cmp(*(SV * const *) a, *(SV * const *) b);
7a6a85bf
RG
2341}
2342
138ec36d 2343#endif /* PATCHLEVEL <= 6 */
7a6a85bf
RG
2344
2345/*
2346 * store_hash
2347 *
d1be9408 2348 * Store a hash table.
7a6a85bf 2349 *
e16e2ff8
NC
2350 * For a "normal" hash (not restricted, no utf8 keys):
2351 *
7a6a85bf
RG
2352 * Layout is SX_HASH <size> followed by each key/value pair, in random order.
2353 * Values are stored as <object>.
2354 * Keys are stored as <length> <data>, the <data> section being omitted
2355 * if length is 0.
c194a0a3
TB
2356 *
2357 * For a "fancy" hash (restricted or utf8 keys):
2358 *
2359 * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair,
e16e2ff8
NC
2360 * in random order.
2361 * Values are stored as <object>.
2362 * Keys are stored as <flags> <length> <data>, the <data> section being omitted
2363 * if length is 0.
c4a6f826 2364 * Currently the only hash flag is "restricted"
e16e2ff8 2365 * Key flags are as for hv.h
7a6a85bf 2366 */
138ec36d 2367static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
7a6a85bf 2368{
27da23d5 2369 dVAR;
1c4fe6e3 2370 I32 len = HvTOTALKEYS(hv);
7a6a85bf
RG
2371 I32 i;
2372 int ret = 0;
2373 I32 riter;
2374 HE *eiter;
530b72ba
NC
2375 int flagged_hash = ((SvREADONLY(hv)
2376#ifdef HAS_HASH_KEY_FLAGS
2377 || HvHASKFLAGS(hv)
2378#endif
2379 ) ? 1 : 0);
e16e2ff8 2380 unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
7a6a85bf 2381
e16e2ff8
NC
2382 if (flagged_hash) {
2383 /* needs int cast for C++ compilers, doesn't it? */
741002cc 2384 TRACEME(("store_hash (0x%" UVxf ") (flags %x)", PTR2UV(hv),
e16e2ff8
NC
2385 (int) hash_flags));
2386 } else {
741002cc 2387 TRACEME(("store_hash (0x%" UVxf ")", PTR2UV(hv)));
e16e2ff8 2388 }
7a6a85bf
RG
2389
2390 /*
2391 * Signal hash by emitting SX_HASH, followed by the table length.
2392 */
2393
e16e2ff8
NC
2394 if (flagged_hash) {
2395 PUTMARK(SX_FLAG_HASH);
2396 PUTMARK(hash_flags);
2397 } else {
2398 PUTMARK(SX_HASH);
2399 }
7a6a85bf
RG
2400 WLEN(len);
2401 TRACEME(("size = %d", len));
2402
2403 /*
2404 * Save possible iteration state via each() on that table.
2405 */
2406
bfcb3514
NC
2407 riter = HvRITER_get(hv);
2408 eiter = HvEITER_get(hv);
7a6a85bf
RG
2409 hv_iterinit(hv);
2410
2411 /*
2412 * Now store each item recursively.
2413 *
2414 * If canonical is defined to some true value then store each
2415 * key/value pair in sorted order otherwise the order is random.
2416 * Canonical order is irrelevant when a deep clone operation is performed.
2417 *
2418 * Fetch the value from perl only once per store() operation, and only
2419 * when needed.
2420 */
2421
2422 if (
2423 !(cxt->optype & ST_CLONE) && (cxt->canonical == 1 ||
2424 (cxt->canonical < 0 && (cxt->canonical =
3509f647 2425 (SvTRUE(perl_get_sv("Storable::canonical", GV_ADD)) ? 1 : 0))))
7a6a85bf
RG
2426 ) {
2427 /*
2428 * Storing in order, sorted by key.
2429 * Run through the hash, building up an array of keys in a
2430 * mortal array, sort the array and then run through the
2431 * array.
2432 */
2433
2434 AV *av = newAV();
2435
e16e2ff8
NC
2436 /*av_extend (av, len);*/
2437
7a6a85bf
RG
2438 TRACEME(("using canonical order"));
2439
2440 for (i = 0; i < len; i++) {
530b72ba 2441#ifdef HAS_RESTRICTED_HASHES
e16e2ff8 2442 HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
530b72ba
NC
2443#else
2444 HE *he = hv_iternext(hv);
2445#endif
0d326098
NC
2446 SV *key;
2447
2448 if (!he)
c33e8be1 2449 CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, (int)len, (int)i));
0d326098 2450 key = hv_iterkeysv(he);
7a6a85bf
RG
2451 av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
2452 }
2453
138ec36d 2454 STORE_HASH_SORT;
7a6a85bf
RG
2455
2456 for (i = 0; i < len; i++) {
dfd91409 2457#ifdef HAS_RESTRICTED_HASHES
ca732855 2458 int placeholders = (int)HvPLACEHOLDERS_get(hv);
dfd91409
NC
2459#endif
2460 unsigned char flags = 0;
7a6a85bf 2461 char *keyval;
e16e2ff8
NC
2462 STRLEN keylen_tmp;
2463 I32 keylen;
7a6a85bf 2464 SV *key = av_shift(av);
dfd91409
NC
2465 /* This will fail if key is a placeholder.
2466 Track how many placeholders we have, and error if we
2467 "see" too many. */
7a6a85bf 2468 HE *he = hv_fetch_ent(hv, key, 0, 0);
dfd91409
NC
2469 SV *val;
2470
2471 if (he) {
2472 if (!(val = HeVAL(he))) {
2473 /* Internal error, not I/O error */
2474 return 1;
2475 }
2476 } else {
2477#ifdef HAS_RESTRICTED_HASHES
2478 /* Should be a placeholder. */
2479 if (placeholders-- < 0) {
2480 /* This should not happen - number of
2481 retrieves should be identical to
2482 number of placeholders. */
2483 return 1;
2484 }
2485 /* Value is never needed, and PL_sv_undef is
2486 more space efficient to store. */
2487 val = &PL_sv_undef;
2488 ASSERT (flags == 0,
2489 ("Flags not 0 but %d", flags));
2490 flags = SHV_K_PLACEHOLDER;
2491#else
2492 return 1;
2493#endif
2494 }
7a6a85bf
RG
2495
2496 /*
2497 * Store value first.
2498 */
2499
741002cc 2500 TRACEME(("(#%d) value 0x%" UVxf, i, PTR2UV(val)));
7a6a85bf 2501
138ec36d 2502 if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
2503 goto out;
2504
2505 /*
2506 * Write key string.
2507 * Keys are written after values to make sure retrieval
2508 * can be optimal in terms of memory usage, where keys are
2509 * read into a fixed unique buffer called kbuf.
2510 * See retrieve_hash() for details.
2511 */
2512
e16e2ff8
NC
2513 /* Implementation of restricted hashes isn't nicely
2514 abstracted: */
a991bd3b 2515 if ((hash_flags & SHV_RESTRICTED)
4ea34344 2516 && SvTRULYREADONLY(val)) {
dfd91409
NC
2517 flags |= SHV_K_LOCKED;
2518 }
e16e2ff8
NC
2519
2520 keyval = SvPV(key, keylen_tmp);
2521 keylen = keylen_tmp;
530b72ba
NC
2522#ifdef HAS_UTF8_HASHES
2523 /* If you build without optimisation on pre 5.6
2524 then nothing spots that SvUTF8(key) is always 0,
2525 so the block isn't optimised away, at which point
2526 the linker dislikes the reference to
2527 bytes_from_utf8. */
e16e2ff8
NC
2528 if (SvUTF8(key)) {
2529 const char *keysave = keyval;
2530 bool is_utf8 = TRUE;
2531
2532 /* Just casting the &klen to (STRLEN) won't work
2533 well if STRLEN and I32 are of different widths.
2534 --jhi */
2535 keyval = (char*)bytes_from_utf8((U8*)keyval,
2536 &keylen_tmp,
2537 &is_utf8);
2538
2539 /* If we were able to downgrade here, then than
2540 means that we have a key which only had chars
2541 0-255, but was utf8 encoded. */
2542
2543 if (keyval != keysave) {
2544 keylen = keylen_tmp;
2545 flags |= SHV_K_WASUTF8;
2546 } else {
2547 /* keylen_tmp can't have changed, so no need
2548 to assign back to keylen. */
2549 flags |= SHV_K_UTF8;
2550 }
2551 }
530b72ba 2552#endif
e16e2ff8
NC
2553
2554 if (flagged_hash) {
2555 PUTMARK(flags);
2556 TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval));
2557 } else {
fcaa57e7
AMS
2558 /* This is a workaround for a bug in 5.8.0
2559 that causes the HEK_WASUTF8 flag to be
2560 set on an HEK without the hash being
2561 marked as having key flags. We just
2562 cross our fingers and drop the flag.
2563 AMS 20030901 */
2564 assert (flags == 0 || flags == SHV_K_WASUTF8);
e16e2ff8
NC
2565 TRACEME(("(#%d) key '%s'", i, keyval));
2566 }
7a6a85bf
RG
2567 WLEN(keylen);
2568 if (keylen)
2569 WRITE(keyval, keylen);
e16e2ff8
NC
2570 if (flags & SHV_K_WASUTF8)
2571 Safefree (keyval);
7a6a85bf
RG
2572 }
2573
2574 /*
2575 * Free up the temporary array
2576 */
2577
2578 av_undef(av);
2579 sv_free((SV *) av);
2580
2581 } else {
2582
2583 /*
2584 * Storing in "random" order (in the order the keys are stored
a6d05634 2585 * within the hash). This is the default and will be faster!
7a6a85bf
RG
2586 */
2587
2588 for (i = 0; i < len; i++) {
0bb78401 2589 char *key = 0;
7a6a85bf 2590 I32 len;
e16e2ff8 2591 unsigned char flags;
530b72ba 2592#ifdef HV_ITERNEXT_WANTPLACEHOLDERS
e16e2ff8 2593 HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
530b72ba
NC
2594#else
2595 HE *he = hv_iternext(hv);
2596#endif
e16e2ff8
NC
2597 SV *val = (he ? hv_iterval(hv, he) : 0);
2598 SV *key_sv = NULL;
2599 HEK *hek;
7a6a85bf
RG
2600
2601 if (val == 0)
2602 return 1; /* Internal error, not I/O error */
2603
dfd91409
NC
2604 /* Implementation of restricted hashes isn't nicely
2605 abstracted: */
2606 flags
2607 = (((hash_flags & SHV_RESTRICTED)
4ea34344 2608 && SvTRULYREADONLY(val))
dfd91409
NC
2609 ? SHV_K_LOCKED : 0);
2610
2611 if (val == &PL_sv_placeholder) {
2612 flags |= SHV_K_PLACEHOLDER;
2613 val = &PL_sv_undef;
2614 }
2615
7a6a85bf
RG
2616 /*
2617 * Store value first.
2618 */
2619
741002cc 2620 TRACEME(("(#%d) value 0x%" UVxf, i, PTR2UV(val)));
7a6a85bf 2621
138ec36d 2622 if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
2623 goto out;
2624
e16e2ff8
NC
2625
2626 hek = HeKEY_hek(he);
2627 len = HEK_LEN(hek);
2628 if (len == HEf_SVKEY) {
2629 /* This is somewhat sick, but the internal APIs are
2630 * such that XS code could put one of these in in
2631 * a regular hash.
2632 * Maybe we should be capable of storing one if
2633 * found.
2634 */
2635 key_sv = HeKEY_sv(he);
2636 flags |= SHV_K_ISSV;
2637 } else {
2638 /* Regular string key. */
530b72ba 2639#ifdef HAS_HASH_KEY_FLAGS
e16e2ff8
NC
2640 if (HEK_UTF8(hek))
2641 flags |= SHV_K_UTF8;
2642 if (HEK_WASUTF8(hek))
2643 flags |= SHV_K_WASUTF8;
530b72ba 2644#endif
e16e2ff8
NC
2645 key = HEK_KEY(hek);
2646 }
7a6a85bf
RG
2647 /*
2648 * Write key string.
2649 * Keys are written after values to make sure retrieval
2650 * can be optimal in terms of memory usage, where keys are
2651 * read into a fixed unique buffer called kbuf.
2652 * See retrieve_hash() for details.
2653 */
2654
e16e2ff8
NC
2655 if (flagged_hash) {
2656 PUTMARK(flags);
2657 TRACEME(("(#%d) key '%s' flags %x", i, key, flags));
2658 } else {
fcaa57e7
AMS
2659 /* This is a workaround for a bug in 5.8.0
2660 that causes the HEK_WASUTF8 flag to be
2661 set on an HEK without the hash being
2662 marked as having key flags. We just
2663 cross our fingers and drop the flag.
2664 AMS 20030901 */
2665 assert (flags == 0 || flags == SHV_K_WASUTF8);
e16e2ff8
NC
2666 TRACEME(("(#%d) key '%s'", i, key));
2667 }
2668 if (flags & SHV_K_ISSV) {
8cb8f897
JH
2669 int ret;
2670 if ((ret = store(aTHX_ cxt, key_sv)))
2671 goto out;
e16e2ff8
NC
2672 } else {
2673 WLEN(len);
2674 if (len)
7a6a85bf 2675 WRITE(key, len);
e16e2ff8 2676 }
7a6a85bf
RG
2677 }
2678 }
2679
741002cc 2680 TRACEME(("ok (hash 0x%" UVxf ")", PTR2UV(hv)));
7a6a85bf
RG
2681
2682out:
bfcb3514
NC
2683 HvRITER_set(hv, riter); /* Restore hash iterator state */
2684 HvEITER_set(hv, eiter);
7a6a85bf
RG
2685
2686 return ret;
2687}
2688
2689/*
464b080a
SR
2690 * store_code
2691 *
2692 * Store a code reference.
2693 *
2694 * Layout is SX_CODE <length> followed by a scalar containing the perl
2695 * source code of the code reference.
2696 */
138ec36d 2697static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
464b080a
SR
2698{
2699#if PERL_VERSION < 6
2700 /*
2701 * retrieve_code does not work with perl 5.005 or less
2702 */
138ec36d 2703 return store_other(aTHX_ cxt, (SV*)cv);
464b080a
SR
2704#else
2705 dSP;
2706 I32 len;
c5661c80 2707 int count, reallen;
464b080a
SR
2708 SV *text, *bdeparse;
2709
741002cc 2710 TRACEME(("store_code (0x%" UVxf ")", PTR2UV(cv)));
464b080a
SR
2711
2712 if (
2713 cxt->deparse == 0 ||
2714 (cxt->deparse < 0 && !(cxt->deparse =
3509f647 2715 SvTRUE(perl_get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0))
464b080a 2716 ) {
138ec36d 2717 return store_other(aTHX_ cxt, (SV*)cv);
464b080a
SR
2718 }
2719
2720 /*
2721 * Require B::Deparse. At least B::Deparse 0.61 is needed for
2722 * blessed code references.
2723 */
17625bd2 2724 /* Ownership of both SVs is passed to load_module, which frees them. */
c2b90b61 2725 load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("B::Deparse"), newSVnv(0.61));
85472d4f 2726 SPAGAIN;
464b080a
SR
2727
2728 ENTER;
2729 SAVETMPS;
2730
2731 /*
2732 * create the B::Deparse object
2733 */
2734
2735 PUSHMARK(sp);
afce0a13 2736 XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP));
464b080a
SR
2737 PUTBACK;
2738 count = call_method("new", G_SCALAR);
2739 SPAGAIN;
2740 if (count != 1)
2741 CROAK(("Unexpected return value from B::Deparse::new\n"));
2742 bdeparse = POPs;
2743
2744 /*
2745 * call the coderef2text method
2746 */
2747
2748 PUSHMARK(sp);
2749 XPUSHs(bdeparse); /* XXX is this already mortal? */
2750 XPUSHs(sv_2mortal(newRV_inc((SV*)cv)));
2751 PUTBACK;
2752 count = call_method("coderef2text", G_SCALAR);
2753 SPAGAIN;
2754 if (count != 1)
2755 CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
2756
2757 text = POPs;
dfe4365a 2758 len = SvCUR(text);
e3feee4e 2759 reallen = strlen(SvPV_nolen(text));
464b080a
SR
2760
2761 /*
2762 * Empty code references or XS functions are deparsed as
2763 * "(prototype) ;" or ";".
2764 */
2765
e3feee4e 2766 if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') {
464b080a
SR
2767 CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
2768 }
2769
2770 /*
2771 * Signal code by emitting SX_CODE.
2772 */
2773
2774 PUTMARK(SX_CODE);
a8b7ef86 2775 cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */
464b080a 2776 TRACEME(("size = %d", len));
e3feee4e 2777 TRACEME(("code = %s", SvPV_nolen(text)));
464b080a
SR
2778
2779 /*
2780 * Now store the source code.
2781 */
2782
70b88f41
DL
2783 if(SvUTF8 (text))
2784 STORE_UTF8STR(SvPV_nolen(text), len);
2785 else
2786 STORE_SCALAR(SvPV_nolen(text), len);
464b080a
SR
2787
2788 FREETMPS;
2789 LEAVE;
2790
2791 TRACEME(("ok (code)"));
2792
2793 return 0;
2794#endif
2795}
2796
2797/*
7a6a85bf
RG
2798 * store_tied
2799 *
2800 * When storing a tied object (be it a tied scalar, array or hash), we lay out
2801 * a special mark, followed by the underlying tied object. For instance, when
2802 * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
2803 * <hash object> stands for the serialization of the tied hash.
2804 */
138ec36d 2805static int store_tied(pTHX_ stcxt_t *cxt, SV *sv)
7a6a85bf
RG
2806{
2807 MAGIC *mg;
72edffd8 2808 SV *obj = NULL;
7a6a85bf
RG
2809 int ret = 0;
2810 int svt = SvTYPE(sv);
2811 char mtype = 'P';
2812
741002cc 2813 TRACEME(("store_tied (0x%" UVxf ")", PTR2UV(sv)));
7a6a85bf
RG
2814
2815 /*
2816 * We have a small run-time penalty here because we chose to factorise
2817 * all tieds objects into the same routine, and not have a store_tied_hash,
2818 * a store_tied_array, etc...
2819 *
2820 * Don't use a switch() statement, as most compilers don't optimize that
2821 * well for 2/3 values. An if() else if() cascade is just fine. We put
2822 * tied hashes first, as they are the most likely beasts.
2823 */
2824
2825 if (svt == SVt_PVHV) {
2826 TRACEME(("tied hash"));
2827 PUTMARK(SX_TIED_HASH); /* Introduces tied hash */
2828 } else if (svt == SVt_PVAV) {
2829 TRACEME(("tied array"));
2830 PUTMARK(SX_TIED_ARRAY); /* Introduces tied array */
2831 } else {
2832 TRACEME(("tied scalar"));
2833 PUTMARK(SX_TIED_SCALAR); /* Introduces tied scalar */
2834 mtype = 'q';
2835 }
2836
2837 if (!(mg = mg_find(sv, mtype)))
2838 CROAK(("No magic '%c' found while storing tied %s", mtype,
2839 (svt == SVt_PVHV) ? "hash" :
2840 (svt == SVt_PVAV) ? "array" : "scalar"));
2841
2842 /*
2843 * The mg->mg_obj found by mg_find() above actually points to the
2844 * underlying tied Perl object implementation. For instance, if the
2845 * original SV was that of a tied array, then mg->mg_obj is an AV.
2846 *
2847 * Note that we store the Perl object as-is. We don't call its FETCH
2848 * method along the way. At retrieval time, we won't call its STORE
2849 * method either, but the tieing magic will be re-installed. In itself,
c4a6f826 2850 * that ensures that the tieing semantics are preserved since further
7a6a85bf
RG
2851 * accesses on the retrieved object will indeed call the magic methods...
2852 */
2853
72edffd8
AMS
2854 /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
2855 obj = mg->mg_obj ? mg->mg_obj : newSV(0);
138ec36d 2856 if ((ret = store(aTHX_ cxt, obj)))
7a6a85bf
RG
2857 return ret;
2858
2859 TRACEME(("ok (tied)"));
2860
2861 return 0;
2862}
2863
2864/*
2865 * store_tied_item
2866 *
2867 * Stores a reference to an item within a tied structure:
2868 *
2869 * . \$h{key}, stores both the (tied %h) object and 'key'.
2870 * . \$a[idx], stores both the (tied @a) object and 'idx'.
2871 *
2872 * Layout is therefore either:
2873 * SX_TIED_KEY <object> <key>
2874 * SX_TIED_IDX <object> <index>
2875 */
138ec36d 2876static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv)
7a6a85bf
RG
2877{
2878 MAGIC *mg;
2879 int ret;
2880
741002cc 2881 TRACEME(("store_tied_item (0x%" UVxf ")", PTR2UV(sv)));
7a6a85bf
RG
2882
2883 if (!(mg = mg_find(sv, 'p')))
2884 CROAK(("No magic 'p' found while storing reference to tied item"));
2885
2886 /*
2887 * We discriminate between \$h{key} and \$a[idx] via mg_ptr.
2888 */
2889
2890 if (mg->mg_ptr) {
2891 TRACEME(("store_tied_item: storing a ref to a tied hash item"));
2892 PUTMARK(SX_TIED_KEY);
741002cc
KW
2893 TRACEME(("store_tied_item: storing OBJ 0x%" UVxf,
2894 PTR2UV(mg->mg_obj)));
7a6a85bf 2895
138ec36d 2896 if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
2897 return ret;
2898
741002cc
KW
2899 TRACEME(("store_tied_item: storing PTR 0x%" UVxf,
2900 PTR2UV(mg->mg_ptr)));
7a6a85bf 2901
138ec36d 2902 if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
7a6a85bf
RG
2903 return ret;
2904 } else {
2905 I32 idx = mg->mg_len;
2906
2907 TRACEME(("store_tied_item: storing a ref to a tied array item "));
2908 PUTMARK(SX_TIED_IDX);
741002cc
KW
2909 TRACEME(("store_tied_item: storing OBJ 0x%" UVxf,
2910 PTR2UV(mg->mg_obj)));
7a6a85bf 2911
138ec36d 2912 if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */
7a6a85bf
RG
2913 return ret;
2914
2915 TRACEME(("store_tied_item: storing IDX %d", idx));
2916
2917 WLEN(idx);
2918 }
2919
2920 TRACEME(("ok (tied item)"));
2921
2922 return 0;
2923}
2924
2925/*
2926 * store_hook -- dispatched manually, not via sv_store[]
2927 *
2928 * The blessed SV is serialized by a hook.
2929 *
2930 * Simple Layout is:
2931 *
2932 * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
2933 *
2934 * where <flags> indicates how long <len>, <len2> and <len3> are, whether
2935 * the trailing part [] is present, the type of object (scalar, array or hash).
2936 * There is also a bit which says how the classname is stored between:
2937 *
2938 * <len> <classname>
2939 * <index>
2940 *
2941 * and when the <index> form is used (classname already seen), the "large
2942 * classname" bit in <flags> indicates how large the <index> is.
2943 *
2944 * The serialized string returned by the hook is of length <len2> and comes
2945 * next. It is an opaque string for us.
2946 *
2947 * Those <len3> object IDs which are listed last represent the extra references
2948 * not directly serialized by the hook, but which are linked to the object.
2949 *
2950 * When recursion is mandated to resolve object-IDs not yet seen, we have
2951 * instead, with <header> being flags with bits set to indicate the object type
2952 * and that recursion was indeed needed:
2953 *
2954 * SX_HOOK <header> <object> <header> <object> <flags>
2955 *
2956 * that same header being repeated between serialized objects obtained through
2957 * recursion, until we reach flags indicating no recursion, at which point
2958 * we know we've resynchronized with a single layout, after <flags>.
b12202d0
JH
2959 *
2960 * When storing a blessed ref to a tied variable, the following format is
2961 * used:
2962 *
2963 * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
2964 *
2965 * The first <flags> indication carries an object of type SHT_EXTRA, and the
2966 * real object type is held in the <extra> flag. At the very end of the
2967 * serialization stream, the underlying magic object is serialized, just like
2968 * any other tied variable.
7a6a85bf 2969 */
f0ffaed8 2970static int store_hook(
138ec36d 2971 pTHX_
f0ffaed8
JH
2972 stcxt_t *cxt,
2973 SV *sv,
2974 int type,
2975 HV *pkg,
2976 SV *hook)
7a6a85bf
RG
2977{
2978 I32 len;
0723351e 2979 char *classname;
7a6a85bf
RG
2980 STRLEN len2;
2981 SV *ref;
2982 AV *av;
2983 SV **ary;
2984 int count; /* really len3 + 1 */
2985 unsigned char flags;
2986 char *pv;
2987 int i;
2988 int recursed = 0; /* counts recursion */
2989 int obj_type; /* object type, on 2 bits */
2990 I32 classnum;
2991 int ret;
2992 int clone = cxt->optype & ST_CLONE;
e993d95c
JH
2993 char mtype = '\0'; /* for blessed ref to tied structures */
2994 unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */
7a6a85bf 2995
bfcb3514 2996 TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum));
7a6a85bf
RG
2997
2998 /*
2999 * Determine object type on 2 bits.
3000 */
3001
3002 switch (type) {
cc4aa37c 3003 case svis_REF:
7a6a85bf
RG
3004 case svis_SCALAR:
3005 obj_type = SHT_SCALAR;
3006 break;
3007 case svis_ARRAY:
3008 obj_type = SHT_ARRAY;
3009 break;
3010 case svis_HASH:
3011 obj_type = SHT_HASH;
3012 break;
b12202d0
JH
3013 case svis_TIED:
3014 /*
3015 * Produced by a blessed ref to a tied data structure, $o in the
3016 * following Perl code.
3017 *
3018 * my %h;
3019 * tie %h, 'FOO';
3020 * my $o = bless \%h, 'BAR';
3021 *
3022 * Signal the tie-ing magic by setting the object type as SHT_EXTRA
3023 * (since we have only 2 bits in <flags> to store the type), and an
3024 * <extra> byte flag will be emitted after the FIRST <flags> in the
6dfee1ec 3025 * stream, carrying what we put in 'eflags'.
b12202d0
JH
3026 */
3027 obj_type = SHT_EXTRA;
3028 switch (SvTYPE(sv)) {
3029 case SVt_PVHV:
3030 eflags = (unsigned char) SHT_THASH;
3031 mtype = 'P';
3032 break;
3033 case SVt_PVAV:
3034 eflags = (unsigned char) SHT_TARRAY;
3035 mtype = 'P';
3036 break;
3037 default:
3038 eflags = (unsigned char) SHT_TSCALAR;
3039 mtype = 'q';
3040 break;
3041 }
3042 break;
7a6a85bf
RG
3043 default:
3044 CROAK(("Unexpected object type (%d) in store_hook()", type));
3045 }
3046 flags = SHF_NEED_RECURSE | obj_type;
3047
bfcb3514 3048 classname = HvNAME_get(pkg);
0723351e 3049 len = strlen(classname);
7a6a85bf
RG
3050
3051 /*
3052 * To call the hook, we need to fake a call like:
3053 *
3054 * $object->STORABLE_freeze($cloning);
3055 *
3056 * but we don't have the $object here. For instance, if $object is
6dfee1ec 3057 * a blessed array, what we have in 'sv' is the array, and we can't
7a6a85bf
RG
3058 * call a method on those.
3059 *
3060 * Therefore, we need to create a temporary reference to the object and
3061 * make the call on that reference.
3062 */
3063
0723351e 3064 TRACEME(("about to call STORABLE_freeze on class %s", classname));
7a6a85bf 3065
27cc3b5a 3066 ref = newRV_inc(sv); /* Temporary reference */
138ec36d 3067 av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
7a6a85bf
RG
3068 SvREFCNT_dec(ref); /* Reclaim temporary reference */
3069
3070 count = AvFILLp(av) + 1;
3071 TRACEME(("store_hook, array holds %d items", count));
3072
3073 /*
3074 * If they return an empty list, it means they wish to ignore the
3075 * hook for this class (and not just this instance -- that's for them
3076 * to handle if they so wish).
3077 *
3078 * Simply disable the cached entry for the hook (it won't be recomputed
3079 * since it's present in the cache) and recurse to store_blessed().
3080 */
3081
3082 if (!count) {
65206418
AS
3083 /* free empty list returned by the hook */
3084 av_undef(av);
3085 sv_free((SV *) av);
3086
7a6a85bf
RG
3087 /*
3088 * They must not change their mind in the middle of a serialization.
3089 */
3090
0723351e 3091 if (hv_fetch(cxt->hclass, classname, len, FALSE))
7a6a85bf 3092 CROAK(("Too late to ignore hooks for %s class \"%s\"",
0723351e 3093 (cxt->optype & ST_CLONE) ? "cloning" : "storing", classname));
7a6a85bf 3094
138ec36d 3095 pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
7a6a85bf 3096
138ec36d 3097 ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
0723351e 3098 TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname));
7a6a85bf 3099
138ec36d 3100 return store_blessed(aTHX_ cxt, sv, type, pkg);
7a6a85bf
RG
3101 }
3102
3103 /*
3104 * Get frozen string.
3105 */
3106
3107 ary = AvARRAY(av);
3108 pv = SvPV(ary[0], len2);
2f796f32
AMS
3109 /* We can't use pkg_can here because it only caches one method per
3110 * package */
3111 {
3112 GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE);
3113 if (gv && isGV(gv)) {
3114 if (count > 1)
3115 CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname));
3116 goto check_done;
3117 }
3118 }
7a6a85bf
RG
3119
3120 /*
7a6a85bf
RG
3121 * If they returned more than one item, we need to serialize some
3122 * extra references if not already done.
3123 *
10ffa93f 3124 * Loop over the array, starting at position #1, and for each item,
7a6a85bf
RG
3125 * ensure it is a reference, serialize it if not already done, and
3126 * replace the entry with the tag ID of the corresponding serialized
3127 * object.
3128 *
3129 * We CHEAT by not calling av_fetch() and read directly within the
3130 * array, for speed.
3131 */
3132
3133 for (i = 1; i < count; i++) {
ab923da1
NC
3134#ifdef USE_PTR_TABLE
3135 char *fake_tag;
3136#else
7a6a85bf 3137 SV **svh;
ab923da1 3138#endif
90826881
JH
3139 SV *rsv = ary[i];
3140 SV *xsv;
ab923da1 3141 SV *tag;
90826881 3142 AV *av_hook = cxt->hook_seen;
7a6a85bf 3143
90826881
JH
3144 if (!SvROK(rsv))
3145 CROAK(("Item #%d returned by STORABLE_freeze "
0723351e 3146 "for %s is not a reference", i, classname));
90826881 3147 xsv = SvRV(rsv); /* Follow ref to know what to look for */
7a6a85bf
RG
3148
3149 /*
3150 * Look in hseen and see if we have a tag already.
3151 * Serialize entry if not done already, and get its tag.
3152 */
ab923da1
NC
3153
3154#ifdef USE_PTR_TABLE
3155 /* Fakery needed because ptr_table_fetch returns zero for a
3156 failure, whereas the existing code assumes that it can
3157 safely store a tag zero. So for ptr_tables we store tag+1
3158 */
ea17c9b6 3159 if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv)))
ab923da1
NC
3160 goto sv_seen; /* Avoid moving code too far to the right */
3161#else
13689cfe 3162 if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
7a6a85bf 3163 goto sv_seen; /* Avoid moving code too far to the right */
ab923da1 3164#endif
7a6a85bf 3165
741002cc
KW
3166 TRACEME(("listed object %d at 0x%" UVxf " is unknown",
3167 i-1, PTR2UV(xsv)));
7a6a85bf
RG
3168
3169 /*
3170 * We need to recurse to store that object and get it to be known
3171 * so that we can resolve the list of object-IDs at retrieve time.
3172 *
3173 * The first time we do this, we need to emit the proper header
3174 * indicating that we recursed, and what the type of object is (the
3175 * object we're storing via a user-hook). Indeed, during retrieval,
3176 * we'll have to create the object before recursing to retrieve the
3177 * others, in case those would point back at that object.
3178 */
3179
b12202d0
JH
3180 /* [SX_HOOK] <flags> [<extra>] <object>*/
3181 if (!recursed++) {
7a6a85bf 3182 PUTMARK(SX_HOOK);
b12202d0
JH
3183 PUTMARK(flags);
3184 if (obj_type == SHT_EXTRA)
3185 PUTMARK(eflags);
3186 } else
3187 PUTMARK(flags);
7a6a85bf 3188
138ec36d 3189 if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */
7a6a85bf
RG
3190 return ret;
3191
ab923da1 3192#ifdef USE_PTR_TABLE
ea17c9b6 3193 fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv);
ab923da1
NC
3194 if (!sv)
3195 CROAK(("Could not serialize item #%d from hook in %s", i, classname));
3196#else
7a6a85bf
RG
3197 svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
3198 if (!svh)
0723351e 3199 CROAK(("Could not serialize item #%d from hook in %s", i, classname));
ab923da1 3200#endif
7a6a85bf 3201 /*
6dfee1ec 3202 * It was the first time we serialized 'xsv'.
90826881
JH
3203 *
3204 * Keep this SV alive until the end of the serialization: if we
3205 * disposed of it right now by decrementing its refcount, and it was
3206 * a temporary value, some next temporary value allocated during
3207 * another STORABLE_freeze might take its place, and we'd wrongly
3208 * assume that new SV was already serialized, based on its presence
3209 * in cxt->hseen.
3210 *
3211 * Therefore, push it away in cxt->hook_seen.
7a6a85bf
RG
3212 */
3213
90826881
JH
3214 av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv));
3215
7a6a85bf 3216 sv_seen:
90826881 3217 /*
6dfee1ec 3218 * Dispose of the REF they returned. If we saved the 'xsv' away
90826881
JH
3219 * in the array of returned SVs, that will not cause the underlying
3220 * referenced SV to be reclaimed.
3221 */
3222
3223 ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF"));
3224 SvREFCNT_dec(rsv); /* Dispose of reference */
3225
3226 /*
3227 * Replace entry with its tag (not a real SV, so no refcnt increment)
3228 */
3229
ab923da1
NC
3230#ifdef USE_PTR_TABLE
3231 tag = (SV *)--fake_tag;
3232#else
3233 tag = *svh;
3234#endif
672ac946 3235 ary[i] = tag;
741002cc 3236 TRACEME(("listed object %d at 0x%" UVxf " is tag #%" UVuf,
ab923da1 3237 i-1, PTR2UV(xsv), PTR2UV(tag)));
7a6a85bf
RG
3238 }
3239
3240 /*
dd19458b
JH
3241 * Allocate a class ID if not already done.
3242 *
3243 * This needs to be done after the recursion above, since at retrieval
3244 * time, we'll see the inner objects first. Many thanks to
3245 * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and
3246 * proposed the right fix. -- RAM, 15/09/2000
3247 */
3248
2f796f32 3249check_done:
0723351e
NC
3250 if (!known_class(aTHX_ cxt, classname, len, &classnum)) {
3251 TRACEME(("first time we see class %s, ID = %d", classname, classnum));
dd19458b
JH
3252 classnum = -1; /* Mark: we must store classname */
3253 } else {
0723351e 3254 TRACEME(("already seen class %s, ID = %d", classname, classnum));
dd19458b
JH
3255 }
3256
3257 /*
7a6a85bf
RG
3258 * Compute leading flags.
3259 */
3260
3261 flags = obj_type;
3262 if (((classnum == -1) ? len : classnum) > LG_SCALAR)
3263 flags |= SHF_LARGE_CLASSLEN;
3264 if (classnum != -1)
3265 flags |= SHF_IDX_CLASSNAME;
3266 if (len2 > LG_SCALAR)
3267 flags |= SHF_LARGE_STRLEN;
3268 if (count > 1)
3269 flags |= SHF_HAS_LIST;
3270 if (count > (LG_SCALAR + 1))
3271 flags |= SHF_LARGE_LISTLEN;
3272
3273 /*
3274 * We're ready to emit either serialized form:
3275 *
3276 * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
3277 * SX_HOOK <flags> <index> <len2> <str> [<len3> <object-IDs>]
3278 *
3279 * If we recursed, the SX_HOOK has already been emitted.
3280 */
3281
9e21b3d0 3282 TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
741002cc 3283 "class=%" IVdf " len=%" IVdf " len2=%" IVdf " len3=%d",
d67b2c17 3284 recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
7a6a85bf 3285
b12202d0
JH
3286 /* SX_HOOK <flags> [<extra>] */
3287 if (!recursed) {
7a6a85bf 3288 PUTMARK(SX_HOOK);
b12202d0
JH
3289 PUTMARK(flags);
3290 if (obj_type == SHT_EXTRA)
3291 PUTMARK(eflags);
3292 } else
3293 PUTMARK(flags);
7a6a85bf
RG
3294
3295 /* <len> <classname> or <index> */
3296 if (flags & SHF_IDX_CLASSNAME) {
3297 if (flags & SHF_LARGE_CLASSLEN)
3298 WLEN(classnum);
3299 else {
3300 unsigned char cnum = (unsigned char) classnum;
3301 PUTMARK(cnum);
3302 }
3303 } else {
3304 if (flags & SHF_LARGE_CLASSLEN)
3305 WLEN(len);
3306 else {
3307 unsigned char clen = (unsigned char) len;
3308 PUTMARK(clen);
3309 }
0723351e 3310 WRITE(classname, len); /* Final \0 is omitted */
7a6a85bf
RG
3311 }
3312
3313 /* <len2> <frozen-str> */
cc964657
JH
3314 if (flags & SHF_LARGE_STRLEN) {
3315 I32 wlen2 = len2; /* STRLEN might be 8 bytes */
3316 WLEN(wlen2); /* Must write an I32 for 64-bit machines */
3317 } else {
7a6a85bf
RG
3318 unsigned char clen = (unsigned char) len2;
3319 PUTMARK(clen);
3320 }
3321 if (len2)
7c436af3 3322 WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */
7a6a85bf
RG
3323
3324 /* [<len3> <object-IDs>] */
3325 if (flags & SHF_HAS_LIST) {
3326 int len3 = count - 1;
3327 if (flags & SHF_LARGE_LISTLEN)
3328 WLEN(len3);
3329 else {
3330 unsigned char clen = (unsigned char) len3;
3331 PUTMARK(clen);
3332 }
3333
3334 /*
3335 * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a
3336 * real pointer, rather a tag number, well under the 32-bit limit.
3337 */
3338
3339 for (i = 1; i < count; i++) {
3340 I32 tagval = htonl(LOW_32BITS(ary[i]));
9e21b3d0 3341 WRITE_I32(tagval);
7a6a85bf
RG
3342 TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
3343 }
3344 }
3345
3346 /*
3347 * Free the array. We need extra care for indices after 0, since they
3348 * don't hold real SVs but integers cast.
3349 */
3350
3351 if (count > 1)
3352 AvFILLp(av) = 0; /* Cheat, nothing after 0 interests us */
3353 av_undef(av);
3354 sv_free((SV *) av);
3355
b12202d0
JH
3356 /*
3357 * If object was tied, need to insert serialization of the magic object.
3358 */
3359
3360 if (obj_type == SHT_EXTRA) {
3361 MAGIC *mg;
3362
3363 if (!(mg = mg_find(sv, mtype))) {
3364 int svt = SvTYPE(sv);
3365 CROAK(("No magic '%c' found while storing ref to tied %s with hook",
3366 mtype, (svt == SVt_PVHV) ? "hash" :
3367 (svt == SVt_PVAV) ? "array" : "scalar"));
3368 }
3369
741002cc
KW
3370 TRACEME(("handling the magic object 0x%" UVxf " part of 0x%"
3371 UVxf, PTR2UV(mg->mg_obj), PTR2UV(sv)));
b12202d0
JH
3372
3373 /*
3374 * [<magic object>]
3375 */
3376
138ec36d 3377 if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
b12202d0
JH
3378 return ret;
3379 }
3380
7a6a85bf
RG
3381 return 0;
3382}
3383
3384/*
3385 * store_blessed -- dispatched manually, not via sv_store[]
3386 *
3387 * Check whether there is a STORABLE_xxx hook defined in the class or in one
3388 * of its ancestors. If there is, then redispatch to store_hook();
3389 *
3390 * Otherwise, the blessed SV is stored using the following layout:
3391 *
3392 * SX_BLESS <flag> <len> <classname> <object>
3393 *
3394 * where <flag> indicates whether <len> is stored on 0 or 4 bytes, depending
3395 * on the high-order bit in flag: if 1, then length follows on 4 bytes.
3396 * Otherwise, the low order bits give the length, thereby giving a compact
3397 * representation for class names less than 127 chars long.
3398 *
3399 * Each <classname> seen is remembered and indexed, so that the next time
3400 * an object in the blessed in the same <classname> is stored, the following
3401 * will be emitted:
3402 *
3403 * SX_IX_BLESS <flag> <index> <object>
3404 *
3405 * where <index> is the classname index, stored on 0 or 4 bytes depending
3406 * on the high-order bit in flag (same encoding as above for <len>).
3407 */
f0ffaed8 3408static int store_blessed(
138ec36d 3409 pTHX_
f0ffaed8
JH
3410 stcxt_t *cxt,
3411 SV *sv,
3412 int type,
3413 HV *pkg)
7a6a85bf
RG
3414{
3415 SV *hook;
3416 I32 len;
0723351e 3417 char *classname;
7a6a85bf
RG
3418 I32 classnum;
3419
bfcb3514 3420 TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg)));
7a6a85bf
RG
3421
3422 /*
3423 * Look for a hook for this blessed SV and redirect to store_hook()
3424 * if needed.
3425 */
3426
138ec36d 3427 hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
7a6a85bf 3428 if (hook)
138ec36d 3429 return store_hook(aTHX_ cxt, sv, type, pkg, hook);
7a6a85bf
RG
3430
3431 /*
3432 * This is a blessed SV without any serialization hook.
3433 */
3434
bfcb3514 3435 classname = HvNAME_get(pkg);
0723351e 3436 len = strlen(classname);
7a6a85bf 3437
741002cc 3438 TRACEME(("blessed 0x%" UVxf " in %s, no hook: tagged #%d",
5e081687 3439 PTR2UV(sv), classname, cxt->tagnum));
7a6a85bf
RG
3440
3441 /*
3442 * Determine whether it is the first time we see that class name (in which
3443 * case it will be stored in the SX_BLESS form), or whether we already
3444 * saw that class name before (in which case the SX_IX_BLESS form will be
3445 * used).
3446 */
3447
0723351e
NC
3448 if (known_class(aTHX_ cxt, classname, len, &classnum)) {
3449 TRACEME(("already seen class %s, ID = %d", classname, classnum));
7a6a85bf
RG
3450 PUTMARK(SX_IX_BLESS);
3451 if (classnum <= LG_BLESS) {
3452 unsigned char cnum = (unsigned char) classnum;
3453 PUTMARK(cnum);
3454 } else {
3455 unsigned char flag = (unsigned char) 0x80;
3456 PUTMARK(flag);
3457 WLEN(classnum);
3458 }
3459 } else {
0723351e 3460 TRACEME(("first time we see class %s, ID = %d", classname, classnum));
7a6a85bf
RG
3461 PUTMARK(SX_BLESS);
3462 if (len <= LG_BLESS) {
3463 unsigned char clen = (unsigned char) len;
3464 PUTMARK(clen);
3465 } else {
3466 unsigned char flag = (unsigned char) 0x80;
3467 PUTMARK(flag);
3468 WLEN(len); /* Don't BER-encode, this should be rare */
3469 }
0723351e 3470 WRITE(classname, len); /* Final \0 is omitted */
7a6a85bf
RG
3471 }
3472
3473 /*
3474 * Now emit the <object> part.
3475 */
3476
138ec36d 3477 return SV_STORE(type)(aTHX_ cxt, sv);
7a6a85bf
RG
3478}
3479
3480/*
3481 * store_other
3482 *
3483 * We don't know how to store the item we reached, so return an error condition.
3484 * (it's probably a GLOB, some CODE reference, etc...)
3485 *
6dfee1ec 3486 * If they defined the 'forgive_me' variable at the Perl level to some
7a6a85bf
RG
3487 * true value, then don't croak, just warn, and store a placeholder string
3488 * instead.
3489 */
138ec36d 3490static int store_other(pTHX_ stcxt_t *cxt, SV *sv)
7a6a85bf 3491{
cc964657 3492 I32 len;
27da23d5 3493 char buf[80];
7a6a85bf
RG
3494
3495 TRACEME(("store_other"));
3496
3497 /*
3498 * Fetch the value from perl only once per store() operation.
3499 */
3500
3501 if (
3502 cxt->forgive_me == 0 ||
3503 (cxt->forgive_me < 0 && !(cxt->forgive_me =
3509f647 3504 SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
7a6a85bf
RG
3505 )
3506 CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
3507
741002cc 3508 warn("Can't store item %s(0x%" UVxf ")",
43d061fe 3509 sv_reftype(sv, FALSE), PTR2UV(sv));
7a6a85bf
RG
3510
3511 /*
3512 * Store placeholder string as a scalar instead...
3513 */
3514
741002cc 3515 (void) sprintf(buf, "You lost %s(0x%" UVxf ")%c", sv_reftype(sv, FALSE),
e993d95c 3516 PTR2UV(sv), (char) 0);
7a6a85bf
RG
3517
3518 len = strlen(buf);
3519 STORE_SCALAR(buf, len);
741002cc 3520 TRACEME(("ok (dummy \"%s\", length = %" IVdf ")", buf, (IV) len));
7a6a85bf
RG
3521
3522 return 0;
3523}
3524
3525/***
3526 *** Store driving routines
3527 ***/
3528
3529/*
3530 * sv_type
3531 *
3532 * WARNING: partially duplicates Perl's sv_reftype for speed.
3533 *
3534 * Returns the type of the SV, identified by an integer. That integer
3535 * may then be used to index the dynamic routine dispatch table.
3536 */
138ec36d 3537static int sv_type(pTHX_ SV *sv)
7a6a85bf
RG
3538{
3539 switch (SvTYPE(sv)) {
3540 case SVt_NULL:
4df7f6af 3541#if PERL_VERSION <= 10
7a6a85bf 3542 case SVt_IV:
<