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