File Coverage

Storable.xs

Criterion	Covered	Total	%
statement	1395	1657	84.1
branch	1547	3754	41.2
condition			n/a
subroutine			n/a
pod			n/a
total	2942	5411	54.3

line	stmt	bran	code
1			/* -- c-basic-offset: 4 --
2			*
3			* Fast store and retrieve mechanism.
4			*
5			* Copyright (c) 1995-2000, Raphael Manfredi
6			* Copyright (c) 2016, 2017 cPanel Inc
7			* Copyright (c) 2017 Reini Urban
8			*
9			* You may redistribute only under the same terms as Perl 5, as specified
10			* in the README file that comes with the distribution.
11			*
12			*/
13
14			#define PERL_NO_GET_CONTEXT /* we want efficiency */
15			#include
16			#include
17			#include
18
19			#ifndef PATCHLEVEL
20			#include /* Perl's one, needed since 5.6 */
21			#endif
22
23			#if !defined(PERL_VERSION) \|\| PERL_VERSION < 10 \|\| (PERL_VERSION == 10 && PERL_SUBVERSION < 1)
24			#define NEED_PL_parser
25			#define NEED_sv_2pv_flags
26			#define NEED_load_module
27			#define NEED_vload_module
28			#define NEED_newCONSTSUB
29			#define NEED_newSVpvn_flags
30			#define NEED_newRV_noinc
31			#include "ppport.h" /* handle old perls */
32			#endif
33
34			#ifdef DEBUGGING
35			#define DEBUGME /* Debug mode, turns assertions on as well */
36			#define DASSERT /* Assertion mode */
37			#endif
38
39			/*
40			* Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined
41			* Provide them with the necessary defines so they can build with pre-5.004.
42			*/
43			#ifndef USE_PERLIO
44			#ifndef PERLIO_IS_STDIO
45			#define PerlIO FILE
46			#define PerlIO_getc(x) getc(x)
47			#define PerlIO_putc(f,x) putc(x,f)
48			#define PerlIO_read(x,y,z) fread(y,1,z,x)
49			#define PerlIO_write(x,y,z) fwrite(y,1,z,x)
50			#define PerlIO_stdoutf printf
51			#endif /* PERLIO_IS_STDIO */
52			#endif /* USE_PERLIO */
53
54			/*
55			* Earlier versions of perl might be used, we can't assume they have the latest!
56			*/
57
58			#ifndef HvSHAREKEYS_off
59			#define HvSHAREKEYS_off(hv) /* Ignore */
60			#endif
61
62			/* perl <= 5.8.2 needs this */
63			#ifndef SvIsCOW
64			# define SvIsCOW(sv) 0
65			#endif
66
67			#ifndef HvRITER_set
68			# define HvRITER_set(hv,r) (HvRITER(hv) = r)
69			#endif
70			#ifndef HvEITER_set
71			# define HvEITER_set(hv,r) (HvEITER(hv) = r)
72			#endif
73
74			#ifndef HvRITER_get
75			# define HvRITER_get HvRITER
76			#endif
77			#ifndef HvEITER_get
78			# define HvEITER_get HvEITER
79			#endif
80
81			#ifndef HvPLACEHOLDERS_get
82			# define HvPLACEHOLDERS_get HvPLACEHOLDERS
83			#endif
84
85			#ifndef HvTOTALKEYS
86			# define HvTOTALKEYS(hv) HvKEYS(hv)
87			#endif
88			/* 5.6 */
89			#ifndef HvUSEDKEYS
90			# define HvUSEDKEYS(hv) HvKEYS(hv)
91			#endif
92
93			#ifdef SVf_IsCOW
94			# define SvTRULYREADONLY(sv) SvREADONLY(sv)
95			#else
96			# define SvTRULYREADONLY(sv) (SvREADONLY(sv) && !SvIsCOW(sv))
97			#endif
98
99			#ifndef SvPVCLEAR
100			# define SvPVCLEAR(sv) sv_setpvs(sv, "")
101			#endif
102
103			#ifndef strEQc
104			# define strEQc(s,c) memEQ(s, ("" c ""), sizeof(c))
105			#endif
106
107			#ifdef DEBUGME
108
109			#ifndef DASSERT
110			#define DASSERT
111			#endif
112
113			/*
114			* TRACEME() will only output things when the $Storable::DEBUGME is true.
115			*/
116
117			#define TRACEME(x) \
118			STMT_START { \
119			if (SvTRUE(get_sv("Storable::DEBUGME", GV_ADD))) \
120			{ PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
121			} STMT_END
122			#else
123			#define TRACEME(x)
124			#endif /* DEBUGME */
125
126			#ifdef DASSERT
127			#define ASSERT(x,y) \
128			STMT_START { \
129			if (!(x)) { \
130			PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \
131			__FILE__, (int)__LINE__); \
132			PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \
133			} \
134			} STMT_END
135			#else
136			#define ASSERT(x,y)
137			#endif
138
139			/*
140			* Type markers.
141			*/
142
143			#define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */
144
145			#define SX_OBJECT C(0) /* Already stored object */
146			#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */
147			#define SX_ARRAY C(2) /* Array forthcoming (size, item list) */
148			#define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */
149			#define SX_REF C(4) /* Reference to object forthcoming */
150			#define SX_UNDEF C(5) /* Undefined scalar */
151			#define SX_INTEGER C(6) /* Integer forthcoming */
152			#define SX_DOUBLE C(7) /* Double forthcoming */
153			#define SX_BYTE C(8) /* (signed) byte forthcoming */
154			#define SX_NETINT C(9) /* Integer in network order forthcoming */
155			#define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */
156			#define SX_TIED_ARRAY C(11) /* Tied array forthcoming */
157			#define SX_TIED_HASH C(12) /* Tied hash forthcoming */
158			#define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */
159			#define SX_SV_UNDEF C(14) /* Perl's immortal PL_sv_undef */
160			#define SX_SV_YES C(15) /* Perl's immortal PL_sv_yes */
161			#define SX_SV_NO C(16) /* Perl's immortal PL_sv_no */
162			#define SX_BLESS C(17) /* Object is blessed */
163			#define SX_IX_BLESS C(18) /* Object is blessed, classname given by index */
164			#define SX_HOOK C(19) /* Stored via hook, user-defined */
165			#define SX_OVERLOAD C(20) /* Overloaded reference */
166			#define SX_TIED_KEY C(21) /* Tied magic key forthcoming */
167			#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */
168			#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */
169			#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */
170			#define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
171			#define SX_CODE C(26) /* Code references as perl source code */
172			#define SX_WEAKREF C(27) /* Weak reference to object forthcoming */
173			#define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */
174			#define SX_VSTRING C(29) /* vstring forthcoming (small) */
175			#define SX_LVSTRING C(30) /* vstring forthcoming (large) */
176			#define SX_SVUNDEF_ELEM C(31) /* array element set to &PL_sv_undef */
177			#define SX_ERROR C(32) /* Error */
178			#define SX_LOBJECT C(33) /* Large object: string, array or hash (size >2G) */
179			#define SX_LAST C(34) /* invalid. marker only */
180
181			/*
182			* Those are only used to retrieve "old" pre-0.6 binary images.
183			*/
184			#define SX_ITEM 'i' /* An array item introducer */
185			#define SX_IT_UNDEF 'I' /* Undefined array item */
186			#define SX_KEY 'k' /* A hash key introducer */
187			#define SX_VALUE 'v' /* A hash value introducer */
188			#define SX_VL_UNDEF 'V' /* Undefined hash value */
189
190			/*
191			* Those are only used to retrieve "old" pre-0.7 binary images
192			*/
193
194			#define SX_CLASS 'b' /* Object is blessed, class name length <255 */
195			#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */
196			#define SX_STORED 'X' /* End of object */
197
198			/*
199			* Limits between short/long length representation.
200			*/
201
202			#define LG_SCALAR 255 /* Large scalar length limit */
203			#define LG_BLESS 127 /* Large classname bless limit */
204
205			/*
206			* Operation types
207			*/
208
209			#define ST_STORE 0x1 /* Store operation */
210			#define ST_RETRIEVE 0x2 /* Retrieval operation */
211			#define ST_CLONE 0x4 /* Deep cloning operation */
212
213			/*
214			* The following structure is used for hash table key retrieval. Since, when
215			* retrieving objects, we'll be facing blessed hash references, it's best
216			* to pre-allocate that buffer once and resize it as the need arises, never
217			* freeing it (keys will be saved away someplace else anyway, so even large
218			* keys are not enough a motivation to reclaim that space).
219			*
220			* This structure is also used for memory store/retrieve operations which
221			* happen in a fixed place before being malloc'ed elsewhere if persistence
222			* is required. Hence the aptr pointer.
223			*/
224			struct extendable {
225			char arena; / Will hold hash key strings, resized as needed */
226			STRLEN asiz; /* Size of aforementioned buffer */
227			char aptr; / Arena pointer, for in-place read/write ops */
228			char aend; / First invalid address */
229			};
230
231			/*
232			* At store time:
233			* A hash table records the objects which have already been stored.
234			* Those are referred to as SX_OBJECT in the file, and their "tag" (i.e.
235			* an arbitrary sequence number) is used to identify them.
236			*
237			* At retrieve time:
238			* An array table records the objects which have already been retrieved,
239			* as seen by the tag determined by counting the objects themselves. The
240			* reference to that retrieved object is kept in the table, and is returned
241			* when an SX_OBJECT is found bearing that same tag.
242			*
243			* The same processing is used to record "classname" for blessed objects:
244			* indexing by a hash at store time, and via an array at retrieve time.
245			*/
246
247			typedef unsigned long stag_t; /* Used by pre-0.6 binary format */
248
249			/*
250			* The following "thread-safe" related defines were contributed by
251			* Murray Nesbitt and integrated by RAM, who
252			* only renamed things a little bit to ensure consistency with surrounding
253			* code. -- RAM, 14/09/1999
254			*
255			* The original patch suffered from the fact that the stcxt_t structure
256			* was global. Murray tried to minimize the impact on the code as much as
257			* possible.
258			*
259			* Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks
260			* on objects. Therefore, the notion of context needs to be generalized,
261			* threading or not.
262			*/
263
264			#define MY_VERSION "Storable(" XS_VERSION ")"
265
266
267			/*
268			* Conditional UTF8 support.
269			*
270			*/
271			#ifdef SvUTF8_on
272			#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
273			#define HAS_UTF8_SCALARS
274			#ifdef HeKUTF8
275			#define HAS_UTF8_HASHES
276			#define HAS_UTF8_ALL
277			#else
278			/* 5.6 perl has utf8 scalars but not hashes */
279			#endif
280			#else
281			#define SvUTF8(sv) 0
282			#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
283			#endif
284			#ifndef HAS_UTF8_ALL
285			#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
286			#endif
287			#ifndef SvWEAKREF
288			#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl"))
289			#endif
290			#ifndef SvVOK
291			#define VSTRING_CROAK() CROAK(("Cannot retrieve vstring in this perl"))
292			#endif
293
294			#ifdef HvPLACEHOLDERS
295			#define HAS_RESTRICTED_HASHES
296			#else
297			#define HVhek_PLACEHOLD 0x200
298			#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash"))
299			#endif
300
301			#ifdef HvHASKFLAGS
302			#define HAS_HASH_KEY_FLAGS
303			#endif
304
305			#ifdef ptr_table_new
306			#define USE_PTR_TABLE
307			#endif
308
309			/* Needed for 32bit with lengths > 2G - 4G, and 64bit */
310			#if UVSIZE > 4
311			#define HAS_U64
312			#endif
313
314			/*
315			* Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
316			* files remap tainted and dirty when threading is enabled. That's bad for
317			* perl to remap such common words. -- RAM, 29/09/00
318			*/
319
320			struct stcxt;
321			typedef struct stcxt {
322			int entry; /* flags recursion */
323			int optype; /* type of traversal operation */
324			/* which objects have been seen, store time.
325			tags are numbers, which are cast to (SV ) and stored directly /
326			#ifdef USE_PTR_TABLE
327			/* use pseen if we have ptr_tables. We have to store tag+1, because
328			tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table
329			without it being confused for a fetch lookup failure. */
330			struct ptr_tbl *pseen;
331			/* Still need hseen for the 0.6 file format code. */
332			#endif
333			HV *hseen;
334			AV hook_seen; / which SVs were returned by STORABLE_freeze() */
335			AV aseen; / which objects have been seen, retrieve time */
336			IV where_is_undef; /* index in aseen of PL_sv_undef */
337			HV hclass; / which classnames have been seen, store time */
338			AV aclass; / which classnames have been seen, retrieve time */
339			HV hook; / cache for hook methods per class name */
340			IV tagnum; /* incremented at store time for each seen object */
341			IV classnum; /* incremented at store time for each seen classname */
342			int netorder; /* true if network order used */
343			int s_tainted; /* true if input source is tainted, at retrieve time */
344			int forgive_me; /* whether to be forgiving... */
345			int deparse; /* whether to deparse code refs */
346			SV eval; / whether to eval source code */
347			int canonical; /* whether to store hashes sorted by key */
348			#ifndef HAS_RESTRICTED_HASHES
349			int derestrict; /* whether to downgrade restricted hashes */
350			#endif
351			#ifndef HAS_UTF8_ALL
352			int use_bytes; /* whether to bytes-ify utf8 */
353			#endif
354			int accept_future_minor; /* croak immediately on future minor versions? */
355			int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
356			int membuf_ro; /* true means membuf is read-only and msaved is rw */
357			struct extendable keybuf; /* for hash key retrieval */
358			struct extendable membuf; /* for memory store/retrieve operations */
359			struct extendable msaved; /* where potentially valid mbuf is saved */
360			PerlIO fio; / where I/O are performed, NULL for memory */
361			int ver_major; /* major of version for retrieved object */
362			int ver_minor; /* minor of version for retrieved object */
363			SV (retrieve_vtbl)(pTHX_ struct stcxt , const char ); / retrieve dispatch table */
364			SV prev; / contexts chained backwards in real recursion */
365			SV my_sv; / the blessed scalar who's SvPVX() I am */
366			SV recur_sv; / check only one recursive SV */
367			int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */
368			int flags; /* controls whether to bless or tie objects */
369			U16 recur_depth; /* avoid stack overflows RT #97526 */
370			} stcxt_t;
371
372			/* Note: We dont count nested scalars. This will have to count all refs
373			without any recursion detection. */
374			/* JSON::XS has 512 */
375			/* sizes computed with stacksize. use some reserve for the croak cleanup. */
376			#include "stacksize.h"
377			/* esp. cygwin64 cannot 32, cygwin32 can. mingw needs more */
378			#if defined(WIN32)
379			# define STACK_RESERVE 32
380			#else
381			/* 8 should be enough, but some systems, esp. 32bit, need more */
382			# define STACK_RESERVE 16
383			#endif
384			#ifdef PST_STACK_MAX_DEPTH
385			# if (PERL_VERSION > 14) && !(defined(__CYGWIN__) && (PTRSIZE == 8))
386			# define MAX_DEPTH (PST_STACK_MAX_DEPTH - STACK_RESERVE)
387			# define MAX_DEPTH_HASH (PST_STACK_MAX_DEPTH_HASH - STACK_RESERVE)
388			# else
389			/* within the exception we need another stack depth to recursively cleanup the hash */
390			# define MAX_DEPTH ((PST_STACK_MAX_DEPTH >> 1) - STACK_RESERVE)
391			# define MAX_DEPTH_HASH ((PST_STACK_MAX_DEPTH_HASH >> 1) - (STACK_RESERVE*2))
392			# endif
393			#else
394			/* uninitialized (stacksize failed): safe */
395			# define MAX_DEPTH 512
396			# define MAX_DEPTH_HASH 256
397			#endif
398			#define MAX_DEPTH_ERROR "Max. recursion depth with nested structures exceeded"
399
400			static int storable_free(pTHX_ SV sv, MAGIC mg);
401
402			static MGVTBL vtbl_storable = {
403			NULL, /* get */
404			NULL, /* set */
405			NULL, /* len */
406			NULL, /* clear */
407			storable_free,
408			#ifdef MGf_COPY
409			NULL, /* copy */
410			#endif
411			#ifdef MGf_DUP
412			NULL, /* dup */
413			#endif
414			#ifdef MGf_LOCAL
415			NULL /* local */
416			#endif
417			};
418
419			/* From Digest::MD5. */
420			#ifndef sv_magicext
421			# define sv_magicext(sv, obj, type, vtbl, name, namlen) \
422			THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen)
423			static MAGIC *THX_sv_magicext(pTHX_
424			SV sv, SV obj, int type,
425			MGVTBL const vtbl, char const name, I32 namlen)
426			{
427			MAGIC *mg;
428			if (obj \|\| namlen)
429			/* exceeded intended usage of this reserve implementation */
430			return NULL;
431			Newxz(mg, 1, MAGIC);
432			mg->mg_virtual = (MGVTBL*)vtbl;
433			mg->mg_type = type;
434			mg->mg_ptr = (char *)name;
435			mg->mg_len = -1;
436			(void) SvUPGRADE(sv, SVt_PVMG);
437			mg->mg_moremagic = SvMAGIC(sv);
438			SvMAGIC_set(sv, mg);
439			SvMAGICAL_off(sv);
440			mg_magical(sv);
441			return mg;
442			}
443			#endif
444
445			#define NEW_STORABLE_CXT_OBJ(cxt) \
446			STMT_START { \
447			SV *self = newSV(sizeof(stcxt_t) - 1); \
448			SV *my_sv = newRV_noinc(self); \
449			sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \
450			cxt = (stcxt_t *)SvPVX(self); \
451			Zero(cxt, 1, stcxt_t); \
452			cxt->my_sv = my_sv; \
453			} STMT_END
454
455			#if defined(MULTIPLICITY) \|\| defined(PERL_OBJECT) \|\| defined(PERL_CAPI)
456
457			#if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
458			#define dSTCXT_SV \
459			SV *perinterp_sv = get_sv(MY_VERSION, 0)
460			#else /* >= perl5.004_68 */
461			#define dSTCXT_SV \
462			SV perinterp_sv = hv_fetch(PL_modglobal, \
463			MY_VERSION, sizeof(MY_VERSION)-1, TRUE)
464			#endif /* < perl5.004_68 */
465
466			#define dSTCXT_PTR(T,name) \
467			T name = ((perinterp_sv \
468			&& SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \
469			? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0))
470			#define dSTCXT \
471			dSTCXT_SV; \
472			dSTCXT_PTR(stcxt_t *, cxt)
473
474			#define INIT_STCXT \
475			dSTCXT; \
476			NEW_STORABLE_CXT_OBJ(cxt); \
477			assert(perinterp_sv); \
478			sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv))
479
480			#define SET_STCXT(x) \
481			STMT_START { \
482			dSTCXT_SV; \
483			sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \
484			} STMT_END
485
486			#else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
487
488			static stcxt_t *Context_ptr = NULL;
489			#define dSTCXT stcxt_t *cxt = Context_ptr
490			#define SET_STCXT(x) Context_ptr = x
491			#define INIT_STCXT \
492			dSTCXT; \
493			NEW_STORABLE_CXT_OBJ(cxt); \
494			SET_STCXT(cxt)
495
496
497			#endif /* MULTIPLICITY \|\| PERL_OBJECT \|\| PERL_CAPI */
498
499			/*
500			* KNOWN BUG:
501			* Croaking implies a memory leak, since we don't use setjmp/longjmp
502			* to catch the exit and free memory used during store or retrieve
503			* operations. This is not too difficult to fix, but I need to understand
504			* how Perl does it, and croaking is exceptional anyway, so I lack the
505			* motivation to do it.
506			*
507			* The current workaround is to mark the context as dirty when croaking,
508			* so that data structures can be freed whenever we renter Storable code
509			* (but only then: it's a workaround, not a fix).
510			*
511			* This is also imperfect, because we don't really know how far they trapped
512			* the croak(), and when we were recursing, we won't be able to clean anything
513			* but the topmost context stacked.
514			*/
515
516			#define CROAK(x) STMT_START { cxt->s_dirty = 1; croak x; } STMT_END
517
518			/*
519			* End of "thread-safe" related definitions.
520			*/
521
522			/*
523			* LOW_32BITS
524			*
525			* Keep only the low 32 bits of a pointer (used for tags, which are not
526			* really pointers).
527			*/
528
529			#if PTRSIZE <= 4
530			#define LOW_32BITS(x) ((I32) (x))
531			#else
532			#define LOW_32BITS(x) ((I32) ((unsigned long) (x) & 0xffffffffUL))
533			#endif
534
535			/*
536			* oI, oS, oC
537			*
538			* Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
539			* Used in the WLEN and RLEN macros.
540			*/
541
542			#if INTSIZE > 4
543			#define oI(x) ((I32 ) ((char ) (x) + 4))
544			#define oS(x) ((x) - 4)
545			#define oL(x) (x)
546			#define oC(x) (x = 0)
547			#define CRAY_HACK
548			#else
549			#define oI(x) (x)
550			#define oS(x) (x)
551			#define oL(x) (x)
552			#define oC(x)
553			#endif
554
555			/*
556			* key buffer handling
557			*/
558			#define kbuf (cxt->keybuf).arena
559			#define ksiz (cxt->keybuf).asiz
560			#define KBUFINIT() \
561			STMT_START { \
562			if (!kbuf) { \
563			TRACEME(("** allocating kbuf of 128 bytes")); \
564			New(10003, kbuf, 128, char); \
565			ksiz = 128; \
566			} \
567			} STMT_END
568			#define KBUFCHK(x) \
569			STMT_START { \
570			if (x >= ksiz) { \
571			if (x >= I32_MAX) \
572			CROAK(("Too large size > I32_MAX")); \
573			TRACEME(("** extending kbuf to %d bytes (had %d)", \
574			(int)(x+1), (int)ksiz)); \
575			Renew(kbuf, x+1, char); \
576			ksiz = x+1; \
577			} \
578			} STMT_END
579
580			/*
581			* memory buffer handling
582			*/
583			#define mbase (cxt->membuf).arena
584			#define msiz (cxt->membuf).asiz
585			#define mptr (cxt->membuf).aptr
586			#define mend (cxt->membuf).aend
587
588			#define MGROW (1 << 13)
589			#define MMASK (MGROW - 1)
590
591			#define round_mgrow(x) \
592			((unsigned long) (((unsigned long) (x) + MMASK) & ~MMASK))
593			#define trunc_int(x) \
594			((unsigned long) ((unsigned long) (x) & ~(sizeof(int)-1)))
595			#define int_aligned(x) \
596			((unsigned long) (x) == trunc_int(x))
597
598			#define MBUF_INIT(x) \
599			STMT_START { \
600			if (!mbase) { \
601			TRACEME(("** allocating mbase of %d bytes", MGROW)); \
602			New(10003, mbase, (int)MGROW, char); \
603			msiz = (STRLEN)MGROW; \
604			} \
605			mptr = mbase; \
606			if (x) \
607			mend = mbase + x; \
608			else \
609			mend = mbase + msiz; \
610			} STMT_END
611
612			#define MBUF_TRUNC(x) mptr = mbase + x
613			#define MBUF_SIZE() (mptr - mbase)
614
615			/*
616			* MBUF_SAVE_AND_LOAD
617			* MBUF_RESTORE
618			*
619			* Those macros are used in do_retrieve() to save the current memory
620			* buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
621			* data from a string.
622			*/
623			#define MBUF_SAVE_AND_LOAD(in) \
624			STMT_START { \
625			ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \
626			cxt->membuf_ro = 1; \
627			TRACEME(("saving mbuf")); \
628			StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \
629			MBUF_LOAD(in); \
630			} STMT_END
631
632			#define MBUF_RESTORE() \
633			STMT_START { \
634			ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
635			cxt->membuf_ro = 0; \
636			TRACEME(("restoring mbuf")); \
637			StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
638			} STMT_END
639
640			/*
641			* Use SvPOKp(), because SvPOK() fails on tainted scalars.
642			* See store_scalar() for other usage of this workaround.
643			*/
644			#define MBUF_LOAD(v) \
645			STMT_START { \
646			ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
647			if (!SvPOKp(v)) \
648			CROAK(("Not a scalar string")); \
649			mptr = mbase = SvPV(v, msiz); \
650			mend = mbase + msiz; \
651			} STMT_END
652
653			#define MBUF_XTEND(x) \
654			STMT_START { \
655			STRLEN nsz = (STRLEN) round_mgrow((x)+msiz); \
656			STRLEN offset = mptr - mbase; \
657			ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
658			TRACEME(("** extending mbase from %ld to %ld bytes (wants %ld new)", \
659			(long)msiz, nsz, (long)(x))); \
660			Renew(mbase, nsz, char); \
661			msiz = nsz; \
662			mptr = mbase + offset; \
663			mend = mbase + nsz; \
664			} STMT_END
665
666			#define MBUF_CHK(x) \
667			STMT_START { \
668			if ((mptr + (x)) > mend) \
669			MBUF_XTEND(x); \
670			} STMT_END
671
672			#define MBUF_GETC(x) \
673			STMT_START { \
674			if (mptr < mend) \
675			x = (int) (unsigned char) *mptr++; \
676			else \
677			return (SV *) 0; \
678			} STMT_END
679
680			#ifdef CRAY_HACK
681			#define MBUF_GETINT(x) \
682			STMT_START { \
683			oC(x); \
684			if ((mptr + 4) <= mend) { \
685			memcpy(oI(&x), mptr, 4); \
686			mptr += 4; \
687			} else \
688			return (SV *) 0; \
689			} STMT_END
690			#else
691			#define MBUF_GETINT(x) \
692			STMT_START { \
693			if ((mptr + sizeof(int)) <= mend) { \
694			if (int_aligned(mptr)) \
695			x = (int ) mptr; \
696			else \
697			memcpy(&x, mptr, sizeof(int)); \
698			mptr += sizeof(int); \
699			} else \
700			return (SV *) 0; \
701			} STMT_END
702			#endif
703
704			#define MBUF_READ(x,s) \
705			STMT_START { \
706			if ((mptr + (s)) <= mend) { \
707			memcpy(x, mptr, s); \
708			mptr += s; \
709			} else \
710			return (SV *) 0; \
711			} STMT_END
712
713			#define MBUF_SAFEREAD(x,s,z) \
714			STMT_START { \
715			if ((mptr + (s)) <= mend) { \
716			memcpy(x, mptr, s); \
717			mptr += s; \
718			} else { \
719			sv_free(z); \
720			return (SV *) 0; \
721			} \
722			} STMT_END
723
724			#define MBUF_SAFEPVREAD(x,s,z) \
725			STMT_START { \
726			if ((mptr + (s)) <= mend) { \
727			memcpy(x, mptr, s); \
728			mptr += s; \
729			} else { \
730			Safefree(z); \
731			return (SV *) 0; \
732			} \
733			} STMT_END
734
735			#define MBUF_PUTC(c) \
736			STMT_START { \
737			if (mptr < mend) \
738			*mptr++ = (char) c; \
739			else { \
740			MBUF_XTEND(1); \
741			*mptr++ = (char) c; \
742			} \
743			} STMT_END
744
745			#ifdef CRAY_HACK
746			#define MBUF_PUTINT(i) \
747			STMT_START { \
748			MBUF_CHK(4); \
749			memcpy(mptr, oI(&i), 4); \
750			mptr += 4; \
751			} STMT_END
752			#else
753			#define MBUF_PUTINT(i) \
754			STMT_START { \
755			MBUF_CHK(sizeof(int)); \
756			if (int_aligned(mptr)) \
757			(int ) mptr = i; \
758			else \
759			memcpy(mptr, &i, sizeof(int)); \
760			mptr += sizeof(int); \
761			} STMT_END
762			#endif
763
764			#define MBUF_PUTLONG(l) \
765			STMT_START { \
766			MBUF_CHK(8); \
767			memcpy(mptr, &l, 8); \
768			mptr += 8; \
769			} STMT_END
770			#define MBUF_WRITE(x,s) \
771			STMT_START { \
772			MBUF_CHK(s); \
773			memcpy(mptr, x, s); \
774			mptr += s; \
775			} STMT_END
776
777			/*
778			* Possible return values for sv_type().
779			*/
780
781			#define svis_REF 0
782			#define svis_SCALAR 1
783			#define svis_ARRAY 2
784			#define svis_HASH 3
785			#define svis_TIED 4
786			#define svis_TIED_ITEM 5
787			#define svis_CODE 6
788			#define svis_OTHER 7
789
790			/*
791			* Flags for SX_HOOK.
792			*/
793
794			#define SHF_TYPE_MASK 0x03
795			#define SHF_LARGE_CLASSLEN 0x04
796			#define SHF_LARGE_STRLEN 0x08
797			#define SHF_LARGE_LISTLEN 0x10
798			#define SHF_IDX_CLASSNAME 0x20
799			#define SHF_NEED_RECURSE 0x40
800			#define SHF_HAS_LIST 0x80
801
802			/*
803			* Types for SX_HOOK (last 2 bits in flags).
804			*/
805
806			#define SHT_SCALAR 0
807			#define SHT_ARRAY 1
808			#define SHT_HASH 2
809			#define SHT_EXTRA 3 /* Read extra byte for type */
810
811			/*
812			* The following are held in the "extra byte"...
813			*/
814
815			#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */
816			#define SHT_TARRAY 5 /* 4 + 1 -- tied array */
817			#define SHT_THASH 6 /* 4 + 2 -- tied hash */
818
819			/*
820			* per hash flags for flagged hashes
821			*/
822
823			#define SHV_RESTRICTED 0x01
824
825			/*
826			* per key flags for flagged hashes
827			*/
828
829			#define SHV_K_UTF8 0x01
830			#define SHV_K_WASUTF8 0x02
831			#define SHV_K_LOCKED 0x04
832			#define SHV_K_ISSV 0x08
833			#define SHV_K_PLACEHOLDER 0x10
834
835			/*
836			* flags to allow blessing and/or tieing data the data we load
837			*/
838			#define FLAG_BLESS_OK 2
839			#define FLAG_TIE_OK 4
840
841			/*
842			* Before 0.6, the magic string was "perl-store" (binary version number 0).
843			*
844			* Since 0.6 introduced many binary incompatibilities, the magic string has
845			* been changed to "pst0" to allow an old image to be properly retrieved by
846			* a newer Storable, but ensure a newer image cannot be retrieved with an
847			* older version.
848			*
849			* At 0.7, objects are given the ability to serialize themselves, and the
850			* set of markers is extended, backward compatibility is not jeopardized,
851			* so the binary version number could have remained unchanged. To correctly
852			* spot errors if a file making use of 0.7-specific extensions is given to
853			* 0.6 for retrieval, the binary version was moved to "2". And I'm introducing
854			* a "minor" version, to better track this kind of evolution from now on.
855			*
856			*/
857			static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */
858			static const char magicstr[] = "pst0"; /* Used as a magic number */
859
860			#define MAGICSTR_BYTES 'p','s','t','0'
861			#define OLDMAGICSTR_BYTES 'p','e','r','l','-','s','t','o','r','e'
862
863			/* 5.6.x introduced the ability to have IVs as long long.
864			However, Configure still defined BYTEORDER based on the size of a long.
865			Storable uses the BYTEORDER value as part of the header, but doesn't
866			explicitly store sizeof(IV) anywhere in the header. Hence on 5.6.x built
867			with IV as long long on a platform that uses Configure (ie most things
868			except VMS and Windows) headers are identical for the different IV sizes,
869			despite the files containing some fields based on sizeof(IV)
870			Erk. Broken-ness.
871			5.8 is consistent - the following redefinition kludge is only needed on
872			5.6.x, but the interwork is needed on 5.8 while data survives in files
873			with the 5.6 header.
874
875			*/
876
877			#if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4)
878			#ifndef NO_56_INTERWORK_KLUDGE
879			#define USE_56_INTERWORK_KLUDGE
880			#endif
881			#if BYTEORDER == 0x1234
882			#undef BYTEORDER
883			#define BYTEORDER 0x12345678
884			#else
885			#if BYTEORDER == 0x4321
886			#undef BYTEORDER
887			#define BYTEORDER 0x87654321
888			#endif
889			#endif
890			#endif
891
892			#if BYTEORDER == 0x1234
893			#define BYTEORDER_BYTES '1','2','3','4'
894			#else
895			#if BYTEORDER == 0x12345678
896			#define BYTEORDER_BYTES '1','2','3','4','5','6','7','8'
897			#ifdef USE_56_INTERWORK_KLUDGE
898			#define BYTEORDER_BYTES_56 '1','2','3','4'
899			#endif
900			#else
901			#if BYTEORDER == 0x87654321
902			#define BYTEORDER_BYTES '8','7','6','5','4','3','2','1'
903			#ifdef USE_56_INTERWORK_KLUDGE
904			#define BYTEORDER_BYTES_56 '4','3','2','1'
905			#endif
906			#else
907			#if BYTEORDER == 0x4321
908			#define BYTEORDER_BYTES '4','3','2','1'
909			#else
910			#error Unknown byteorder. Please append your byteorder to Storable.xs
911			#endif
912			#endif
913			#endif
914			#endif
915
916			#ifndef INT32_MAX
917			# define INT32_MAX 2147483647
918			#endif
919			#if IVSIZE > 4 && !defined(INT64_MAX)
920			# define INT64_MAX 9223372036854775807LL
921			#endif
922
923			static const char byteorderstr[] = {BYTEORDER_BYTES, 0};
924			#ifdef USE_56_INTERWORK_KLUDGE
925			static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
926			#endif
927
928			#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
929			#define STORABLE_BIN_MINOR 11 /* Binary minor "version" */
930
931			#if (PATCHLEVEL <= 5)
932			#define STORABLE_BIN_WRITE_MINOR 4
933			#elif !defined (SvVOK)
934			/*
935			* Perl 5.6.0-5.8.0 can do weak references, but not vstring magic.
936			*/
937			#define STORABLE_BIN_WRITE_MINOR 8
938			#elif PATCHLEVEL >= 19
939			/* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */
940			/* With 3.x we added LOBJECT */
941			#define STORABLE_BIN_WRITE_MINOR 11
942			#else
943			#define STORABLE_BIN_WRITE_MINOR 9
944			#endif /* (PATCHLEVEL <= 5) */
945
946			#if (PATCHLEVEL < 8 \|\| (PATCHLEVEL == 8 && SUBVERSION < 1))
947			#define PL_sv_placeholder PL_sv_undef
948			#endif
949
950			/*
951			* Useful store shortcuts...
952			*/
953
954			/*
955			* Note that if you put more than one mark for storing a particular
956			* type of thing, and in the retrieve_foo() function you mark both
957			* the thingy's you get off with SEEN(), you must increase the
958			* tagnum with cxt->tagnum++ along with this macro!
959			* - samv 20Jan04
960			*/
961			#define PUTMARK(x) \
962			STMT_START { \
963			if (!cxt->fio) \
964			MBUF_PUTC(x); \
965			else if (PerlIO_putc(cxt->fio, x) == EOF) \
966			return -1; \
967			} STMT_END
968
969			#define WRITE_I32(x) \
970			STMT_START { \
971			ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \
972			if (!cxt->fio) \
973			MBUF_PUTINT(x); \
974			else if (PerlIO_write(cxt->fio, oI(&x), \
975			oS(sizeof(x))) != oS(sizeof(x))) \
976			return -1; \
977			} STMT_END
978
979			#define WRITE_U64(x) \
980			STMT_START { \
981			ASSERT(sizeof(x) == sizeof(UV), ("writing an UV")); \
982			if (!cxt->fio) \
983			MBUF_PUTLONG(x); \
984			else if (PerlIO_write(cxt->fio, oL(&x), \
985			oS(sizeof(x))) != oS(sizeof(x))) \
986			return -1; \
987			} STMT_END
988
989			#ifdef HAS_HTONL
990			#define WLEN(x) \
991			STMT_START { \
992			ASSERT(sizeof(x) == sizeof(int), ("WLEN writing an int")); \
993			if (cxt->netorder) { \
994			int y = (int) htonl(x); \
995			if (!cxt->fio) \
996			MBUF_PUTINT(y); \
997			else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \
998			return -1; \
999			} else { \
1000			if (!cxt->fio) \
1001			MBUF_PUTINT(x); \
1002			else if (PerlIO_write(cxt->fio,oI(&x), \
1003			oS(sizeof(x))) != oS(sizeof(x))) \
1004			return -1; \
1005			} \
1006			} STMT_END
1007			#define W64LEN(x) \
1008			STMT_START { \
1009			ASSERT(sizeof(x) == 8, ("W64LEN writing a U64")); \
1010			if (cxt->netorder) { \
1011			union u64_t { U32 a; U32 b; } y; \
1012			y.b = htonl(x & 0xffffffffUL); \
1013			y.a = htonl(x >> 32); \
1014			if (!cxt->fio) \
1015			MBUF_PUTLONG(y); \
1016			else if (PerlIO_write(cxt->fio,oI(&y), \
1017			oS(sizeof(y))) != oS(sizeof(y))) \
1018			return -1; \
1019			} else { \
1020			if (!cxt->fio) \
1021			MBUF_PUTLONG(x); \
1022			else if (PerlIO_write(cxt->fio,oI(&x), \
1023			oS(sizeof(x))) != oS(sizeof(x))) \
1024			return -1; \
1025			} \
1026			} STMT_END
1027			#else
1028			#define WLEN(x) WRITE_I32(x)
1029			#ifdef HAS_U64
1030			#define W64LEN(x) WRITE_U64(x)
1031			#else
1032			#define W64LEN(x) CROAK(("no 64bit UVs"))
1033			#endif
1034			#endif
1035
1036			#define WRITE(x,y) \
1037			STMT_START { \
1038			if (!cxt->fio) \
1039			MBUF_WRITE(x,y); \
1040			else if (PerlIO_write(cxt->fio, x, y) != (SSize_t)y) \
1041			return -1; \
1042			} STMT_END
1043
1044			#define STORE_PV_LEN(pv, len, small, large) \
1045			STMT_START { \
1046			if (len <= LG_SCALAR) { \
1047			int ilen = (int) len; \
1048			unsigned char clen = (unsigned char) len; \
1049			PUTMARK(small); \
1050			PUTMARK(clen); \
1051			if (len) \
1052			WRITE(pv, ilen); \
1053			} else if (sizeof(len) > 4 && len > INT32_MAX) { \
1054			PUTMARK(SX_LOBJECT); \
1055			PUTMARK(large); \
1056			W64LEN(len); \
1057			WRITE(pv, len); \
1058			} else { \
1059			int ilen = (int) len; \
1060			PUTMARK(large); \
1061			WLEN(ilen); \
1062			WRITE(pv, ilen); \
1063			} \
1064			} STMT_END
1065
1066			#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
1067
1068			/*
1069			* Store &PL_sv_undef in arrays without recursing through store(). We
1070			* actually use this to represent nonexistent elements, for historical
1071			* reasons.
1072			*/
1073			#define STORE_SV_UNDEF() \
1074			STMT_START { \
1075			cxt->tagnum++; \
1076			PUTMARK(SX_SV_UNDEF); \
1077			} STMT_END
1078
1079			/*
1080			* Useful retrieve shortcuts...
1081			*/
1082
1083			#define GETCHAR() \
1084			(cxt->fio ? PerlIO_getc(cxt->fio) \
1085			: (mptr >= mend ? EOF : (int) *mptr++))
1086
1087			#define GETMARK(x) \
1088			STMT_START { \
1089			if (!cxt->fio) \
1090			MBUF_GETC(x); \
1091			else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \
1092			return (SV *) 0; \
1093			} STMT_END
1094
1095			#define READ_I32(x) \
1096			STMT_START { \
1097			ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \
1098			oC(x); \
1099			if (!cxt->fio) \
1100			MBUF_GETINT(x); \
1101			else if (PerlIO_read(cxt->fio, oI(&x), \
1102			oS(sizeof(x))) != oS(sizeof(x))) \
1103			return (SV *) 0; \
1104			} STMT_END
1105
1106			#ifdef HAS_NTOHL
1107			#define RLEN(x) \
1108			STMT_START { \
1109			oC(x); \
1110			if (!cxt->fio) \
1111			MBUF_GETINT(x); \
1112			else if (PerlIO_read(cxt->fio, oI(&x), \
1113			oS(sizeof(x))) != oS(sizeof(x))) \
1114			return (SV *) 0; \
1115			if (cxt->netorder) \
1116			x = (int) ntohl(x); \
1117			} STMT_END
1118			#else
1119			#define RLEN(x) READ_I32(x)
1120			#endif
1121
1122			#define READ(x,y) \
1123			STMT_START { \
1124			if (!cxt->fio) \
1125			MBUF_READ(x, y); \
1126			else if (PerlIO_read(cxt->fio, x, y) != (SSize_t)y) \
1127			return (SV *) 0; \
1128			} STMT_END
1129
1130			#define SAFEREAD(x,y,z) \
1131			STMT_START { \
1132			if (!cxt->fio) \
1133			MBUF_SAFEREAD(x,y,z); \
1134			else if (PerlIO_read(cxt->fio, x, y) != (SSize_t)y) { \
1135			sv_free(z); \
1136			return (SV *) 0; \
1137			} \
1138			} STMT_END
1139
1140			#define SAFEPVREAD(x,y,z) \
1141			STMT_START { \
1142			if (!cxt->fio) \
1143			MBUF_SAFEPVREAD(x,y,z); \
1144			else if (PerlIO_read(cxt->fio, x, y) != y) { \
1145			Safefree(z); \
1146			return (SV *) 0; \
1147			} \
1148			} STMT_END
1149
1150			/*
1151			* SEEN() is used at retrieve time, to remember where object 'y', bearing a
1152			* given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
1153			* we'll therefore know where it has been retrieved and will be able to
1154			* share the same reference, as in the original stored memory image.
1155			*
1156			* We also need to bless objects ASAP for hooks (which may compute "ref $x"
1157			* on the objects given to STORABLE_thaw and expect that to be defined), and
1158			* also for overloaded objects (for which we might not find the stash if the
1159			* object is not blessed yet--this might occur for overloaded objects that
1160			* refer to themselves indirectly: if we blessed upon return from a sub
1161			* retrieve(), the SX_OBJECT marker we'd found could not have overloading
1162			* restored on it because the underlying object would not be blessed yet!).
1163			*
1164			* To achieve that, the class name of the last retrieved object is passed down
1165			* recursively, and the first SEEN() call for which the class name is not NULL
1166			* will bless the object.
1167			*
1168			* i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef)
1169			*
1170			* SEEN0() is a short-cut where stash is always NULL.
1171			*
1172			* The _NN variants dont check for y being null
1173			*/
1174			#define SEEN0_NN(y,i) \
1175			STMT_START { \
1176			if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) \
1177			: SvREFCNT_inc(y)) == 0) \
1178			return (SV *) 0; \
1179			TRACEME(("aseen(#%d) = 0x%" UVxf " (refcnt=%d)", \
1180			(int)cxt->tagnum-1, \
1181			PTR2UV(y), (int)SvREFCNT(y)-1)); \
1182			} STMT_END
1183
1184			#define SEEN0(y,i) \
1185			STMT_START { \
1186			if (!y) \
1187			return (SV *) 0; \
1188			SEEN0_NN(y,i); \
1189			} STMT_END
1190
1191			#define SEEN_NN(y,stash,i) \
1192			STMT_START { \
1193			SEEN0_NN(y,i); \
1194			if (stash) \
1195			BLESS((SV )(y), (HV )(stash)); \
1196			} STMT_END
1197
1198			#define SEEN(y,stash,i) \
1199			STMT_START { \
1200			if (!y) \
1201			return (SV *) 0; \
1202			SEEN_NN(y,stash, i); \
1203			} STMT_END
1204
1205			/*
1206			* Bless 's' in 'p', via a temporary reference, required by sv_bless().
1207			* "A" magic is added before the sv_bless for overloaded classes, this avoids
1208			* an expensive call to S_reset_amagic in sv_bless.
1209			*/
1210			#define BLESS(s,stash) \
1211			STMT_START { \
1212			SV *ref; \
1213			if (cxt->flags & FLAG_BLESS_OK) { \
1214			TRACEME(("blessing 0x%" UVxf " in %s", PTR2UV(s), \
1215			HvNAME_get(stash))); \
1216			ref = newRV_noinc(s); \
1217			if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) { \
1218			cxt->in_retrieve_overloaded = 0; \
1219			SvAMAGIC_on(ref); \
1220			} \
1221			(void) sv_bless(ref, stash); \
1222			SvRV_set(ref, NULL); \
1223			SvREFCNT_dec(ref); \
1224			} \
1225			else { \
1226			TRACEME(("not blessing 0x%" UVxf " in %s", PTR2UV(s), \
1227			(HvNAME_get(stash)))); \
1228			} \
1229			} STMT_END
1230			/*
1231			* sort (used in store_hash) - conditionally use qsort when
1232			* sortsv is not available ( <= 5.6.1 ).
1233			*/
1234
1235			#if (PATCHLEVEL <= 6)
1236
1237			#if defined(USE_ITHREADS)
1238
1239			#define STORE_HASH_SORT \
1240			ENTER; { \
1241			PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \
1242			SAVESPTR(orig_perl); \
1243			PERL_SET_CONTEXT(aTHX); \
1244			qsort((char ) AvARRAY(av), len, sizeof(SV ), sortcmp);\
1245			} LEAVE;
1246
1247			#else /* ! USE_ITHREADS */
1248
1249			#define STORE_HASH_SORT \
1250			qsort((char ) AvARRAY(av), len, sizeof(SV ), sortcmp);
1251
1252			#endif /* USE_ITHREADS */
1253
1254			#else /* PATCHLEVEL > 6 */
1255
1256			#define STORE_HASH_SORT \
1257			sortsv(AvARRAY(av), len, Perl_sv_cmp);
1258
1259			#endif /* PATCHLEVEL <= 6 */
1260
1261			static int store(pTHX_ stcxt_t cxt, SV sv);
1262			static SV retrieve(pTHX_ stcxt_t cxt, const char *cname);
1263
1264			#define UNSEE() \
1265			STMT_START { \
1266			av_pop(cxt->aseen); \
1267			cxt->tagnum--; \
1268			} STMT_END
1269
1270			/*
1271			* Dynamic dispatching table for SV store.
1272			*/
1273
1274			static int store_ref(pTHX_ stcxt_t cxt, SV sv);
1275			static int store_scalar(pTHX_ stcxt_t cxt, SV sv);
1276			static int store_array(pTHX_ stcxt_t cxt, AV av);
1277			static int store_hash(pTHX_ stcxt_t cxt, HV hv);
1278			static int store_tied(pTHX_ stcxt_t cxt, SV sv);
1279			static int store_tied_item(pTHX_ stcxt_t cxt, SV sv);
1280			static int store_code(pTHX_ stcxt_t cxt, CV cv);
1281			static int store_other(pTHX_ stcxt_t cxt, SV sv);
1282			static int store_blessed(pTHX_ stcxt_t cxt, SV sv, int type, HV *pkg);
1283
1284			typedef int (sv_store_t)(pTHX_ stcxt_t cxt, SV *sv);
1285
1286			static const sv_store_t sv_store[] = {
1287			(sv_store_t)store_ref, /* svis_REF */
1288			(sv_store_t)store_scalar, /* svis_SCALAR */
1289			(sv_store_t)store_array, /* svis_ARRAY */
1290			(sv_store_t)store_hash, /* svis_HASH */
1291			(sv_store_t)store_tied, /* svis_TIED */
1292			(sv_store_t)store_tied_item,/* svis_TIED_ITEM */
1293			(sv_store_t)store_code, /* svis_CODE */
1294			(sv_store_t)store_other, /* svis_OTHER */
1295			};
1296
1297			#define SV_STORE(x) (*sv_store[x])
1298
1299			/*
1300			* Dynamic dispatching tables for SV retrieval.
1301			*/
1302
1303			static SV retrieve_lscalar(pTHX_ stcxt_t cxt, const char *cname);
1304			static SV retrieve_lutf8str(pTHX_ stcxt_t cxt, const char *cname);
1305			static SV old_retrieve_array(pTHX_ stcxt_t cxt, const char *cname);
1306			static SV old_retrieve_hash(pTHX_ stcxt_t cxt, const char *cname);
1307			static SV retrieve_ref(pTHX_ stcxt_t cxt, const char *cname);
1308			static SV retrieve_undef(pTHX_ stcxt_t cxt, const char *cname);
1309			static SV retrieve_integer(pTHX_ stcxt_t cxt, const char *cname);
1310			static SV retrieve_double(pTHX_ stcxt_t cxt, const char *cname);
1311			static SV retrieve_byte(pTHX_ stcxt_t cxt, const char *cname);
1312			static SV retrieve_netint(pTHX_ stcxt_t cxt, const char *cname);
1313			static SV retrieve_scalar(pTHX_ stcxt_t cxt, const char *cname);
1314			static SV retrieve_utf8str(pTHX_ stcxt_t cxt, const char *cname);
1315			static SV retrieve_tied_array(pTHX_ stcxt_t cxt, const char *cname);
1316			static SV retrieve_tied_hash(pTHX_ stcxt_t cxt, const char *cname);
1317			static SV retrieve_tied_scalar(pTHX_ stcxt_t cxt, const char *cname);
1318			static SV retrieve_other(pTHX_ stcxt_t cxt, const char *cname);
1319			static SV retrieve_lobject(pTHX_ stcxt_t cxt, const char *cname);
1320
1321			/* helpers for U64 lobjects */
1322
1323			static SV get_lstring(pTHX_ stcxt_t cxt, UV len, int isutf8, const char *cname);
1324			static SV get_larray(pTHX_ stcxt_t cxt, UV len, const char *cname);
1325			#ifdef HAS_U64
1326			static SV get_lhash(pTHX_ stcxt_t cxt, UV len, int flagged, const char *cname);
1327			static int store_lhash(pTHX_ stcxt_t cxt, HV hv, unsigned char hash_flags);
1328			#endif
1329			static int store_hentry(pTHX_ stcxt_t cxt, HV hv, UV i, HE *he, unsigned char hash_flags);
1330
1331			typedef SV* (sv_retrieve_t)(pTHX_ stcxt_t cxt, const char *name);
1332
1333			static const sv_retrieve_t sv_old_retrieve[] = {
1334			0, /* SX_OBJECT -- entry unused dynamically */
1335			(sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */
1336			(sv_retrieve_t)old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */
1337			(sv_retrieve_t)old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */
1338			(sv_retrieve_t)retrieve_ref, /* SX_REF */
1339			(sv_retrieve_t)retrieve_undef, /* SX_UNDEF */
1340			(sv_retrieve_t)retrieve_integer, /* SX_INTEGER */
1341			(sv_retrieve_t)retrieve_double, /* SX_DOUBLE */
1342			(sv_retrieve_t)retrieve_byte, /* SX_BYTE */
1343			(sv_retrieve_t)retrieve_netint, /* SX_NETINT */
1344			(sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */
1345			(sv_retrieve_t)retrieve_tied_array, /* SX_TIED_ARRAY */
1346			(sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */
1347			(sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_SCALAR */
1348			(sv_retrieve_t)retrieve_other, /* SX_SV_UNDEF not supported */
1349			(sv_retrieve_t)retrieve_other, /* SX_SV_YES not supported */
1350			(sv_retrieve_t)retrieve_other, /* SX_SV_NO not supported */
1351			(sv_retrieve_t)retrieve_other, /* SX_BLESS not supported */
1352			(sv_retrieve_t)retrieve_other, /* SX_IX_BLESS not supported */
1353			(sv_retrieve_t)retrieve_other, /* SX_HOOK not supported */
1354			(sv_retrieve_t)retrieve_other, /* SX_OVERLOADED not supported */
1355			(sv_retrieve_t)retrieve_other, /* SX_TIED_KEY not supported */
1356			(sv_retrieve_t)retrieve_other, /* SX_TIED_IDX not supported */
1357			(sv_retrieve_t)retrieve_other, /* SX_UTF8STR not supported */
1358			(sv_retrieve_t)retrieve_other, /* SX_LUTF8STR not supported */
1359			(sv_retrieve_t)retrieve_other, /* SX_FLAG_HASH not supported */
1360			(sv_retrieve_t)retrieve_other, /* SX_CODE not supported */
1361			(sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */
1362			(sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */
1363			(sv_retrieve_t)retrieve_other, /* SX_VSTRING not supported */
1364			(sv_retrieve_t)retrieve_other, /* SX_LVSTRING not supported */
1365			(sv_retrieve_t)retrieve_other, /* SX_SVUNDEF_ELEM not supported */
1366			(sv_retrieve_t)retrieve_other, /* SX_ERROR */
1367			(sv_retrieve_t)retrieve_other, /* SX_LOBJECT not supported */
1368			};
1369
1370			static SV retrieve_array(pTHX_ stcxt_t cxt, const char *cname);
1371			static SV retrieve_hash(pTHX_ stcxt_t cxt, const char *cname);
1372			static SV retrieve_sv_undef(pTHX_ stcxt_t cxt, const char *cname);
1373			static SV retrieve_sv_yes(pTHX_ stcxt_t cxt, const char *cname);
1374			static SV retrieve_sv_no(pTHX_ stcxt_t cxt, const char *cname);
1375			static SV retrieve_blessed(pTHX_ stcxt_t cxt, const char *cname);
1376			static SV retrieve_idx_blessed(pTHX_ stcxt_t cxt, const char *cname);
1377			static SV retrieve_hook(pTHX_ stcxt_t cxt, const char *cname);
1378			static SV retrieve_overloaded(pTHX_ stcxt_t cxt, const char *cname);
1379			static SV retrieve_tied_key(pTHX_ stcxt_t cxt, const char *cname);
1380			static SV retrieve_tied_idx(pTHX_ stcxt_t cxt, const char *cname);
1381			static SV retrieve_flag_hash(pTHX_ stcxt_t cxt, const char *cname);
1382			static SV retrieve_code(pTHX_ stcxt_t cxt, const char *cname);
1383			static SV retrieve_weakref(pTHX_ stcxt_t cxt, const char *cname);
1384			static SV retrieve_weakoverloaded(pTHX_ stcxt_t cxt, const char *cname);
1385			static SV retrieve_vstring(pTHX_ stcxt_t cxt, const char *cname);
1386			static SV retrieve_lvstring(pTHX_ stcxt_t cxt, const char *cname);
1387			static SV retrieve_svundef_elem(pTHX_ stcxt_t cxt, const char *cname);
1388
1389			static const sv_retrieve_t sv_retrieve[] = {
1390			0, /* SX_OBJECT -- entry unused dynamically */
1391			(sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */
1392			(sv_retrieve_t)retrieve_array, /* SX_ARRAY */
1393			(sv_retrieve_t)retrieve_hash, /* SX_HASH */
1394			(sv_retrieve_t)retrieve_ref, /* SX_REF */
1395			(sv_retrieve_t)retrieve_undef, /* SX_UNDEF */
1396			(sv_retrieve_t)retrieve_integer, /* SX_INTEGER */
1397			(sv_retrieve_t)retrieve_double, /* SX_DOUBLE */
1398			(sv_retrieve_t)retrieve_byte, /* SX_BYTE */
1399			(sv_retrieve_t)retrieve_netint, /* SX_NETINT */
1400			(sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */
1401			(sv_retrieve_t)retrieve_tied_array, /* SX_TIED_ARRAY */
1402			(sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */
1403			(sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_SCALAR */
1404			(sv_retrieve_t)retrieve_sv_undef, /* SX_SV_UNDEF */
1405			(sv_retrieve_t)retrieve_sv_yes, /* SX_SV_YES */
1406			(sv_retrieve_t)retrieve_sv_no, /* SX_SV_NO */
1407			(sv_retrieve_t)retrieve_blessed, /* SX_BLESS */
1408			(sv_retrieve_t)retrieve_idx_blessed,/* SX_IX_BLESS */
1409			(sv_retrieve_t)retrieve_hook, /* SX_HOOK */
1410			(sv_retrieve_t)retrieve_overloaded, /* SX_OVERLOAD */
1411			(sv_retrieve_t)retrieve_tied_key, /* SX_TIED_KEY */
1412			(sv_retrieve_t)retrieve_tied_idx, /* SX_TIED_IDX */
1413			(sv_retrieve_t)retrieve_utf8str, /* SX_UTF8STR */
1414			(sv_retrieve_t)retrieve_lutf8str, /* SX_LUTF8STR */
1415			(sv_retrieve_t)retrieve_flag_hash, /* SX_HASH */
1416			(sv_retrieve_t)retrieve_code, /* SX_CODE */
1417			(sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */
1418			(sv_retrieve_t)retrieve_weakoverloaded,/* SX_WEAKOVERLOAD */
1419			(sv_retrieve_t)retrieve_vstring, /* SX_VSTRING */
1420			(sv_retrieve_t)retrieve_lvstring, /* SX_LVSTRING */
1421			(sv_retrieve_t)retrieve_svundef_elem,/* SX_SVUNDEF_ELEM */
1422			(sv_retrieve_t)retrieve_other, /* SX_ERROR */
1423			(sv_retrieve_t)retrieve_lobject, /* SX_LOBJECT */
1424			};
1425
1426			#define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_LAST ? SX_ERROR : (x)])
1427
1428			static SV *mbuf2sv(pTHX);
1429
1430			/***
1431			*** Context management.
1432			***/
1433
1434			/*
1435			* init_perinterp
1436			*
1437			* Called once per "thread" (interpreter) to initialize some global context.
1438			*/
1439	31		static void init_perinterp(pTHX)
1440			{
1441	31		INIT_STCXT;
1442
1443	31		cxt->netorder = 0; /* true if network order used */
1444	31		cxt->forgive_me = -1; /* whether to be forgiving... */
1445	31		cxt->accept_future_minor = -1; /* would otherwise occur too late */
1446	31		}
1447
1448			/*
1449			* reset_context
1450			*
1451			* Called at the end of every context cleaning, to perform common reset
1452			* operations.
1453			*/
1454	1228		static void reset_context(stcxt_t *cxt)
1455			{
1456	1228		cxt->entry = 0;
1457	1228		cxt->s_dirty = 0;
1458	1228		cxt->recur_sv = NULL;
1459	1228		cxt->recur_depth = 0;
1460	1228		cxt->optype &= ~(ST_STORE\|ST_RETRIEVE); /* Leave ST_CLONE alone */
1461	1228		}
1462
1463			/*
1464			* init_store_context
1465			*
1466			* Initialize a new store context for real recursion.
1467			*/
1468	519		static void init_store_context(pTHX_
1469			stcxt_t *cxt,
1470			PerlIO *f,
1471			int optype,
1472			int network_order)
1473			{
1474			TRACEME(("init_store_context"));
1475
1476	519		cxt->netorder = network_order;
1477	519		cxt->forgive_me = -1; /* Fetched from perl if needed */
1478	519		cxt->deparse = -1; /* Idem */
1479	519		cxt->eval = NULL; /* Idem */
1480	519		cxt->canonical = -1; /* Idem */
1481	519		cxt->tagnum = -1; /* Reset tag numbers */
1482	519		cxt->classnum = -1; /* Reset class numbers */
1483	519		cxt->fio = f; /* Where I/O are performed */
1484	519		cxt->optype = optype; /* A store, or a deep clone */
1485	519		cxt->entry = 1; /* No recursion yet */
1486
1487			/*
1488			* The 'hseen' table is used to keep track of each SV stored and their
1489			* associated tag numbers is special. It is "abused" because the
1490			* values stored are not real SV, just integers cast to (SV *),
1491			* which explains the freeing below.
1492			*
1493			* It is also one possible bottleneck to achieve good storing speed,
1494			* so the "shared keys" optimization is turned off (unlikely to be
1495			* of any use here), and the hash table is "pre-extended". Together,
1496			* those optimizations increase the throughput by 12%.
1497			*/
1498
1499			#ifdef USE_PTR_TABLE
1500	519		cxt->pseen = ptr_table_new();
1501	519		cxt->hseen = 0;
1502			#else
1503			cxt->hseen = newHV(); /* Table where seen objects are stored */
1504			HvSHAREKEYS_off(cxt->hseen);
1505			#endif
1506			/*
1507			* The following does not work well with perl5.004_04, and causes
1508			* a core dump later on, in a completely unrelated spot, which
1509			* makes me think there is a memory corruption going on.
1510			*
1511			* Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking
1512			* it below does not make any difference. It seems to work fine
1513			* with perl5.004_68 but given the probable nature of the bug,
1514			* that does not prove anything.
1515			*
1516			* It's a shame because increasing the amount of buckets raises
1517			* store() throughput by 5%, but until I figure this out, I can't
1518			* allow for this to go into production.
1519			*
1520			* It is reported fixed in 5.005, hence the #if.
1521			*/
1522			#if PERL_VERSION >= 5
1523			#define HBUCKETS 4096 /* Buckets for %hseen */
1524			#ifndef USE_PTR_TABLE
1525			HvMAX(cxt->hseen) = HBUCKETS - 1; /* keys %hseen = $HBUCKETS; */
1526			#endif
1527			#endif
1528
1529			/*
1530			* The 'hclass' hash uses the same settings as 'hseen' above, but it is
1531			* used to assign sequential tags (numbers) to class names for blessed
1532			* objects.
1533			*
1534			* We turn the shared key optimization on.
1535			*/
1536
1537	519		cxt->hclass = newHV(); /* Where seen classnames are stored */
1538
1539			#if PERL_VERSION >= 5
1540	519		HvMAX(cxt->hclass) = HBUCKETS - 1; /* keys %hclass = $HBUCKETS; */
1541			#endif
1542
1543			/*
1544			* The 'hook' hash table is used to keep track of the references on
1545			* the STORABLE_freeze hook routines, when found in some class name.
1546			*
1547			* It is assumed that the inheritance tree will not be changed during
1548			* storing, and that no new method will be dynamically created by the
1549			* hooks.
1550			*/
1551
1552	519		cxt->hook = newHV(); /* Table where hooks are cached */
1553
1554			/*
1555			* The 'hook_seen' array keeps track of all the SVs returned by
1556			* STORABLE_freeze hooks for us to serialize, so that they are not
1557			* reclaimed until the end of the serialization process. Each SV is
1558			* only stored once, the first time it is seen.
1559			*/
1560
1561	519		cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */
1562	519		}
1563
1564			/*
1565			* clean_store_context
1566			*
1567			* Clean store context by
1568			*/
1569	518		static void clean_store_context(pTHX_ stcxt_t *cxt)
1570			{
1571			HE *he;
1572
1573			TRACEME(("clean_store_context"));
1574
1575			ASSERT(cxt->optype & ST_STORE, ("was performing a store()"));
1576
1577			/*
1578			* Insert real values into hashes where we stored faked pointers.
1579			*/
1580
1581			#ifndef USE_PTR_TABLE
1582			if (cxt->hseen) {
1583			hv_iterinit(cxt->hseen);
1584			while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall */
1585			HeVAL(he) = &PL_sv_undef;
1586			}
1587			#endif
1588
1589	518	50	if (cxt->hclass) {
1590	518		hv_iterinit(cxt->hclass);
1591	687	100	while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall */
1592	169		HeVAL(he) = &PL_sv_undef;
1593			}
1594
1595			/*
1596			* And now dispose of them...
1597			*
1598			* The surrounding if() protection has been added because there might be
1599			* some cases where this routine is called more than once, during
1600			* exceptional events. This was reported by Marc Lehmann when Storable
1601			* is executed from mod_perl, and the fix was suggested by him.
1602			* -- RAM, 20/12/2000
1603			*/
1604
1605			#ifdef USE_PTR_TABLE
1606	518	50	if (cxt->pseen) {
1607	518		struct ptr_tbl *pseen = cxt->pseen;
1608	518		cxt->pseen = 0;
1609	518		ptr_table_free(pseen);
1610			}
1611			assert(!cxt->hseen);
1612			#else
1613			if (cxt->hseen) {
1614			HV *hseen = cxt->hseen;
1615			cxt->hseen = 0;
1616			hv_undef(hseen);
1617			sv_free((SV *) hseen);
1618			}
1619			#endif
1620
1621	518	50	if (cxt->hclass) {
1622	518		HV *hclass = cxt->hclass;
1623	518		cxt->hclass = 0;
1624	518		hv_undef(hclass);
1625	518		sv_free((SV *) hclass);
1626			}
1627
1628	518	50	if (cxt->hook) {
1629	518		HV *hook = cxt->hook;
1630	518		cxt->hook = 0;
1631	518		hv_undef(hook);
1632	518		sv_free((SV *) hook);
1633			}
1634
1635	518	50	if (cxt->hook_seen) {
1636	518		AV *hook_seen = cxt->hook_seen;
1637	518		cxt->hook_seen = 0;
1638	518		av_undef(hook_seen);
1639	518		sv_free((SV *) hook_seen);
1640			}
1641
1642	518		cxt->forgive_me = -1; /* Fetched from perl if needed */
1643	518		cxt->deparse = -1; /* Idem */
1644	518	50	if (cxt->eval) {
1645	0		SvREFCNT_dec(cxt->eval);
1646			}
1647	518		cxt->eval = NULL; /* Idem */
1648	518		cxt->canonical = -1; /* Idem */
1649
1650	518		reset_context(cxt);
1651	518		}
1652
1653			/*
1654			* init_retrieve_context
1655			*
1656			* Initialize a new retrieve context for real recursion.
1657			*/
1658	639		static void init_retrieve_context(pTHX_
1659			stcxt_t *cxt, int optype, int is_tainted)
1660			{
1661			TRACEME(("init_retrieve_context"));
1662
1663			/*
1664			* The hook hash table is used to keep track of the references on
1665			* the STORABLE_thaw hook routines, when found in some class name.
1666			*
1667			* It is assumed that the inheritance tree will not be changed during
1668			* storing, and that no new method will be dynamically created by the
1669			* hooks.
1670			*/
1671
1672	639		cxt->hook = newHV(); /* Caches STORABLE_thaw */
1673
1674			#ifdef USE_PTR_TABLE
1675	639		cxt->pseen = 0;
1676			#endif
1677
1678			/*
1679			* If retrieving an old binary version, the cxt->retrieve_vtbl variable
1680			* was set to sv_old_retrieve. We'll need a hash table to keep track of
1681			* the correspondence between the tags and the tag number used by the
1682			* new retrieve routines.
1683			*/
1684
1685	1278		cxt->hseen = (((void)cxt->retrieve_vtbl == (void)sv_old_retrieve)
1686	639	100	? newHV() : 0);
1687
1688	639		cxt->aseen = newAV(); /* Where retrieved objects are kept */
1689	639		cxt->where_is_undef = -1; /* Special case for PL_sv_undef */
1690	639		cxt->aclass = newAV(); /* Where seen classnames are kept */
1691	639		cxt->tagnum = 0; /* Have to count objects... */
1692	639		cxt->classnum = 0; /* ...and class names as well */
1693	639		cxt->optype = optype;
1694	639		cxt->s_tainted = is_tainted;
1695	639		cxt->entry = 1; /* No recursion yet */
1696			#ifndef HAS_RESTRICTED_HASHES
1697			cxt->derestrict = -1; /* Fetched from perl if needed */
1698			#endif
1699			#ifndef HAS_UTF8_ALL
1700			cxt->use_bytes = -1; /* Fetched from perl if needed */
1701			#endif
1702	639		cxt->accept_future_minor = -1;/* Fetched from perl if needed */
1703	639		cxt->in_retrieve_overloaded = 0;
1704	639		}
1705
1706			/*
1707			* clean_retrieve_context
1708			*
1709			* Clean retrieve context by
1710			*/
1711	637		static void clean_retrieve_context(pTHX_ stcxt_t *cxt)
1712			{
1713			TRACEME(("clean_retrieve_context"));
1714
1715			ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
1716
1717	637	50	if (cxt->aseen) {
1718	637		AV *aseen = cxt->aseen;
1719	637		cxt->aseen = 0;
1720	637		av_undef(aseen);
1721	637		sv_free((SV *) aseen);
1722			}
1723	637		cxt->where_is_undef = -1;
1724
1725	637	50	if (cxt->aclass) {
1726	637		AV *aclass = cxt->aclass;
1727	637		cxt->aclass = 0;
1728	637		av_undef(aclass);
1729	637		sv_free((SV *) aclass);
1730			}
1731
1732	637	50	if (cxt->hook) {
1733	637		HV *hook = cxt->hook;
1734	637		cxt->hook = 0;
1735	637		hv_undef(hook);
1736	637		sv_free((SV *) hook);
1737			}
1738
1739	637	100	if (cxt->hseen) {
1740	2		HV *hseen = cxt->hseen;
1741	2		cxt->hseen = 0;
1742	2		hv_undef(hseen);
1743	2		sv_free((SV ) hseen); / optional HV, for backward compat. */
1744			}
1745
1746			#ifndef HAS_RESTRICTED_HASHES
1747			cxt->derestrict = -1; /* Fetched from perl if needed */
1748			#endif
1749			#ifndef HAS_UTF8_ALL
1750			cxt->use_bytes = -1; /* Fetched from perl if needed */
1751			#endif
1752	637		cxt->accept_future_minor = -1; /* Fetched from perl if needed */
1753
1754	637		cxt->in_retrieve_overloaded = 0;
1755	637		reset_context(cxt);
1756	637		}
1757
1758			/*
1759			* clean_context
1760			*
1761			* A workaround for the CROAK bug: cleanup the last context.
1762			*/
1763	106		static void clean_context(pTHX_ stcxt_t *cxt)
1764			{
1765			TRACEME(("clean_context"));
1766
1767			ASSERT(cxt->s_dirty, ("dirty context"));
1768
1769	106	100	if (cxt->membuf_ro)
1770	51		MBUF_RESTORE();
1771
1772			ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
1773
1774	106	100	if (cxt->optype & ST_RETRIEVE)
1775	27		clean_retrieve_context(aTHX_ cxt);
1776	79	100	else if (cxt->optype & ST_STORE)
1777	6		clean_store_context(aTHX_ cxt);
1778			else
1779	73		reset_context(cxt);
1780
1781			ASSERT(!cxt->s_dirty, ("context is clean"));
1782			ASSERT(cxt->entry == 0, ("context is reset"));
1783	106		}
1784
1785			/*
1786			* allocate_context
1787			*
1788			* Allocate a new context and push it on top of the parent one.
1789			* This new context is made globally visible via SET_STCXT().
1790			*/
1791	79		static stcxt_t allocate_context(pTHX_ stcxt_t parent_cxt)
1792			{
1793			stcxt_t *cxt;
1794
1795			TRACEME(("allocate_context"));
1796
1797			ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
1798
1799	79		NEW_STORABLE_CXT_OBJ(cxt);
1800	79		cxt->prev = parent_cxt->my_sv;
1801	79		SET_STCXT(cxt);
1802
1803			ASSERT(!cxt->s_dirty, ("clean context"));
1804
1805	79		return cxt;
1806			}
1807
1808			/*
1809			* free_context
1810			*
1811			* Free current context, which cannot be the "root" one.
1812			* Make the context underneath globally visible via SET_STCXT().
1813			*/
1814	79		static void free_context(pTHX_ stcxt_t *cxt)
1815			{
1816	79	50	stcxt_t prev = (stcxt_t )(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0);
1817
1818			TRACEME(("free_context"));
1819
1820			ASSERT(!cxt->s_dirty, ("clean context"));
1821			ASSERT(prev, ("not freeing root context"));
1822			assert(prev);
1823
1824	79		SvREFCNT_dec(cxt->my_sv);
1825	79		SET_STCXT(prev);
1826
1827			ASSERT(cxt, ("context not void"));
1828	79		}
1829
1830			/***
1831			*** Predicates.
1832			***/
1833
1834			/* these two functions are currently only used within asserts */
1835			#ifdef DASSERT
1836			/*
1837			* is_storing
1838			*
1839			* Tells whether we're in the middle of a store operation.
1840			*/
1841			static int is_storing(pTHX)
1842			{
1843			dSTCXT;
1844
1845			return cxt->entry && (cxt->optype & ST_STORE);
1846			}
1847
1848			/*
1849			* is_retrieving
1850			*
1851			* Tells whether we're in the middle of a retrieve operation.
1852			*/
1853			static int is_retrieving(pTHX)
1854			{
1855			dSTCXT;
1856
1857			return cxt->entry && (cxt->optype & ST_RETRIEVE);
1858			}
1859			#endif
1860
1861			/*
1862			* last_op_in_netorder
1863			*
1864			* Returns whether last operation was made using network order.
1865			*
1866			* This is typically out-of-band information that might prove useful
1867			* to people wishing to convert native to network order data when used.
1868			*/
1869	5		static int last_op_in_netorder(pTHX)
1870			{
1871	5		dSTCXT;
1872
1873			assert(cxt);
1874	5		return cxt->netorder;
1875			}
1876
1877			/***
1878			*** Hook lookup and calling routines.
1879			***/
1880
1881			/*
1882			* pkg_fetchmeth
1883			*
1884			* A wrapper on gv_fetchmethod_autoload() which caches results.
1885			*
1886			* Returns the routine reference as an SV*, or null if neither the package
1887			* nor its ancestors know about the method.
1888			*/
1889	242		static SV *pkg_fetchmeth(pTHX_
1890			HV *cache,
1891			HV *pkg,
1892			const char *method)
1893			{
1894			GV *gv;
1895			SV *sv;
1896	242	50	const char *hvname = HvNAME_get(pkg);
		50
		50
		0
		50
		50
1897
1898
1899			/*
1900			* The following code is the same as the one performed by UNIVERSAL::can
1901			* in the Perl core.
1902			*/
1903
1904	242		gv = gv_fetchmethod_autoload(pkg, method, FALSE);
1905	242	100	if (gv && isGV(gv)) {
		50
1906	157		sv = newRV_inc((SV*) GvCV(gv));
1907			TRACEME(("%s->%s: 0x%" UVxf, hvname, method, PTR2UV(sv)));
1908			} else {
1909	85		sv = newSVsv(&PL_sv_undef);
1910			TRACEME(("%s->%s: not found", hvname, method));
1911			}
1912
1913			/*
1914			* Cache the result, ignoring failure: if we can't store the value,
1915			* it just won't be cached.
1916			*/
1917
1918	242		(void) hv_store(cache, hvname, strlen(hvname), sv, 0);
1919
1920	242	100	return SvOK(sv) ? sv : (SV *) 0;
		50
		50
1921			}
1922
1923			/*
1924			* pkg_hide
1925			*
1926			* Force cached value to be undef: hook ignored even if present.
1927			*/
1928	5		static void pkg_hide(pTHX_
1929			HV *cache,
1930			HV *pkg,
1931			const char *method)
1932			{
1933	5	50	const char *hvname = HvNAME_get(pkg);
		50
		50
		0
		50
		50
1934			PERL_UNUSED_ARG(method);
1935	5		(void) hv_store(cache,
1936			hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0);
1937	5		}
1938
1939			/*
1940			* pkg_uncache
1941			*
1942			* Discard cached value: a whole fetch loop will be retried at next lookup.
1943			*/
1944	2		static void pkg_uncache(pTHX_
1945			HV *cache,
1946			HV *pkg,
1947			const char *method)
1948			{
1949	2	50	const char *hvname = HvNAME_get(pkg);
		50
		50
		0
		50
		50
1950			PERL_UNUSED_ARG(method);
1951	2		(void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
1952	2		}
1953
1954			/*
1955			* pkg_can
1956			*
1957			* Our own "UNIVERSAL::can", which caches results.
1958			*
1959			* Returns the routine reference as an SV*, or null if the object does not
1960			* know about the method.
1961			*/
1962	312		static SV *pkg_can(pTHX_
1963			HV *cache,
1964			HV *pkg,
1965			const char *method)
1966			{
1967			SV **svh;
1968			SV *sv;
1969	312	50	const char *hvname = HvNAME_get(pkg);
		50
		50
		0
		50
		50
1970
1971			TRACEME(("pkg_can for %s->%s", hvname, method));
1972
1973			/*
1974			* Look into the cache to see whether we already have determined
1975			* where the routine was, if any.
1976			*
1977			* NOTA BENE: we don't use 'method' at all in our lookup, since we know
1978			* that only one hook (i.e. always the same) is cached in a given cache.
1979			*/
1980
1981	312		svh = hv_fetch(cache, hvname, strlen(hvname), FALSE);
1982	312	100	if (svh) {
1983	70		sv = *svh;
1984	70	100	if (!SvOK(sv)) {
		50
		50
1985			TRACEME(("cached %s->%s: not found", hvname, method));
1986	32		return (SV *) 0;
1987			} else {
1988			TRACEME(("cached %s->%s: 0x%" UVxf,
1989			hvname, method, PTR2UV(sv)));
1990	38		return sv;
1991			}
1992			}
1993
1994			TRACEME(("not cached yet"));
1995	242		return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */
1996			}
1997
1998			/*
1999			* scalar_call
2000			*
2001			* Call routine as obj->hook(av) in scalar context.
2002			* Propagates the single returned value if not called in void context.
2003			*/
2004	101		static SV *scalar_call(pTHX_
2005			SV *obj,
2006			SV *hook,
2007			int cloning,
2008			AV *av,
2009			I32 flags)
2010			{
2011	101		dSP;
2012			int count;
2013	101		SV *sv = 0;
2014
2015			TRACEME(("scalar_call (cloning=%d)", cloning));
2016
2017	101		ENTER;
2018	101		SAVETMPS;
2019
2020	101	50	PUSHMARK(sp);
2021	101	50	XPUSHs(obj);
2022	101	50	XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */
2023	101	50	if (av) {
2024	101		SV **ary = AvARRAY(av);
2025	101		SSize_t cnt = AvFILLp(av) + 1;
2026			SSize_t i;
2027	101	50	XPUSHs(ary[0]); /* Frozen string */
2028	198	100	for (i = 1; i < cnt; i++) {
2029			TRACEME(("pushing arg #%d (0x%" UVxf ")...",
2030			(int)i, PTR2UV(ary[i])));
2031	97	50	XPUSHs(sv_2mortal(newRV_inc(ary[i])));
2032			}
2033			}
2034	101		PUTBACK;
2035
2036			TRACEME(("calling..."));
2037	101		count = call_sv(hook, flags); /* Go back to Perl code */
2038			TRACEME(("count = %d", count));
2039
2040	101		SPAGAIN;
2041
2042	101	100	if (count) {
2043	12		sv = POPs;
2044	12		SvREFCNT_inc(sv); /* We're returning it, must stay alive! */
2045			}
2046
2047	101		PUTBACK;
2048	101	50	FREETMPS;
2049	101		LEAVE;
2050
2051	101		return sv;
2052			}
2053
2054			/*
2055			* array_call
2056			*
2057			* Call routine obj->hook(cloning) in list context.
2058			* Returns the list of returned values in an array.
2059			*/
2060	106		static AV *array_call(pTHX_
2061			SV *obj,
2062			SV *hook,
2063			int cloning)
2064			{
2065	106		dSP;
2066			int count;
2067			AV *av;
2068			int i;
2069
2070			TRACEME(("array_call (cloning=%d)", cloning));
2071
2072	106		ENTER;
2073	106		SAVETMPS;
2074
2075	106	50	PUSHMARK(sp);
2076	106	50	XPUSHs(obj); /* Target object */
2077	106	50	XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */
2078	106		PUTBACK;
2079
2080	106		count = call_sv(hook, G_ARRAY); /* Go back to Perl code */
2081
2082	106		SPAGAIN;
2083
2084	106		av = newAV();
2085	306	100	for (i = count - 1; i >= 0; i--) {
2086	200		SV *sv = POPs;
2087	200		av_store(av, i, SvREFCNT_inc(sv));
2088			}
2089
2090	106		PUTBACK;
2091	106	50	FREETMPS;
2092	106		LEAVE;
2093
2094	106		return av;
2095			}
2096
2097			#if PERL_VERSION < 15
2098			static void
2099			cleanup_recursive_av(pTHX_ AV* av) {
2100			SSize_t i = AvFILLp(av);
2101			SV** arr = AvARRAY(av);
2102			if (SvMAGICAL(av)) return;
2103			while (i >= 0) {
2104			if (arr[i]) {
2105			#if PERL_VERSION < 14
2106			arr[i] = NULL;
2107			#else
2108			SvREFCNT_dec(arr[i]);
2109			#endif
2110			}
2111			i--;
2112			}
2113			}
2114
2115			#ifndef SvREFCNT_IMMORTAL
2116			#ifdef DEBUGGING
2117			/* exercise the immortal resurrection code in sv_free2() */
2118			# define SvREFCNT_IMMORTAL 1000
2119			#else
2120			# define SvREFCNT_IMMORTAL ((~(U32)0)/2)
2121			#endif
2122			#endif
2123
2124			static void
2125			cleanup_recursive_hv(pTHX_ HV* hv) {
2126			long int i = HvTOTALKEYS(hv);
2127			HE** arr = HvARRAY(hv);
2128			if (SvMAGICAL(hv)) return;
2129			while (i >= 0) {
2130			if (arr[i]) {
2131			SvREFCNT(HeVAL(arr[i])) = SvREFCNT_IMMORTAL;
2132			arr[i] = NULL; /* let it leak. too dangerous to clean it up here */
2133			}
2134			i--;
2135			}
2136			#if PERL_VERSION < 8
2137			((XPVHV*)SvANY(hv))->xhv_array = NULL;
2138			#else
2139			HvARRAY(hv) = NULL;
2140			#endif
2141			HvTOTALKEYS(hv) = 0;
2142			}
2143			static void
2144			cleanup_recursive_rv(pTHX_ SV* sv) {
2145			if (sv && SvROK(sv))
2146			SvREFCNT_dec(SvRV(sv));
2147			}
2148			static void
2149			cleanup_recursive_data(pTHX_ SV* sv) {
2150			if (SvTYPE(sv) == SVt_PVAV) {
2151			cleanup_recursive_av(aTHX_ (AV*)sv);
2152			}
2153			else if (SvTYPE(sv) == SVt_PVHV) {
2154			cleanup_recursive_hv(aTHX_ (HV*)sv);
2155			}
2156			else {
2157			cleanup_recursive_rv(aTHX_ sv);
2158			}
2159			}
2160			#endif
2161
2162			/*
2163			* known_class
2164			*
2165			* Lookup the class name in the 'hclass' table and either assign it a new ID
2166			* or return the existing one, by filling in 'classnum'.
2167			*
2168			* Return true if the class was known, false if the ID was just generated.
2169			*/
2170	215		static int known_class(pTHX_
2171			stcxt_t *cxt,
2172			char name, / Class name */
2173			int len, /* Name length */
2174			I32 *classnum)
2175			{
2176			SV **svh;
2177	215		HV *hclass = cxt->hclass;
2178
2179			TRACEME(("known_class (%s)", name));
2180
2181			/*
2182			* Recall that we don't store pointers in this hash table, but tags.
2183			* Therefore, we need LOW_32BITS() to extract the relevant parts.
2184			*/
2185
2186	215		svh = hv_fetch(hclass, name, len, FALSE);
2187	215	100	if (svh) {
2188	46		classnum = LOW_32BITS(svh);
2189	46		return TRUE;
2190			}
2191
2192			/*
2193			* Unknown classname, we need to record it.
2194			*/
2195
2196	169		cxt->classnum++;
2197	169	50	if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0))
2198	0		CROAK(("Unable to record new classname"));
2199
2200	169		*classnum = cxt->classnum;
2201	169		return FALSE;
2202			}
2203
2204			/***
2205			*** Specific store routines.
2206			***/
2207
2208			/*
2209			* store_ref
2210			*
2211			* Store a reference.
2212			* Layout is SX_REF
2213			*/
2214	13049		static int store_ref(pTHX_ stcxt_t cxt, SV sv)
2215			{
2216			int retval;
2217	13049		int is_weak = 0;
2218			TRACEME(("store_ref (0x%" UVxf ")", PTR2UV(sv)));
2219
2220			/*
2221			* Follow reference, and check if target is overloaded.
2222			*/
2223
2224			#ifdef SvWEAKREF
2225	13049	100	if (SvWEAKREF(sv))
2226	16		is_weak = 1;
2227			TRACEME(("ref (0x%" UVxf ") is%s weak", PTR2UV(sv),
2228			is_weak ? "" : "n't"));
2229			#endif
2230	13049		sv = SvRV(sv);
2231
2232	13049	100	if (SvOBJECT(sv)) {
2233	174		HV stash = (HV ) SvSTASH(sv);
2234	174	50	if (stash && Gv_AMG(stash)) {
		50
		50
		50
		0
		50
		50
		50
		100
2235			TRACEME(("ref (0x%" UVxf ") is overloaded", PTR2UV(sv)));
2236	33	100	PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD);
		50
		100
		0
		100
		50
2237			} else
2238	174	100	PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
		50
		50
		0
		50
		50
2239			} else
2240	12875	100	PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
		100
		100
		50
		100
		50
2241
2242			TRACEME(("recur_depth %u, recur_sv (0x%" UVxf ")", cxt->recur_depth,
2243			PTR2UV(cxt->recur_sv)));
2244	13049	50	if (cxt->entry && cxt->recur_sv == sv) {
		100
2245	42	50	if (++cxt->recur_depth > MAX_DEPTH) {
2246			#if PERL_VERSION < 15
2247			cleanup_recursive_data(aTHX_ (SV*)sv);
2248			#endif
2249	0		CROAK((MAX_DEPTH_ERROR));
2250			}
2251			}
2252	13049		cxt->recur_sv = sv;
2253
2254	13049		retval = store(aTHX_ cxt, sv);
2255	12306	50	if (cxt->entry && cxt->recur_sv == sv && cxt->recur_depth > 0) {
		100
		100
2256			TRACEME(("recur_depth --%u", cxt->recur_depth));
2257	5540		--cxt->recur_depth;
2258			}
2259	12306		return retval;
2260			}
2261
2262			/*
2263			* store_scalar
2264			*
2265			* Store a scalar.
2266			*
2267			* Layout is SX_LSCALAR , SX_SCALAR or SX_UNDEF.
2268			* SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings.
2269			* The section is omitted if is 0.
2270			*
2271			* For vstrings, the vstring portion is stored first with
2272			* SX_LVSTRING or SX_VSTRING , followed by
2273			* SX_(L)SCALAR or SX_(L)UTF8STR with the actual PV.
2274			*
2275			* If integer or double, the layout is SX_INTEGER or SX_DOUBLE .
2276			* Small integers (within [-127, +127]) are stored as SX_BYTE .
2277			*
2278			* For huge strings use SX_LOBJECT SX_type SX_U64
2279			*/
2280	25767		static int store_scalar(pTHX_ stcxt_t cxt, SV sv)
2281			{
2282			IV iv;
2283			char *pv;
2284			STRLEN len;
2285	25767		U32 flags = SvFLAGS(sv); /* "cc -O" may put it in register */
2286
2287			TRACEME(("store_scalar (0x%" UVxf ")", PTR2UV(sv)));
2288
2289			/*
2290			* For efficiency, break the SV encapsulation by peaking at the flags
2291			* directly without using the Perl macros to avoid dereferencing
2292			* sv->sv_flags each time we wish to check the flags.
2293			*/
2294
2295	25767	100	if (!(flags & SVf_OK)) { /* !SvOK(sv) */
2296	5146	100	if (sv == &PL_sv_undef) {
2297			TRACEME(("immortal undef"));
2298	5125	50	PUTMARK(SX_SV_UNDEF);
		50
		0
2299			} else {
2300			TRACEME(("undef at 0x%" UVxf, PTR2UV(sv)));
2301	21	100	PUTMARK(SX_UNDEF);
		50
		50
2302			}
2303	5146		return 0;
2304			}
2305
2306			/*
2307			* Always store the string representation of a scalar if it exists.
2308			* Gisle Aas provided me with this test case, better than a long speach:
2309			*
2310			* perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)'
2311			* SV = PVNV(0x80c8520)
2312			* REFCNT = 1
2313			* FLAGS = (NOK,POK,pNOK,pPOK)
2314			* IV = 0
2315			* NV = 0
2316			* PV = 0x80c83d0 "abc"\0
2317			* CUR = 3
2318			* LEN = 4
2319			*
2320			* Write SX_SCALAR, length, followed by the actual data.
2321			*
2322			* Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as
2323			* appropriate, followed by the actual (binary) data. A double
2324			* is written as a string if network order, for portability.
2325			*
2326			* NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv).
2327			* The reason is that when the scalar value is tainted, the SvNOK(sv)
2328			* value is false.
2329			*
2330			* The test for a read-only scalar with both POK and NOK set is meant
2331			* to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the
2332			* address comparison for each scalar we store.
2333			*/
2334
2335			#define SV_MAYBE_IMMORTAL (SVf_READONLY\|SVf_POK\|SVf_NOK)
2336
2337	20621	100	if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) {
2338	6	100	if (sv == &PL_sv_yes) {
2339			TRACEME(("immortal yes"));
2340	3	50	PUTMARK(SX_SV_YES);
		50
		0
2341	3	50	} else if (sv == &PL_sv_no) {
2342			TRACEME(("immortal no"));
2343	3	50	PUTMARK(SX_SV_NO);
		50
		0
2344			} else {
2345	0	0	pv = SvPV(sv, len); /* We know it's SvPOK */
2346	0		goto string; /* Share code below */
2347			}
2348	20615	100	} else if (flags & SVf_POK) {
2349			/* public string - go direct to string read. */
2350	20037		goto string_readlen;
2351	578	100	} else if (
2352			#if (PATCHLEVEL <= 6)
2353			/* For 5.6 and earlier NV flag trumps IV flag, so only use integer
2354			direct if NV flag is off. */
2355			(flags & (SVf_NOK \| SVf_IOK)) == SVf_IOK
2356			#else
2357			/* 5.7 rules are that if IV public flag is set, IV value is as
2358			good, if not better, than NV value. */
2359	578		flags & SVf_IOK
2360			#endif
2361			) {
2362	548	50	iv = SvIV(sv);
2363			/*
2364			* Will come here from below with iv set if double is an integer.
2365			*/
2366			integer:
2367
2368			/* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
2369			#ifdef SVf_IVisUV
2370			/* Need to do this out here, else 0xFFFFFFFF becomes iv of -1
2371			* (for example) and that ends up in the optimised small integer
2372			* case.
2373			*/
2374	553	100	if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) {
		50
		50
2375			TRACEME(("large unsigned integer as string, value = %" UVuf,
2376			SvUV(sv)));
2377	20		goto string_readlen;
2378			}
2379			#endif
2380			/*
2381			* Optimize small integers into a single byte, otherwise store as
2382			* a real integer (converted into network order if they asked).
2383			*/
2384
2385	930	100	if (iv >= -128 && iv <= 127) {
		100
2386	397		unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
2387	397	100	PUTMARK(SX_BYTE);
		50
		50
2388	397	100	PUTMARK(siv);
		50
		50
2389			TRACEME(("small integer stored as %d", (int)siv));
2390	136	100	} else if (cxt->netorder) {
2391			#ifndef HAS_HTONL
2392			TRACEME(("no htonl, fall back to string for integer"));
2393			goto string_readlen;
2394			#else
2395			I32 niv;
2396
2397
2398			#if IVSIZE > 4
2399	49	50	if (
		0
2400			#ifdef SVf_IVisUV
2401			/* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
2402	49	0	((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) \|\|
		0
		100
2403			#endif
2404	33	100	(iv > (IV)0x7FFFFFFF) \|\| (iv < -(IV)0x80000000)) {
2405			/* Bigger than 32 bits. */
2406			TRACEME(("large network order integer as string, value = %" IVdf, iv));
2407			goto string_readlen;
2408			}
2409			#endif
2410
2411	27		niv = (I32) htonl((I32) iv);
2412			TRACEME(("using network order"));
2413	27	100	PUTMARK(SX_NETINT);
		50
		50
2414	49	100	WRITE_I32(niv);
		50
		50
		50
2415			#endif
2416			} else {
2417	87	100	PUTMARK(SX_INTEGER);
		50
		50
2418	511	100	WRITE(&iv, sizeof(iv));
		50
		50
2419			}
2420
2421			TRACEME(("ok (integer 0x%" UVxf ", value = %" IVdf ")", PTR2UV(sv), iv));
2422	30	50	} else if (flags & SVf_NOK) {
2423			NV nv;
2424			#if (PATCHLEVEL <= 6)
2425			nv = SvNV(sv);
2426			/*
2427			* Watch for number being an integer in disguise.
2428			*/
2429			if (nv == (NV) (iv = I_V(nv))) {
2430			TRACEME(("double %" NVff " is actually integer %" IVdf, nv, iv));
2431			goto integer; /* Share code above */
2432			}
2433			#else
2434
2435	30	100	SvIV_please(sv);
		50
		50
2436	30	100	if (SvIOK_notUV(sv)) {
2437	5	50	iv = SvIV(sv);
2438	5		goto integer; /* Share code above */
2439			}
2440	25	50	nv = SvNV(sv);
2441			#endif
2442
2443	25	100	if (cxt->netorder) {
2444			TRACEME(("double %" NVff " stored as string", nv));
2445	5		goto string_readlen; /* Share code below */
2446			}
2447
2448	20	100	PUTMARK(SX_DOUBLE);
		50
		50
2449	20	100	WRITE(&nv, sizeof(nv));
		50
		50
2450
2451			TRACEME(("ok (double 0x%" UVxf ", value = %" NVff ")", PTR2UV(sv), nv));
2452
2453	0	0	} else if (flags & (SVp_POK \| SVp_NOK \| SVp_IOK)) {
2454			#ifdef SvVOK
2455			MAGIC *mg;
2456			#endif
2457			UV wlen; /* For 64-bit machines */
2458
2459			string_readlen:
2460	20084	100	pv = SvPV(sv, len);
2461
2462			/*
2463			* Will come here from above if it was readonly, POK and NOK but
2464			* neither &PL_sv_yes nor &PL_sv_no.
2465			*/
2466			string:
2467
2468			#ifdef SvVOK
2469	20084	100	if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) {
		50
2470			/* The macro passes this by address, not value, and a lot of
2471			called code assumes that it's 32 bits without checking. */
2472	2		const SSize_t len = mg->mg_len;
2473	2	100	STORE_PV_LEN((const char *)mg->mg_ptr,
		50
		50
		0
		50
		50
		0
		50
		50
		50
		0
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		50
		50
		0
		50
		0
		0
		0
		0
		50
		50
		50
		0
		50
		50
		0
2474			len, SX_VSTRING, SX_LVSTRING);
2475			}
2476			#endif
2477
2478	20084		wlen = (Size_t)len;
2479	20084	100	if (SvUTF8 (sv))
2480	12	100	STORE_UTF8STR(pv, wlen);
		50
		50
		0
		50
		50
		0
		50
		50
		50
		0
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		50
		50
		0
		50
		0
		0
		0
		0
		50
		50
		50
		0
		50
		50
		0
2481			else
2482	20084	50	STORE_SCALAR(pv, wlen);
		100
		50
		50
		100
		50
		50
		100
		100
		100
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
2483			TRACEME(("ok (scalar 0x%" UVxf " '%s', length = %" UVuf ")",
2484			PTR2UV(sv), len >= 2048 ? "" : SvPVX(sv),
2485			(UV)len));
2486			} else {
2487	0		CROAK(("Can't determine type of %s(0x%" UVxf ")",
2488			sv_reftype(sv, FALSE),
2489			PTR2UV(sv)));
2490			}
2491	25767		return 0; /* Ok, no recursion on scalars */
2492			}
2493
2494			/*
2495			* store_array
2496			*
2497			* Store an array.
2498			*
2499			* Layout is SX_ARRAY followed by each item, in increasing index order.
2500			* Each item is stored as
2501			*/
2502	6363		static int store_array(pTHX_ stcxt_t cxt, AV av)
2503			{
2504			SV **sav;
2505	6363		UV len = av_len(av) + 1;
2506			UV i;
2507			int ret;
2508
2509			TRACEME(("store_array (0x%" UVxf ")", PTR2UV(av)));
2510
2511			#ifdef HAS_U64
2512	6363	50	if (len > 0x7fffffffu) {
2513			/*
2514			* Large array by emitting SX_LOBJECT 1 U64 data
2515			*/
2516	0	0	PUTMARK(SX_LOBJECT);
		0
		0
2517	0	0	PUTMARK(SX_ARRAY);
		0
		0
2518	0	0	W64LEN(len);
		0
		0
		0
		0
		0
		0
2519			TRACEME(("lobject size = %lu", (unsigned long)len));
2520			} else
2521			#endif
2522			{
2523			/*
2524			* Normal array by emitting SX_ARRAY, followed by the array length.
2525			*/
2526	6363		I32 l = (I32)len;
2527	6363	100	PUTMARK(SX_ARRAY);
		50
		50
2528	6363	100	WLEN(l);
		100
		50
		100
		50
		100
		100
		100
		50
2529			TRACEME(("size = %d", (int)l));
2530			}
2531
2532			TRACEME(("recur_depth %u, recur_sv (0x%" UVxf ")", cxt->recur_depth,
2533			PTR2UV(cxt->recur_sv)));
2534	6363	50	if (cxt->entry && cxt->recur_sv == (SV*)av) {
		100
2535	6291	100	if (++cxt->recur_depth > MAX_DEPTH) {
2536			/* with <= 5.14 it recurses in the cleanup also, needing 2x stack size */
2537			#if PERL_VERSION < 15
2538			cleanup_recursive_data(aTHX_ (SV*)av);
2539			#endif
2540	1		CROAK((MAX_DEPTH_ERROR));
2541			}
2542			}
2543	6362		cxt->recur_sv = (SV*)av;
2544
2545			/*
2546			* Now store each item recursively.
2547			*/
2548
2549	27579	100	for (i = 0; i < len; i++) {
2550	21717		sav = av_fetch(av, i, 0);
2551	21717	100	if (!sav) {
2552			TRACEME(("(#%d) nonexistent item", (int)i));
2553	3	50	STORE_SV_UNDEF();
		50
		0
2554	3		continue;
2555			}
2556			#if PATCHLEVEL >= 19
2557			/* In 5.19.3 and up, &PL_sv_undef can actually be stored in
2558			* an array; it no longer represents nonexistent elements.
2559			* Historically, we have used SX_SV_UNDEF in arrays for
2560			* nonexistent elements, so we use SX_SVUNDEF_ELEM for
2561			* &PL_sv_undef itself. */
2562	21714	50	if (*sav == &PL_sv_undef) {
2563			TRACEME(("(#%d) undef item", (int)i));
2564	0		cxt->tagnum++;
2565	0	0	PUTMARK(SX_SVUNDEF_ELEM);
		0
		0
2566	0		continue;
2567			}
2568			#endif
2569			TRACEME(("(#%d) item", (int)i));
2570	21714	50	if ((ret = store(aTHX_ cxt, sav))) / Extra () for -Wall */
2571	0		return ret;
2572			}
2573
2574	5862	50	if (cxt->entry && cxt->recur_sv == (SV*)av && cxt->recur_depth > 0) {
		100
		100
2575			TRACEME(("recur_depth --%u", cxt->recur_depth));
2576	277		--cxt->recur_depth;
2577			}
2578			TRACEME(("ok (array)"));
2579
2580	5862		return 0;
2581			}
2582
2583
2584			#if (PATCHLEVEL <= 6)
2585
2586			/*
2587			* sortcmp
2588			*
2589			* Sort two SVs
2590			* Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
2591			*/
2592			static int
2593			sortcmp(const void a, const void b)
2594			{
2595			#if defined(USE_ITHREADS)
2596			dTHX;
2597			#endif /* USE_ITHREADS */
2598			return sv_cmp((SV const ) a, (SV * const *) b);
2599			}
2600
2601			#endif /* PATCHLEVEL <= 6 */
2602
2603			/*
2604			* store_hash
2605			*
2606			* Store a hash table.
2607			*
2608			* For a "normal" hash (not restricted, no utf8 keys):
2609			*
2610			* Layout is SX_HASH followed by each key/value pair, in random order.
2611			* Values are stored as
2612			* Keys are stored as , the section being omitted
2613			* if length is 0.
2614			*
2615			* For a "fancy" hash (restricted or utf8 keys):
2616			*
2617			* Layout is SX_FLAG_HASH followed by each key/value pair,
2618			* in random order.
2619			* Values are stored as
2620			* Keys are stored as , the section being omitted
2621			* if length is 0.
2622			* Currently the only hash flag is "restricted"
2623			* Key flags are as for hv.h
2624			*/
2625	6640		static int store_hash(pTHX_ stcxt_t cxt, HV hv)
2626			{
2627			dVAR;
2628	6640		UV len = (UV)HvTOTALKEYS(hv);
2629			Size_t i;
2630	6640		int ret = 0;
2631			I32 riter;
2632			HE *eiter;
2633	13280		int flagged_hash = ((SvREADONLY(hv)
2634			#ifdef HAS_HASH_KEY_FLAGS
2635	6528		\|\| HvHASKFLAGS(hv)
2636			#endif
2637	6640	100	) ? 1 : 0);
		100
2638	6640		unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
2639
2640			/*
2641			* Signal hash by emitting SX_HASH, followed by the table length.
2642			* Max number of keys per perl version:
2643			* IV - 5.12
2644			* STRLEN 5.14 - 5.24 (size_t: U32/U64)
2645			* SSize_t 5.22c - 5.24c (I32/I64)
2646			* U32 5.25c -
2647			*/
2648
2649	6640	50	if (len > 0x7fffffffu) { /* keys > I32_MAX */
2650			/*
2651			* Large hash: SX_LOBJECT type hashflags? U64 data
2652			*
2653			* Stupid limitation:
2654			* Note that perl5 can store more than 2G keys, but only iterate
2655			* over 2G max. (cperl can)
2656			* We need to manually iterate over it then, unsorted.
2657			* But until perl itself cannot do that, skip that.
2658			*/
2659			TRACEME(("lobject size = %lu", (unsigned long)len));
2660			#ifdef HAS_U64
2661	0	0	PUTMARK(SX_LOBJECT);
		0
		0
2662	0	0	if (flagged_hash) {
2663	0	0	PUTMARK(SX_FLAG_HASH);
		0
		0
2664	0	0	PUTMARK(hash_flags);
		0
		0
2665			} else {
2666	0	0	PUTMARK(SX_HASH);
		0
		0
2667			}
2668	0	0	W64LEN(len);
		0
		0
		0
		0
		0
		0
2669	0		return store_lhash(aTHX_ cxt, hv, hash_flags);
2670			#else
2671			/* <5.12 you could store larger hashes, but cannot iterate over them.
2672			So we reject them, it's a bug. */
2673			CROAK(("Cannot store large objects on a 32bit system"));
2674			#endif
2675			} else {
2676	6640		I32 l = (I32)len;
2677	6640	100	if (flagged_hash) {
2678			TRACEME(("store_hash (0x%" UVxf ") (flags %x)", PTR2UV(hv),
2679			(unsigned int)hash_flags));
2680	135	100	PUTMARK(SX_FLAG_HASH);
		50
		50
2681	135	100	PUTMARK(hash_flags);
		50
		50
2682			} else {
2683			TRACEME(("store_hash (0x%" UVxf ")", PTR2UV(hv)));
2684	6505	100	PUTMARK(SX_HASH);
		50
		50
2685			}
2686	6640	100	WLEN(l);
		100
		50
		100
		50
		100
		100
		100
		50
2687			TRACEME(("size = %d, used = %d", (int)l, (int)HvUSEDKEYS(hv)));
2688			}
2689
2690			TRACEME(("recur_depth %u, recur_sv (0x%" UVxf ")", cxt->recur_depth,
2691			PTR2UV(cxt->recur_sv)));
2692	6640	50	if (cxt->entry && cxt->recur_sv == (SV*)hv) {
		100
2693	6476	100	if (++cxt->recur_depth > MAX_DEPTH_HASH) {
2694			#if PERL_VERSION < 15
2695			cleanup_recursive_data(aTHX_ (SV*)hv);
2696			#endif
2697	1		CROAK((MAX_DEPTH_ERROR));
2698			}
2699			}
2700	6639		cxt->recur_sv = (SV*)hv;
2701
2702			/*
2703			* Save possible iteration state via each() on that table.
2704			*
2705			* Note that perl as of 5.24 can store more than 2G keys, but not
2706			* iterate over it.
2707			* Lengths of hash keys are also limited to I32, which is good.
2708			*/
2709
2710	6639	100	riter = HvRITER_get(hv);
2711	6639	100	eiter = HvEITER_get(hv);
2712	6639		hv_iterinit(hv);
2713
2714			/*
2715			* Now store each item recursively.
2716			*
2717			* If canonical is defined to some true value then store each
2718			* key/value pair in sorted order otherwise the order is random.
2719			* Canonical order is irrelevant when a deep clone operation is performed.
2720			*
2721			* Fetch the value from perl only once per store() operation, and only
2722			* when needed.
2723			*/
2724
2725	6639	100	if (
2726	6639		!(cxt->optype & ST_CLONE)
2727	913	100	&& (cxt->canonical == 1
2728	509	100	\|\| (cxt->canonical < 0
2729	83	100	&& (cxt->canonical =
2730	398	50	(SvTRUE(get_sv("Storable::canonical", GV_ADD))
		50
		50
		50
		50
		100
		100
		50
		100
		50
		0
		100
		0
2731	398		? 1 : 0))))
2732	423		) {
2733			/*
2734			* Storing in order, sorted by key.
2735			* Run through the hash, building up an array of keys in a
2736			* mortal array, sort the array and then run through the
2737			* array.
2738			*/
2739	423		AV *av = newAV();
2740	423		av_extend (av, len);
2741
2742			TRACEME(("using canonical order"));
2743
2744	5206	100	for (i = 0; i < len; i++) {
2745			#ifdef HAS_RESTRICTED_HASHES
2746	4783		HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
2747			#else
2748			HE *he = hv_iternext(hv);
2749			#endif
2750	4783		av_store(av, i, hv_iterkeysv(he));
2751			}
2752
2753	423		STORE_HASH_SORT;
2754
2755	5206	100	for (i = 0; i < len; i++) {
2756			#ifdef HAS_RESTRICTED_HASHES
2757	4783	100	int placeholders = (int)HvPLACEHOLDERS_get(hv);
2758			#endif
2759	4783		unsigned char flags = 0;
2760			char *keyval;
2761			STRLEN keylen_tmp;
2762			I32 keylen;
2763	4783		SV *key = av_shift(av);
2764			/* This will fail if key is a placeholder.
2765			Track how many placeholders we have, and error if we
2766			"see" too many. */
2767	4783		HE *he = hv_fetch_ent(hv, key, 0, 0);
2768			SV *val;
2769
2770	4783	100	if (he) {
2771	4765	50	if (!(val = HeVAL(he))) {
2772			/* Internal error, not I/O error */
2773	0		return 1;
2774			}
2775			} else {
2776			#ifdef HAS_RESTRICTED_HASHES
2777			/* Should be a placeholder. */
2778	18	50	if (placeholders-- < 0) {
2779			/* This should not happen - number of
2780			retrieves should be identical to
2781			number of placeholders. */
2782	0		return 1;
2783			}
2784			/* Value is never needed, and PL_sv_undef is
2785			more space efficient to store. */
2786	18		val = &PL_sv_undef;
2787			ASSERT (flags == 0,
2788			("Flags not 0 but %d", (int)flags));
2789	18		flags = SHV_K_PLACEHOLDER;
2790			#else
2791			return 1;
2792			#endif
2793			}
2794
2795			/*
2796			* Store value first.
2797			*/
2798
2799			TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
2800
2801	4783	50	if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */
2802	0		goto out;
2803
2804			/*
2805			* Write key string.
2806			* Keys are written after values to make sure retrieval
2807			* can be optimal in terms of memory usage, where keys are
2808			* read into a fixed unique buffer called kbuf.
2809			* See retrieve_hash() for details.
2810			*/
2811
2812			/* Implementation of restricted hashes isn't nicely
2813			abstracted: */
2814	4783	100	if ((hash_flags & SHV_RESTRICTED)
2815	22	100	&& SvTRULYREADONLY(val)) {
2816	20		flags \|= SHV_K_LOCKED;
2817			}
2818
2819	4783	50	keyval = SvPV(key, keylen_tmp);
2820	4783		keylen = keylen_tmp;
2821			#ifdef HAS_UTF8_HASHES
2822			/* If you build without optimisation on pre 5.6
2823			then nothing spots that SvUTF8(key) is always 0,
2824			so the block isn't optimised away, at which point
2825			the linker dislikes the reference to
2826			bytes_from_utf8. */
2827	4783	100	if (SvUTF8(key)) {
2828	14		const char *keysave = keyval;
2829	14		bool is_utf8 = TRUE;
2830
2831			/* Just casting the &klen to (STRLEN) won't work
2832			well if STRLEN and I32 are of different widths.
2833			--jhi */
2834	14		keyval = (char)bytes_from_utf8((U8)keyval,
2835			&keylen_tmp,
2836			&is_utf8);
2837
2838			/* If we were able to downgrade here, then than
2839			means that we have a key which only had chars
2840			0-255, but was utf8 encoded. */
2841
2842	14	100	if (keyval != keysave) {
2843	5		keylen = keylen_tmp;
2844	5		flags \|= SHV_K_WASUTF8;
2845			} else {
2846			/* keylen_tmp can't have changed, so no need
2847			to assign back to keylen. */
2848	14		flags \|= SHV_K_UTF8;
2849			}
2850			}
2851			#endif
2852
2853	4783	100	if (flagged_hash) {
2854	48	100	PUTMARK(flags);
		50
		50
2855			TRACEME(("(#%d) key '%s' flags %x %u", (int)i, keyval, flags, *keyval));
2856			} else {
2857			/* This is a workaround for a bug in 5.8.0
2858			that causes the HEK_WASUTF8 flag to be
2859			set on an HEK without the hash being
2860			marked as having key flags. We just
2861			cross our fingers and drop the flag.
2862			AMS 20030901 */
2863			assert (flags == 0 \|\| flags == SHV_K_WASUTF8);
2864			TRACEME(("(#%d) key '%s'", (int)i, keyval));
2865			}
2866	4783	100	WLEN(keylen);
		100
		50
		100
		50
		100
		50
		100
		50
2867	4783	50	if (keylen)
2868	4783	100	WRITE(keyval, keylen);
		50
		50
2869	4783	100	if (flags & SHV_K_WASUTF8)
2870	5		Safefree (keyval);
2871			}
2872
2873			/*
2874			* Free up the temporary array
2875			*/
2876
2877	423		av_undef(av);
2878	423		sv_free((SV *) av);
2879
2880			} else {
2881
2882			/*
2883			* Storing in "random" order (in the order the keys are stored
2884			* within the hash). This is the default and will be faster!
2885			*/
2886
2887	18009	100	for (i = 0; i < len; i++) {
2888			#ifdef HV_ITERNEXT_WANTPLACEHOLDERS
2889	12036		HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
2890			#else
2891			HE *he = hv_iternext(hv);
2892			#endif
2893	12036	50	SV *val = (he ? hv_iterval(hv, he) : 0);
2894
2895	12036	50	if (val == 0)
2896	0		return 1; /* Internal error, not I/O error */
2897
2898	12036	50	if ((ret = store_hentry(aTHX_ cxt, hv, i, he, hash_flags)))
2899	0		goto out;
2900			#if 0
2901			/* Implementation of restricted hashes isn't nicely
2902			abstracted: */
2903			flags = (((hash_flags & SHV_RESTRICTED)
2904			&& SvTRULYREADONLY(val))
2905			? SHV_K_LOCKED : 0);
2906
2907			if (val == &PL_sv_placeholder) {
2908			flags \|= SHV_K_PLACEHOLDER;
2909			val = &PL_sv_undef;
2910			}
2911
2912			/*
2913			* Store value first.
2914			*/
2915
2916			TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
2917
2918			if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall */
2919			goto out;
2920
2921
2922			hek = HeKEY_hek(he);
2923			len = HEK_LEN(hek);
2924			if (len == HEf_SVKEY) {
2925			/* This is somewhat sick, but the internal APIs are
2926			* such that XS code could put one of these in in
2927			* a regular hash.
2928			* Maybe we should be capable of storing one if
2929			* found.
2930			*/
2931			key_sv = HeKEY_sv(he);
2932			flags \|= SHV_K_ISSV;
2933			} else {
2934			/* Regular string key. */
2935			#ifdef HAS_HASH_KEY_FLAGS
2936			if (HEK_UTF8(hek))
2937			flags \|= SHV_K_UTF8;
2938			if (HEK_WASUTF8(hek))
2939			flags \|= SHV_K_WASUTF8;
2940			#endif
2941			key = HEK_KEY(hek);
2942			}
2943			/*
2944			* Write key string.
2945			* Keys are written after values to make sure retrieval
2946			* can be optimal in terms of memory usage, where keys are
2947			* read into a fixed unique buffer called kbuf.
2948			* See retrieve_hash() for details.
2949			*/
2950
2951			if (flagged_hash) {
2952			PUTMARK(flags);
2953			TRACEME(("(#%d) key '%s' flags %x", (int)i, key, flags));
2954			} else {
2955			/* This is a workaround for a bug in 5.8.0
2956			that causes the HEK_WASUTF8 flag to be
2957			set on an HEK without the hash being
2958			marked as having key flags. We just
2959			cross our fingers and drop the flag.
2960			AMS 20030901 */
2961			assert (flags == 0 \|\| flags == SHV_K_WASUTF8);
2962			TRACEME(("(#%d) key '%s'", (int)i, key));
2963			}
2964			if (flags & SHV_K_ISSV) {
2965			int ret;
2966			if ((ret = store(aTHX_ cxt, key_sv)))
2967			goto out;
2968			} else {
2969			WLEN(len);
2970			if (len)
2971			WRITE(key, len);
2972			}
2973			#endif
2974			}
2975			}
2976
2977			TRACEME(("ok (hash 0x%" UVxf ")", PTR2UV(hv)));
2978
2979			out:
2980	6396	50	if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) {
		100
		100
2981			TRACEME(("recur_depth --%u", cxt->recur_depth));
2982	5529		--cxt->recur_depth;
2983			}
2984	6396		HvRITER_set(hv, riter); /* Restore hash iterator state */
2985	6396		HvEITER_set(hv, eiter);
2986
2987	6396		return ret;
2988			}
2989
2990	12036		static int store_hentry(pTHX_
2991			stcxt_t cxt, HV hv, UV i, HE *he, unsigned char hash_flags)
2992			{
2993	12036		int ret = 0;
2994	12036		SV* val = hv_iterval(hv, he);
2995	24072		int flagged_hash = ((SvREADONLY(hv)
2996			#ifdef HAS_HASH_KEY_FLAGS
2997	6920		\|\| HvHASKFLAGS(hv)
2998			#endif
2999	12036	100	) ? 1 : 0);
		100
3000	17152	100	unsigned char flags = (((hash_flags & SHV_RESTRICTED)
3001	5116	100	&& SvTRULYREADONLY(val))
3002			? SHV_K_LOCKED : 0);
3003			#ifndef DEBUGME
3004			PERL_UNUSED_ARG(i);
3005			#endif
3006	12036	100	if (val == &PL_sv_placeholder) {
3007	5104		flags \|= SHV_K_PLACEHOLDER;
3008	5104		val = &PL_sv_undef;
3009			}
3010
3011			/*
3012			* Store value first.
3013			*/
3014
3015			TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
3016
3017			{
3018	12036		HEK* hek = HeKEY_hek(he);
3019	12036		I32 len = HEK_LEN(hek);
3020	12036		SV *key_sv = NULL;
3021	12036		char *key = 0;
3022
3023	12036	50	if ((ret = store(aTHX_ cxt, val)))
3024	0		return ret;
3025	11793	50	if (len == HEf_SVKEY) {
3026	0		key_sv = HeKEY_sv(he);
3027	0		flags \|= SHV_K_ISSV;
3028			} else {
3029			/* Regular string key. */
3030			#ifdef HAS_HASH_KEY_FLAGS
3031	11793	100	if (HEK_UTF8(hek))
3032	9		flags \|= SHV_K_UTF8;
3033	11793	100	if (HEK_WASUTF8(hek))
3034	6		flags \|= SHV_K_WASUTF8;
3035			#endif
3036	11793		key = HEK_KEY(hek);
3037			}
3038			/*
3039			* Write key string.
3040			* Keys are written after values to make sure retrieval
3041			* can be optimal in terms of memory usage, where keys are
3042			* read into a fixed unique buffer called kbuf.
3043			* See retrieve_hash() for details.
3044			*/
3045
3046	11793	100	if (flagged_hash) {
3047	5147	100	PUTMARK(flags);
		50
		50
3048			TRACEME(("(#%d) key '%s' flags %x", (int)i, key, flags));
3049			} else {
3050			/* This is a workaround for a bug in 5.8.0
3051			that causes the HEK_WASUTF8 flag to be
3052			set on an HEK without the hash being
3053			marked as having key flags. We just
3054			cross our fingers and drop the flag.
3055			AMS 20030901 */
3056			assert (flags == 0 \|\| flags == SHV_K_WASUTF8);
3057			TRACEME(("(#%d) key '%s'", (int)i, key));
3058			}
3059	11793	50	if (flags & SHV_K_ISSV) {
3060	0	0	if ((ret = store(aTHX_ cxt, key_sv)))
3061	0		return ret;
3062			} else {
3063	11793	100	WLEN(len);
		100
		50
		100
		50
		100
		100
		100
		50
3064	11793	100	if (len)
3065	11789	100	WRITE(key, len);
		100
		50
3066			}
3067			}
3068	11793		return ret;
3069			}
3070
3071
3072			#ifdef HAS_U64
3073			/*
3074			* store_lhash
3075			*
3076			* Store a overlong hash table, with >2G keys, which we cannot iterate
3077			* over with perl5. xhv_eiter is only I32 there. (only cperl can)
3078			* and we also do not want to sort it.
3079			* So we walk the buckets and chains manually.
3080			*
3081			* type, len and flags are already written.
3082			*/
3083
3084	0		static int store_lhash(pTHX_ stcxt_t cxt, HV hv, unsigned char hash_flags)
3085			{
3086			dVAR;
3087	0		int ret = 0;
3088			Size_t i;
3089	0		UV ix = 0;
3090			HE** array;
3091			#ifdef DEBUGME
3092			UV len = (UV)HvTOTALKEYS(hv);
3093			#endif
3094			if (hash_flags) {
3095			TRACEME(("store_lhash (0x%" UVxf ") (flags %x)", PTR2UV(hv),
3096			(int) hash_flags));
3097			} else {
3098			TRACEME(("store_lhash (0x%" UVxf ")", PTR2UV(hv)));
3099			}
3100			TRACEME(("size = %" UVuf ", used = %" UVuf, len, (UV)HvUSEDKEYS(hv)));
3101
3102			TRACEME(("recur_depth %u, recur_sv (0x%" UVxf ")", cxt->recur_depth,
3103			PTR2UV(cxt->recur_sv)));
3104	0	0	if (cxt->entry && cxt->recur_sv == (SV*)hv) {
		0
3105	0	0	if (++cxt->recur_depth > MAX_DEPTH_HASH) {
3106			#if PERL_VERSION < 15
3107			cleanup_recursive_data(aTHX_ (SV*)hv);
3108			#endif
3109	0		CROAK((MAX_DEPTH_ERROR));
3110			}
3111			}
3112	0		cxt->recur_sv = (SV*)hv;
3113
3114	0		array = HvARRAY(hv);
3115	0	0	for (i = 0; i <= (Size_t)HvMAX(hv); i++) {
3116	0		HE* entry = array[i];
3117	0	0	if (!entry) continue;
3118	0	0	if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags)))
3119	0		return ret;
3120	0	0	while ((entry = HeNEXT(entry))) {
3121	0	0	if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags)))
3122	0		return ret;
3123			}
3124			}
3125	0	0	if (cxt->entry && cxt->recur_sv == (SV*)hv && cxt->recur_depth > 0) {
		0
		0
3126			TRACEME(("recur_depth --%u", cxt->recur_depth));
3127	0		--cxt->recur_depth;
3128			}
3129			assert(ix == len);
3130	0		return ret;
3131			}
3132			#endif
3133
3134			/*
3135			* store_code
3136			*
3137			* Store a code reference.
3138			*
3139			* Layout is SX_CODE followed by a scalar containing the perl
3140			* source code of the code reference.
3141			*/
3142	73		static int store_code(pTHX_ stcxt_t cxt, CV cv)
3143			{
3144			#if PERL_VERSION < 6
3145			/*
3146			* retrieve_code does not work with perl 5.005 or less
3147			*/
3148			return store_other(aTHX_ cxt, (SV*)cv);
3149			#else
3150	73		dSP;
3151			STRLEN len;
3152			STRLEN count, reallen;
3153			SV text, bdeparse;
3154
3155			TRACEME(("store_code (0x%" UVxf ")", PTR2UV(cv)));
3156
3157	73	50	if (
3158	73	100	cxt->deparse == 0 \|\|
3159	41	100	(cxt->deparse < 0 &&
3160	41		!(cxt->deparse =
3161	41	50	SvTRUE(get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0))
		50
		0
		50
		0
		0
		50
		0
		0
		0
		0
		0
		50
		50
		100
		50
		0
		100
		0
3162			) {
3163	3		return store_other(aTHX_ cxt, (SV*)cv);
3164			}
3165
3166			/*
3167			* Require B::Deparse. At least B::Deparse 0.61 is needed for
3168			* blessed code references.
3169			*/
3170			/* Ownership of both SVs is passed to load_module, which frees them. */
3171	70		load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("B::Deparse"), newSVnv(0.61));
3172	70		SPAGAIN;
3173
3174	70		ENTER;
3175	70		SAVETMPS;
3176
3177			/*
3178			* create the B::Deparse object
3179			*/
3180
3181	70	50	PUSHMARK(sp);
3182	70	50	XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP));
3183	70		PUTBACK;
3184	70		count = call_method("new", G_SCALAR);
3185	70		SPAGAIN;
3186	70	50	if (count != 1)
3187	0		CROAK(("Unexpected return value from B::Deparse::new\n"));
3188	70		bdeparse = POPs;
3189
3190			/*
3191			* call the coderef2text method
3192			*/
3193
3194	70	50	PUSHMARK(sp);
3195	70	50	XPUSHs(bdeparse); /* XXX is this already mortal? */
3196	70	50	XPUSHs(sv_2mortal(newRV_inc((SV*)cv)));
3197	70		PUTBACK;
3198	70		count = call_method("coderef2text", G_SCALAR);
3199	70		SPAGAIN;
3200	70	50	if (count != 1)
3201	0		CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
3202
3203	70		text = POPs;
3204	70		len = SvCUR(text);
3205	70	50	reallen = strlen(SvPV_nolen(text));
3206
3207			/*
3208			* Empty code references or XS functions are deparsed as
3209			* "(prototype) ;" or ";".
3210			*/
3211
3212	70	50	if (len == 0 \|\| *(SvPV_nolen(text)+reallen-1) == ';') {
		50
		100
3213	1		CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
3214			}
3215
3216			/*
3217			* Signal code by emitting SX_CODE.
3218			*/
3219
3220	69	100	PUTMARK(SX_CODE);
		50
		50
3221	69		cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */
3222			TRACEME(("size = %d", (int)len));
3223			TRACEME(("code = %s", SvPV_nolen(text)));
3224
3225			/*
3226			* Now store the source code.
3227			*/
3228
3229	69	100	if(SvUTF8 (text))
3230	8	100	STORE_UTF8STR(SvPV_nolen(text), len);
		50
		50
		0
		50
		50
		0
		50
		50
		50
		50
		0
		0
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		100
		50
		50
		100
		50
		0
		0
		50
		100
		50
		50
		50
		100
		50
		50
		50
		50
3231			else
3232	61	100	STORE_SCALAR(SvPV_nolen(text), len);
		100
		50
		50
		100
		50
		50
		50
		100
		50
		50
		50
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		50
		50
		0
		50
		0
		0
		0
		0
		50
		50
		50
		0
		50
		50
		50
		0
		0
3233
3234	69	50	FREETMPS;
3235	69		LEAVE;
3236
3237			TRACEME(("ok (code)"));
3238
3239	70		return 0;
3240			#endif
3241			}
3242
3243			/*
3244			* store_tied
3245			*
3246			* When storing a tied object (be it a tied scalar, array or hash), we lay out
3247			* a special mark, followed by the underlying tied object. For instance, when
3248			* dealing with a tied hash, we store SX_TIED_HASH , where
3249			* stands for the serialization of the tied hash.
3250			*/
3251	19		static int store_tied(pTHX_ stcxt_t cxt, SV sv)
3252			{
3253			MAGIC *mg;
3254	19		SV *obj = NULL;
3255	19		int ret = 0;
3256	19		int svt = SvTYPE(sv);
3257	19		char mtype = 'P';
3258
3259			TRACEME(("store_tied (0x%" UVxf ")", PTR2UV(sv)));
3260
3261			/*
3262			* We have a small run-time penalty here because we chose to factorise
3263			* all tieds objects into the same routine, and not have a store_tied_hash,
3264			* a store_tied_array, etc...
3265			*
3266			* Don't use a switch() statement, as most compilers don't optimize that
3267			* well for 2/3 values. An if() else if() cascade is just fine. We put
3268			* tied hashes first, as they are the most likely beasts.
3269			*/
3270
3271	19	100	if (svt == SVt_PVHV) {
3272			TRACEME(("tied hash"));
3273	7	50	PUTMARK(SX_TIED_HASH); /* Introduces tied hash */
		50
		0
3274	12	100	} else if (svt == SVt_PVAV) {
3275			TRACEME(("tied array"));
3276	6	50	PUTMARK(SX_TIED_ARRAY); /* Introduces tied array */
		50
		0
3277			} else {
3278			TRACEME(("tied scalar"));
3279	6	50	PUTMARK(SX_TIED_SCALAR); /* Introduces tied scalar */
		50
		0
3280	6		mtype = 'q';
3281			}
3282
3283	19	50	if (!(mg = mg_find(sv, mtype)))
3284	0	0	CROAK(("No magic '%c' found while storing tied %s", mtype,
		0
3285			(svt == SVt_PVHV) ? "hash" :
3286			(svt == SVt_PVAV) ? "array" : "scalar"));
3287
3288			/*
3289			* The mg->mg_obj found by mg_find() above actually points to the
3290			* underlying tied Perl object implementation. For instance, if the
3291			* original SV was that of a tied array, then mg->mg_obj is an AV.
3292			*
3293			* Note that we store the Perl object as-is. We don't call its FETCH
3294			* method along the way. At retrieval time, we won't call its STORE
3295			* method either, but the tieing magic will be re-installed. In itself,
3296			* that ensures that the tieing semantics are preserved since further
3297			* accesses on the retrieved object will indeed call the magic methods...
3298			*/
3299
3300			/* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
3301	19	100	obj = mg->mg_obj ? mg->mg_obj : newSV(0);
3302	19	50	if ((ret = store(aTHX_ cxt, obj)))
3303	0		return ret;
3304
3305			TRACEME(("ok (tied)"));
3306
3307	19		return 0;
3308			}
3309
3310			/*
3311			* store_tied_item
3312			*
3313			* Stores a reference to an item within a tied structure:
3314			*
3315			* . \$h{key}, stores both the (tied %h) object and 'key'.
3316			* . \$a[idx], stores both the (tied @a) object and 'idx'.
3317			*
3318			* Layout is therefore either:
3319			* SX_TIED_KEY
3320			* SX_TIED_IDX
3321			*/
3322	2		static int store_tied_item(pTHX_ stcxt_t cxt, SV sv)
3323			{
3324			MAGIC *mg;
3325			int ret;
3326
3327			TRACEME(("store_tied_item (0x%" UVxf ")", PTR2UV(sv)));
3328
3329	2	50	if (!(mg = mg_find(sv, 'p')))
3330	0		CROAK(("No magic 'p' found while storing reference to tied item"));
3331
3332			/*
3333			* We discriminate between \$h{key} and \$a[idx] via mg_ptr.
3334			*/
3335
3336	2	100	if (mg->mg_ptr) {
3337			TRACEME(("store_tied_item: storing a ref to a tied hash item"));
3338	1	50	PUTMARK(SX_TIED_KEY);
		50
		0
3339			TRACEME(("store_tied_item: storing OBJ 0x%" UVxf, PTR2UV(mg->mg_obj)));
3340
3341	1	50	if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
3342	0		return ret;
3343
3344			TRACEME(("store_tied_item: storing PTR 0x%" UVxf, PTR2UV(mg->mg_ptr)));
3345
3346	1	50	if ((ret = store(aTHX_ cxt, (SV ) mg->mg_ptr))) / Idem, for -Wall */
3347	0		return ret;
3348			} else {
3349	1		I32 idx = mg->mg_len;
3350
3351			TRACEME(("store_tied_item: storing a ref to a tied array item "));
3352	1	50	PUTMARK(SX_TIED_IDX);
		50
		0
3353			TRACEME(("store_tied_item: storing OBJ 0x%" UVxf, PTR2UV(mg->mg_obj)));
3354
3355	1	50	if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */
3356	0		return ret;
3357
3358			TRACEME(("store_tied_item: storing IDX %d", (int)idx));
3359
3360	1	50	WLEN(idx);
		0
		0
		0
		0
		50
		50
		50
		0
3361			}
3362
3363			TRACEME(("ok (tied item)"));
3364
3365	2		return 0;
3366			}
3367
3368			/*
3369			* store_hook -- dispatched manually, not via sv_store[]
3370			*
3371			* The blessed SV is serialized by a hook.
3372			*
3373			* Simple Layout is:
3374			*
3375			* SX_HOOK [ ]
3376			*
3377			* where indicates how long , and are, whether
3378			* the trailing part [] is present, the type of object (scalar, array or hash).
3379			* There is also a bit which says how the classname is stored between:
3380			*
3381			*
3382			*
3383			*
3384			* and when the form is used (classname already seen), the "large
3385			* classname" bit in indicates how large the is.
3386			*
3387			* The serialized string returned by the hook is of length and comes
3388			* next. It is an opaque string for us.
3389			*
3390			* Those object IDs which are listed last represent the extra references
3391			* not directly serialized by the hook, but which are linked to the object.
3392			*
3393			* When recursion is mandated to resolve object-IDs not yet seen, we have
3394			* instead, with being flags with bits set to indicate the object type
3395			* and that recursion was indeed needed:
3396			*
3397			* SX_HOOK
3398			*
3399			* that same header being repeated between serialized objects obtained through
3400			* recursion, until we reach flags indicating no recursion, at which point
3401			* we know we've resynchronized with a single layout, after .
3402			*
3403			* When storing a blessed ref to a tied variable, the following format is
3404			* used:
3405			*
3406			* SX_HOOK ... [ ]
3407			*
3408			* The first indication carries an object of type SHT_EXTRA, and the
3409			* real object type is held in the flag. At the very end of the
3410			* serialization stream, the underlying magic object is serialized, just like
3411			* any other tied variable.
3412			*/
3413	106		static int store_hook(
3414			pTHX_
3415			stcxt_t *cxt,
3416			SV *sv,
3417			int type,
3418			HV *pkg,
3419			SV *hook)
3420			{
3421			I32 len;
3422			char *classname;
3423			STRLEN len2;
3424			SV *ref;
3425			AV *av;
3426			SV **ary;
3427			int count; /* really len3 + 1 */
3428			unsigned char flags;
3429			char *pv;
3430			int i;
3431	106		int recursed = 0; /* counts recursion */
3432			int obj_type; /* object type, on 2 bits */
3433			I32 classnum;
3434			int ret;
3435	106		int clone = cxt->optype & ST_CLONE;
3436	106		char mtype = '\0'; /* for blessed ref to tied structures */
3437	106		unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */
3438
3439			TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), (int)cxt->tagnum));
3440
3441			/*
3442			* Determine object type on 2 bits.
3443			*/
3444
3445	106		switch (type) {
3446			case svis_REF:
3447			case svis_SCALAR:
3448	6		obj_type = SHT_SCALAR;
3449	6		break;
3450			case svis_ARRAY:
3451	75		obj_type = SHT_ARRAY;
3452	75		break;
3453			case svis_HASH:
3454	24		obj_type = SHT_HASH;
3455	24		break;
3456			case svis_TIED:
3457			/*
3458			* Produced by a blessed ref to a tied data structure, $o in the
3459			* following Perl code.
3460			*
3461			* my %h;
3462			* tie %h, 'FOO';
3463			* my $o = bless \%h, 'BAR';
3464			*
3465			* Signal the tie-ing magic by setting the object type as SHT_EXTRA
3466			* (since we have only 2 bits in to store the type), and an
3467			* byte flag will be emitted after the FIRST in the
3468			* stream, carrying what we put in 'eflags'.
3469			*/
3470	1		obj_type = SHT_EXTRA;
3471	1		switch (SvTYPE(sv)) {
3472			case SVt_PVHV:
3473	1		eflags = (unsigned char) SHT_THASH;
3474	1		mtype = 'P';
3475	1		break;
3476			case SVt_PVAV:
3477	0		eflags = (unsigned char) SHT_TARRAY;
3478	0		mtype = 'P';
3479	0		break;
3480			default:
3481	0		eflags = (unsigned char) SHT_TSCALAR;
3482	0		mtype = 'q';
3483	0		break;
3484			}
3485	1		break;
3486			default:
3487	0		CROAK(("Unexpected object type (%d) in store_hook()", type));
3488			}
3489	106		flags = SHF_NEED_RECURSE \| obj_type;
3490
3491	106	50	classname = HvNAME_get(pkg);
		50
		50
		0
		50
		50
3492	106		len = strlen(classname);
3493
3494			/*
3495			* To call the hook, we need to fake a call like:
3496			*
3497			* $object->STORABLE_freeze($cloning);
3498			*
3499			* but we don't have the $object here. For instance, if $object is
3500			* a blessed array, what we have in 'sv' is the array, and we can't
3501			* call a method on those.
3502			*
3503			* Therefore, we need to create a temporary reference to the object and
3504			* make the call on that reference.
3505			*/
3506
3507			TRACEME(("about to call STORABLE_freeze on class %s", classname));
3508
3509	106		ref = newRV_inc(sv); /* Temporary reference */
3510	106		av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
3511	106		SvREFCNT_dec(ref); /* Reclaim temporary reference */
3512
3513	106		count = AvFILLp(av) + 1;
3514			TRACEME(("store_hook, array holds %d items", count));
3515
3516			/*
3517			* If they return an empty list, it means they wish to ignore the
3518			* hook for this class (and not just this instance -- that's for them
3519			* to handle if they so wish).
3520			*
3521			* Simply disable the cached entry for the hook (it won't be recomputed
3522			* since it's present in the cache) and recurse to store_blessed().
3523			*/
3524
3525	106	100	if (!count) {
3526			/* free empty list returned by the hook */
3527	5		av_undef(av);
3528	5		sv_free((SV *) av);
3529
3530			/*
3531			* They must not change their mind in the middle of a serialization.
3532			*/
3533
3534	5	50	if (hv_fetch(cxt->hclass, classname, len, FALSE))
3535	0	0	CROAK(("Too late to ignore hooks for %s class \"%s\"",
3536			(cxt->optype & ST_CLONE) ? "cloning" : "storing",
3537			classname));
3538
3539	5		pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
3540
3541			ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"),
3542			("hook invisible"));
3543			TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname));
3544
3545	5		return store_blessed(aTHX_ cxt, sv, type, pkg);
3546			}
3547
3548			/*
3549			* Get frozen string.
3550			*/
3551
3552	101		ary = AvARRAY(av);
3553	101	100	pv = SvPV(ary[0], len2);
3554			/* We can't use pkg_can here because it only caches one method per
3555			* package */
3556			{
3557	101		GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE);
3558	101	100	if (gv && isGV(gv)) {
		50
3559	8	100	if (count > 1)
3560	1		CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname));
3561	7		goto check_done;
3562			}
3563			}
3564
3565			/*
3566			* If they returned more than one item, we need to serialize some
3567			* extra references if not already done.
3568			*
3569			* Loop over the array, starting at position #1, and for each item,
3570			* ensure it is a reference, serialize it if not already done, and
3571			* replace the entry with the tag ID of the corresponding serialized
3572			* object.
3573			*
3574			* We CHEAT by not calling av_fetch() and read directly within the
3575			* array, for speed.
3576			*/
3577
3578	191	100	for (i = 1; i < count; i++) {
3579			#ifdef USE_PTR_TABLE
3580			char *fake_tag;
3581			#else
3582			SV **svh;
3583			#endif
3584	98		SV *rsv = ary[i];
3585			SV *xsv;
3586			SV *tag;
3587	98		AV *av_hook = cxt->hook_seen;
3588
3589	98	50	if (!SvROK(rsv))
3590	0		CROAK(("Item #%d returned by STORABLE_freeze "
3591			"for %s is not a reference", (int)i, classname));
3592	98		xsv = SvRV(rsv); /* Follow ref to know what to look for */
3593
3594			/*
3595			* Look in hseen and see if we have a tag already.
3596			* Serialize entry if not done already, and get its tag.
3597			*/
3598
3599			#ifdef USE_PTR_TABLE
3600			/* Fakery needed because ptr_table_fetch returns zero for a
3601			failure, whereas the existing code assumes that it can
3602			safely store a tag zero. So for ptr_tables we store tag+1
3603			*/
3604	98	100	if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv)))
3605	79		goto sv_seen; /* Avoid moving code too far to the right */
3606			#else
3607			if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
3608			goto sv_seen; /* Avoid moving code too far to the right */
3609			#endif
3610
3611			TRACEME(("listed object %d at 0x%" UVxf " is unknown", i-1,
3612			PTR2UV(xsv)));
3613
3614			/*
3615			* We need to recurse to store that object and get it to be known
3616			* so that we can resolve the list of object-IDs at retrieve time.
3617			*
3618			* The first time we do this, we need to emit the proper header
3619			* indicating that we recursed, and what the type of object is (the
3620			* object we're storing via a user-hook). Indeed, during retrieval,
3621			* we'll have to create the object before recursing to retrieve the
3622			* others, in case those would point back at that object.
3623			*/
3624
3625			/* [SX_HOOK] []
3626	19	100	if (!recursed++) {
3627	17	50	PUTMARK(SX_HOOK);
		50
		0
3628	17	50	PUTMARK(flags);
		50
		0
3629	17	50	if (obj_type == SHT_EXTRA)
3630	0	0	PUTMARK(eflags);
		0
		0
3631			} else
3632	2	50	PUTMARK(flags);
		50
		0
3633
3634	19	50	if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */
3635	0		return ret;
3636
3637			#ifdef USE_PTR_TABLE
3638	19		fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv);
3639	19	50	if (!fake_tag)
3640	0		CROAK(("Could not serialize item #%d from hook in %s",
3641			(int)i, classname));
3642			#else
3643			svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
3644			if (!svh)
3645			CROAK(("Could not serialize item #%d from hook in %s",
3646			(int)i, classname));
3647			#endif
3648			/*
3649			* It was the first time we serialized 'xsv'.
3650			*
3651			* Keep this SV alive until the end of the serialization: if we
3652			* disposed of it right now by decrementing its refcount, and it was
3653			* a temporary value, some next temporary value allocated during
3654			* another STORABLE_freeze might take its place, and we'd wrongly
3655			* assume that new SV was already serialized, based on its presence
3656			* in cxt->hseen.
3657			*
3658			* Therefore, push it away in cxt->hook_seen.
3659			*/
3660
3661	19		av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv));
3662
3663			sv_seen:
3664			/*
3665			* Dispose of the REF they returned. If we saved the 'xsv' away
3666			* in the array of returned SVs, that will not cause the underlying
3667			* referenced SV to be reclaimed.
3668			*/
3669
3670			ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF"));
3671	98		SvREFCNT_dec(rsv); /* Dispose of reference */
3672
3673			/*
3674			* Replace entry with its tag (not a real SV, so no refcnt increment)
3675			*/
3676
3677			#ifdef USE_PTR_TABLE
3678	98		tag = (SV *)--fake_tag;
3679			#else
3680			tag = *svh;
3681			#endif
3682	98		ary[i] = tag;
3683			TRACEME(("listed object %d at 0x%" UVxf " is tag #%" UVuf,
3684			i-1, PTR2UV(xsv), PTR2UV(tag)));
3685			}
3686
3687			/*
3688			* Allocate a class ID if not already done.
3689			*
3690			* This needs to be done after the recursion above, since at retrieval
3691			* time, we'll see the inner objects first. Many thanks to
3692			* Salvador Ortiz Garcia who spot that bug and
3693			* proposed the right fix. -- RAM, 15/09/2000
3694			*/
3695
3696			check_done:
3697	100	100	if (!known_class(aTHX_ cxt, classname, len, &classnum)) {
3698			TRACEME(("first time we see class %s, ID = %d", classname, (int)classnum));
3699	81		classnum = -1; /* Mark: we must store classname */
3700			} else {
3701			TRACEME(("already seen class %s, ID = %d", classname, (int)classnum));
3702			}
3703
3704			/*
3705			* Compute leading flags.
3706			*/
3707
3708	100		flags = obj_type;
3709	100	100	if (((classnum == -1) ? len : classnum) > LG_SCALAR)
		50
3710	0		flags \|= SHF_LARGE_CLASSLEN;
3711	100	100	if (classnum != -1)
3712	19		flags \|= SHF_IDX_CLASSNAME;
3713	100	100	if (len2 > LG_SCALAR)
3714	24		flags \|= SHF_LARGE_STRLEN;
3715	100	100	if (count > 1)
3716	80		flags \|= SHF_HAS_LIST;
3717	100	50	if (count > (LG_SCALAR + 1))
3718	0		flags \|= SHF_LARGE_LISTLEN;
3719
3720			/*
3721			* We're ready to emit either serialized form:
3722			*
3723			* SX_HOOK [ ]
3724			* SX_HOOK [ ]
3725			*
3726			* If we recursed, the SX_HOOK has already been emitted.
3727			*/
3728
3729			TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
3730			"class=%" IVdf " len=%" IVdf " len2=%" IVdf " len3=%d",
3731			recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
3732
3733			/* SX_HOOK [] */
3734	100	100	if (!recursed) {
3735	83	100	PUTMARK(SX_HOOK);
		50
		50
3736	83	100	PUTMARK(flags);
		50
		50
3737	83	100	if (obj_type == SHT_EXTRA)
3738	1	50	PUTMARK(eflags);
		50
		0
3739			} else
3740	17	50	PUTMARK(flags);
		50
		0
3741
3742			/* or */
3743	100	100	if (flags & SHF_IDX_CLASSNAME) {
3744	19	50	if (flags & SHF_LARGE_CLASSLEN)
3745	0	0	WLEN(classnum);
		0
		0
		0
		0
		0
		0
		0
		0
3746			else {
3747	19		unsigned char cnum = (unsigned char) classnum;
3748	19	50	PUTMARK(cnum);
		50
		0
3749			}
3750			} else {
3751	81	50	if (flags & SHF_LARGE_CLASSLEN)
3752	0	0	WLEN(len);
		0
		0
		0
		0
		0
		0
		0
		0
3753			else {
3754	81		unsigned char clen = (unsigned char) len;
3755	81	100	PUTMARK(clen);
		50
		50
3756			}
3757	81	100	WRITE(classname, len); /* Final \0 is omitted */
		50
		50
3758			}
3759
3760			/* */
3761	100	100	if (flags & SHF_LARGE_STRLEN) {
3762	24		I32 wlen2 = len2; /* STRLEN might be 8 bytes */
3763	24	50	WLEN(wlen2); /* Must write an I32 for 64-bit machines */
		0
		0
		0
		0
		50
		50
		50
		0
3764			} else {
3765	76		unsigned char clen = (unsigned char) len2;
3766	76	100	PUTMARK(clen);
		50
		50
3767			}
3768	100	100	if (len2)
3769	66	50	WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */
		50
		0
3770
3771			/* [ ] */
3772	100	100	if (flags & SHF_HAS_LIST) {
3773	80		int len3 = count - 1;
3774	80	50	if (flags & SHF_LARGE_LISTLEN)
3775	0	0	WLEN(len3);
		0
		0
		0
		0
		0
		0
		0
		0
3776			else {
3777	80		unsigned char clen = (unsigned char) len3;
3778	80	50	PUTMARK(clen);
		50
		0
3779			}
3780
3781			/*
3782			* NOTA BENE, for 64-bit machines: the ary[i] below does not yield a
3783			* real pointer, rather a tag number, well under the 32-bit limit.
3784			*/
3785
3786	178	100	for (i = 1; i < count; i++) {
3787	98		I32 tagval = htonl(LOW_32BITS(ary[i]));
3788	98	50	WRITE_I32(tagval);
		50
		100
		0
3789			TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
3790			}
3791			}
3792
3793			/*
3794			* Free the array. We need extra care for indices after 0, since they
3795			* don't hold real SVs but integers cast.
3796			*/
3797
3798	100	100	if (count > 1)
3799	80		AvFILLp(av) = 0; /* Cheat, nothing after 0 interests us */
3800	100		av_undef(av);
3801	100		sv_free((SV *) av);
3802
3803			/*
3804			* If object was tied, need to insert serialization of the magic object.
3805			*/
3806
3807	100	100	if (obj_type == SHT_EXTRA) {
3808			MAGIC *mg;
3809
3810	1	50	if (!(mg = mg_find(sv, mtype))) {
3811	0		int svt = SvTYPE(sv);
3812	0	0	CROAK(("No magic '%c' found while storing ref to tied %s with hook",
		0
3813			mtype, (svt == SVt_PVHV) ? "hash" :
3814			(svt == SVt_PVAV) ? "array" : "scalar"));
3815			}
3816
3817			TRACEME(("handling the magic object 0x%" UVxf " part of 0x%" UVxf,
3818			PTR2UV(mg->mg_obj), PTR2UV(sv)));
3819
3820			/*
3821			* []
3822			*/
3823	1	50	if ((ret = store(aTHX_ cxt, mg->mg_obj)))
3824	0		return ret;
3825			}
3826
3827	105		return 0;
3828			}
3829
3830			/*
3831			* store_blessed -- dispatched manually, not via sv_store[]
3832			*
3833			* Check whether there is a STORABLE_xxx hook defined in the class or in one
3834			* of its ancestors. If there is, then redispatch to store_hook();
3835			*
3836			* Otherwise, the blessed SV is stored using the following layout:
3837			*
3838			* SX_BLESS
3839			*
3840			* where indicates whether is stored on 0 or 4 bytes, depending
3841			* on the high-order bit in flag: if 1, then length follows on 4 bytes.
3842			* Otherwise, the low order bits give the length, thereby giving a compact
3843			* representation for class names less than 127 chars long.
3844			*
3845			* Each seen is remembered and indexed, so that the next time
3846			* an object in the blessed in the same is stored, the following
3847			* will be emitted:
3848			*
3849			* SX_IX_BLESS
3850			*
3851			* where is the classname index, stored on 0 or 4 bytes depending
3852			* on the high-order bit in flag (same encoding as above for ).
3853			*/
3854	221		static int store_blessed(
3855			pTHX_
3856			stcxt_t *cxt,
3857			SV *sv,
3858			int type,
3859			HV *pkg)
3860			{
3861			SV *hook;
3862			char *classname;
3863			I32 len;
3864			I32 classnum;
3865
3866			TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg)));
3867
3868			/*
3869			* Look for a hook for this blessed SV and redirect to store_hook()
3870			* if needed.
3871			*/
3872
3873	221		hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
3874	221	100	if (hook)
3875	106		return store_hook(aTHX_ cxt, sv, type, pkg, hook);
3876
3877			/*
3878			* This is a blessed SV without any serialization hook.
3879			*/
3880
3881	115	50	classname = HvNAME_get(pkg);
		50
		50
		0
		50
		50
3882	115		len = strlen(classname);
3883
3884			TRACEME(("blessed 0x%" UVxf " in %s, no hook: tagged #%d",
3885			PTR2UV(sv), classname, (int)cxt->tagnum));
3886
3887			/*
3888			* Determine whether it is the first time we see that class name (in which
3889			* case it will be stored in the SX_BLESS form), or whether we already
3890			* saw that class name before (in which case the SX_IX_BLESS form will be
3891			* used).
3892			*/
3893
3894	115	100	if (known_class(aTHX_ cxt, classname, len, &classnum)) {
3895			TRACEME(("already seen class %s, ID = %d", classname, (int)classnum));
3896	27	50	PUTMARK(SX_IX_BLESS);
		50
		0
3897	27	50	if (classnum <= LG_BLESS) {
3898	27		unsigned char cnum = (unsigned char) classnum;
3899	27	50	PUTMARK(cnum);
		50
		0
3900			} else {
3901	0		unsigned char flag = (unsigned char) 0x80;
3902	0	0	PUTMARK(flag);
		0
		0
3903	27	0	WLEN(classnum);
		0
		0
		0
		0
		0
		0
		0
		0
3904			}
3905			} else {
3906			TRACEME(("first time we see class %s, ID = %d", classname,
3907			(int)classnum));
3908	88	100	PUTMARK(SX_BLESS);
		50
		50
3909	88	100	if (len <= LG_BLESS) {
3910	87		unsigned char clen = (unsigned char) len;
3911	87	100	PUTMARK(clen);
		50
		50
3912			} else {
3913	1		unsigned char flag = (unsigned char) 0x80;
3914	1	50	PUTMARK(flag);
		50
		0
3915	1	50	WLEN(len); /* Don't BER-encode, this should be rare */
		0
		0
		0
		0
		50
		50
		50
		0
3916			}
3917	88	100	WRITE(classname, len); /* Final \0 is omitted */
		50
		50
3918			}
3919
3920			/*
3921			* Now emit the
3922			*/
3923
3924	220		return SV_STORE(type)(aTHX_ cxt, sv);
3925			}
3926
3927			/*
3928			* store_other
3929			*
3930			* We don't know how to store the item we reached, so return an error condition.
3931			* (it's probably a GLOB, some CODE reference, etc...)
3932			*
3933			* If they defined the 'forgive_me' variable at the Perl level to some
3934			* true value, then don't croak, just warn, and store a placeholder string
3935			* instead.
3936			*/
3937	5		static int store_other(pTHX_ stcxt_t cxt, SV sv)
3938			{
3939			STRLEN len;
3940			char buf[80];
3941
3942			TRACEME(("store_other"));
3943
3944			/*
3945			* Fetch the value from perl only once per store() operation.
3946			*/
3947
3948	5	50	if (
3949	5	50	cxt->forgive_me == 0 \|\|
3950	5	100	(cxt->forgive_me < 0 &&
3951	24	50	!(cxt->forgive_me = SvTRUE
		50
		0
		0
		0
		0
		0
		50
		50
		0
		0
		50
		0
3952	24		(get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
3953			)
3954	3		CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
3955
3956	2		warn("Can't store item %s(0x%" UVxf ")",
3957			sv_reftype(sv, FALSE), PTR2UV(sv));
3958
3959			/*
3960			* Store placeholder string as a scalar instead...
3961			*/
3962
3963	2		(void) sprintf(buf, "You lost %s(0x%" UVxf ")%c", sv_reftype(sv, FALSE),
3964			PTR2UV(sv), (char) 0);
3965
3966	2		len = strlen(buf);
3967	2	50	if (len < 80)
3968	2	50	STORE_SCALAR(buf, len);
		100
		50
		50
		100
		50
		50
		50
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
3969			TRACEME(("ok (dummy \"%s\", length = %" IVdf ")", buf, (IV) len));
3970
3971	2		return 0;
3972			}
3973
3974			/***
3975			*** Store driving routines
3976			***/
3977
3978			/*
3979			* sv_type
3980			*
3981			* WARNING: partially duplicates Perl's sv_reftype for speed.
3982			*
3983			* Returns the type of the SV, identified by an integer. That integer
3984			* may then be used to index the dynamic routine dispatch table.
3985			*/
3986	47002		static int sv_type(pTHX_ SV *sv)
3987			{
3988	47002		switch (SvTYPE(sv)) {
3989			case SVt_NULL:
3990			#if PERL_VERSION <= 10
3991			case SVt_IV:
3992			#endif
3993			case SVt_NV:
3994			/*
3995			* No need to check for ROK, that can't be set here since there
3996			* is no field capable of hodling the xrv_rv reference.
3997			*/
3998	149		return svis_SCALAR;
3999			case SVt_PV:
4000			#if PERL_VERSION <= 10
4001			case SVt_RV:
4002			#else
4003			case SVt_IV:
4004			#endif
4005			case SVt_PVIV:
4006			case SVt_PVNV:
4007			/*
4008			* Starting from SVt_PV, it is possible to have the ROK flag
4009			* set, the pointer to the other SV being either stored in
4010			* the xrv_rv (in the case of a pure SVt_RV), or as the
4011			* xpv_pv field of an SVt_PV and its heirs.
4012			*
4013			* However, those SV cannot be magical or they would be an
4014			* SVt_PVMG at least.
4015			*/
4016	33642		return SvROK(sv) ? svis_REF : svis_SCALAR;
4017			case SVt_PVMG:
4018			case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */
4019	21	100	if ((SvFLAGS(sv) & (SVs_GMG\|SVs_SMG\|SVs_RMG)) ==
4020	8	100	(SVs_GMG\|SVs_SMG\|SVs_RMG) &&
4021	8		(mg_find(sv, 'p')))
4022	2		return svis_TIED_ITEM;
4023			/* FALL THROUGH */
4024			#if PERL_VERSION < 9
4025			case SVt_PVBM:
4026			#endif
4027	19	100	if ((SvFLAGS(sv) & (SVs_GMG\|SVs_SMG\|SVs_RMG)) ==
4028	6	50	(SVs_GMG\|SVs_SMG\|SVs_RMG) &&
4029	6		(mg_find(sv, 'q')))
4030	6		return svis_TIED;
4031	13		return SvROK(sv) ? svis_REF : svis_SCALAR;
4032			case SVt_PVAV:
4033	6444	100	if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
		100
4034	6		return svis_TIED;
4035	6438		return svis_ARRAY;
4036			case SVt_PVHV:
4037	6671	100	if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
		100
4038	8		return svis_TIED;
4039	6663		return svis_HASH;
4040			case SVt_PVCV:
4041	73		return svis_CODE;
4042			#if PERL_VERSION > 8
4043			/* case SVt_INVLIST: */
4044			#endif
4045			default:
4046	2		break;
4047			}
4048
4049	2		return svis_OTHER;
4050			}
4051
4052			/*
4053			* store
4054			*
4055			* Recursively store objects pointed to by the sv to the specified file.
4056			*
4057			* Layout is or SX_OBJECT if we reach an already stored
4058			* object (one for which storage has started -- it may not be over if we have
4059			* a self-referenced structure). This data set forms a stored
4060			*/
4061	52143		static int store(pTHX_ stcxt_t cxt, SV sv)
4062			{
4063			SV **svh;
4064			int ret;
4065			int type;
4066			#ifdef USE_PTR_TABLE
4067	52143		struct ptr_tbl *pseen = cxt->pseen;
4068			#else
4069			HV *hseen = cxt->hseen;
4070			#endif
4071
4072			TRACEME(("store (0x%" UVxf ")", PTR2UV(sv)));
4073
4074			/*
4075			* If object has already been stored, do not duplicate data.
4076			* Simply emit the SX_OBJECT marker followed by its tag data.
4077			* The tag is always written in network order.
4078			*
4079			* NOTA BENE, for 64-bit machines: the "*svh" below does not yield a
4080			* real pointer, rather a tag number (watch the insertion code below).
4081			* That means it probably safe to assume it is well under the 32-bit
4082			* limit, and makes the truncation safe.
4083			* -- RAM, 14/09/1999
4084			*/
4085
4086			#ifdef USE_PTR_TABLE
4087	52143		svh = (SV **)ptr_table_fetch(pseen, sv);
4088			#else
4089			svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
4090			#endif
4091	52143	100	if (svh) {
4092			I32 tagval;
4093
4094	5141	100	if (sv == &PL_sv_undef) {
4095			/* We have seen PL_sv_undef before, but fake it as
4096			if we have not.
4097
4098			Not the simplest solution to making restricted
4099			hashes work on 5.8.0, but it does mean that
4100			repeated references to the one true undef will
4101			take up less space in the output file.
4102			*/
4103			/* Need to jump past the next hv_store, because on the
4104			second store of undef the old hash value will be
4105			SvREFCNT_dec()ed, and as Storable cheats horribly
4106			by storing non-SVs in the hash a SEGV will ensure.
4107			Need to increase the tag number so that the
4108			receiver has no idea what games we're up to. This
4109			special casing doesn't affect hooks that store
4110			undef, as the hook routine does its own lookup into
4111			hseen. Also this means that any references back
4112			to PL_sv_undef (from the pathological case of hooks
4113			storing references to it) will find the seen hash
4114			entry for the first time, as if we didn't have this
4115			hackery here. (That hseen lookup works even on 5.8.0
4116			because it's a key of &PL_sv_undef and a value
4117			which is a tag number, not a value which is
4118			PL_sv_undef.) */
4119	5014		cxt->tagnum++;
4120	5014		type = svis_SCALAR;
4121	5014		goto undef_special_case;
4122			}
4123
4124			#ifdef USE_PTR_TABLE
4125	127		tagval = htonl(LOW_32BITS(((char *)svh)-1));
4126			#else
4127			tagval = htonl(LOW_32BITS(*svh));
4128			#endif
4129
4130			TRACEME(("object 0x%" UVxf " seen as #%d", PTR2UV(sv),
4131			ntohl(tagval)));
4132
4133	254	100	PUTMARK(SX_OBJECT);
		50
		50
4134	127	100	WRITE_I32(tagval);
		50
		100
		50
4135	127		return 0;
4136			}
4137
4138			/*
4139			* Allocate a new tag and associate it with the address of the sv being
4140			* stored, before recursing...
4141			*
4142			* In order to avoid creating new SvIVs to hold the tagnum we just
4143			* cast the tagnum to an SV pointer and store that in the hash. This
4144			* means that we must clean up the hash manually afterwards, but gives
4145			* us a 15% throughput increase.
4146			*
4147			*/
4148
4149	47002		cxt->tagnum++;
4150			#ifdef USE_PTR_TABLE
4151	47002		ptr_table_store(pseen, sv, INT2PTR(SV*, 1 + cxt->tagnum));
4152			#else
4153			if (!hv_store(hseen,
4154			(char ) &sv, sizeof(sv), INT2PTR(SV, cxt->tagnum), 0))
4155			return -1;
4156			#endif
4157
4158			/*
4159			* Store 'sv' and everything beneath it, using appropriate routine.
4160			* Abort immediately if we get a non-zero status back.
4161			*/
4162
4163	47002		type = sv_type(aTHX_ sv);
4164
4165			undef_special_case:
4166			TRACEME(("storing 0x%" UVxf " tag #%d, type %d...",
4167			PTR2UV(sv), (int)cxt->tagnum, (int)type));
4168
4169	52016	100	if (SvOBJECT(sv)) {
4170	216		HV *pkg = SvSTASH(sv);
4171	216		ret = store_blessed(aTHX_ cxt, sv, type, pkg);
4172			} else
4173	51800		ret = SV_STORE(type)(aTHX_ cxt, sv);
4174
4175			TRACEME(("%s (stored 0x%" UVxf ", refcnt=%d, %s)",
4176			ret ? "FAILED" : "ok", PTR2UV(sv),
4177			(int)SvREFCNT(sv), sv_reftype(sv, FALSE)));
4178
4179	50523		return ret;
4180			}
4181
4182			/*
4183			* magic_write
4184			*
4185			* Write magic number and system information into the file.
4186			* Layout is [
4187			* ] where is the length of the byteorder hexa string.
4188			* All size and lengths are written as single characters here.
4189			*
4190			* Note that no byte ordering info is emitted when is true, since
4191			* integers will be emitted in network order in that case.
4192			*/
4193	519		static int magic_write(pTHX_ stcxt_t *cxt)
4194			{
4195			/*
4196			* Starting with 0.6, the "use_network_order" byte flag is also used to
4197			* indicate the version number of the binary image, encoded in the upper
4198			* bits. The bit 0 is always used to indicate network order.
4199			*/
4200			/*
4201			* Starting with 0.7, a full byte is dedicated to the minor version of
4202			* the binary format, which is incremented only when new markers are
4203			* introduced, for instance, but when backward compatibility is preserved.
4204			*/
4205
4206			/* Make these at compile time. The WRITE() macro is sufficiently complex
4207			that it saves about 200 bytes doing it this way and only using it
4208			once. */
4209			static const unsigned char network_file_header[] = {
4210			MAGICSTR_BYTES,
4211			(STORABLE_BIN_MAJOR << 1) \| 1,
4212			STORABLE_BIN_WRITE_MINOR
4213			};
4214			static const unsigned char file_header[] = {
4215			MAGICSTR_BYTES,
4216			(STORABLE_BIN_MAJOR << 1) \| 0,
4217			STORABLE_BIN_WRITE_MINOR,
4218			/* sizeof the array includes the 0 byte at the end: */
4219			(char) sizeof (byteorderstr) - 1,
4220			BYTEORDER_BYTES,
4221			(unsigned char) sizeof(int),
4222			(unsigned char) sizeof(long),
4223			(unsigned char) sizeof(char *),
4224			(unsigned char) sizeof(NV)
4225			};
4226			#ifdef USE_56_INTERWORK_KLUDGE
4227			static const unsigned char file_header_56[] = {
4228			MAGICSTR_BYTES,
4229			(STORABLE_BIN_MAJOR << 1) \| 0,
4230			STORABLE_BIN_WRITE_MINOR,
4231			/* sizeof the array includes the 0 byte at the end: */
4232			(char) sizeof (byteorderstr_56) - 1,
4233			BYTEORDER_BYTES_56,
4234			(unsigned char) sizeof(int),
4235			(unsigned char) sizeof(long),
4236			(unsigned char) sizeof(char *),
4237			(unsigned char) sizeof(NV)
4238			};
4239			#endif
4240			const unsigned char *header;
4241			SSize_t length;
4242
4243			TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) : -1));
4244
4245	519	100	if (cxt->netorder) {
4246	92		header = network_file_header;
4247	92		length = sizeof (network_file_header);
4248			} else {
4249			#ifdef USE_56_INTERWORK_KLUDGE
4250			if (SvTRUE(get_sv("Storable::interwork_56_64bit", GV_ADD))) {
4251			header = file_header_56;
4252			length = sizeof (file_header_56);
4253			} else
4254			#endif
4255			{
4256	427		header = file_header;
4257	427		length = sizeof (file_header);
4258			}
4259			}
4260
4261	519	100	if (!cxt->fio) {
4262			/* sizeof the array includes the 0 byte at the end. */
4263	420		header += sizeof (magicstr) - 1;
4264	420		length -= sizeof (magicstr) - 1;
4265			}
4266
4267	519	100	WRITE( (unsigned char*) header, length);
		50
		50
4268
4269	519		if (!cxt->netorder) {
4270			TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
4271			(unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1,
4272			(int) sizeof(int), (int) sizeof(long),
4273			(int) sizeof(char *), (int) sizeof(NV)));
4274			}
4275	519		return 0;
4276			}
4277
4278			/*
4279			* do_store
4280			*
4281			* Common code for store operations.
4282			*
4283			* When memory store is requested (f = NULL) and a non null SV* is given in
4284			* 'res', it is filled with a new SV created out of the memory buffer.
4285			*
4286			* It is required to provide a non-null 'res' when the operation type is not
4287			* dclone() and store() is performed to memory.
4288			*/
4289	519		static int do_store(pTHX_
4290			PerlIO *f,
4291			SV *sv,
4292			int optype,
4293			int network_order,
4294			SV **res)
4295			{
4296	519		dSTCXT;
4297			int status;
4298
4299			ASSERT(!(f == 0 && !(optype & ST_CLONE)) \|\| res,
4300			("must supply result SV pointer for real recursion to memory"));
4301
4302			TRACEME(("do_store (optype=%d, netorder=%d)",
4303			optype, network_order));
4304
4305	519		optype \|= ST_STORE;
4306
4307			/*
4308			* Workaround for CROAK leak: if they enter with a "dirty" context,
4309			* free up memory for them now.
4310			*/
4311
4312			assert(cxt);
4313	519	100	if (cxt->s_dirty)
4314	15		clean_context(aTHX_ cxt);
4315
4316			/*
4317			* Now that STORABLE_xxx hooks exist, it is possible that they try to
4318			* re-enter store() via the hooks. We need to stack contexts.
4319			*/
4320
4321	519	100	if (cxt->entry)
4322	40		cxt = allocate_context(aTHX_ cxt);
4323
4324	519		cxt->entry++;
4325
4326			ASSERT(cxt->entry == 1, ("starting new recursion"));
4327			ASSERT(!cxt->s_dirty, ("clean context"));
4328
4329			/*
4330			* Ensure sv is actually a reference. From perl, we called something
4331			* like:
4332			* pstore(aTHX_ FILE, \@array);
4333			* so we must get the scalar value behind that reference.
4334			*/
4335
4336	519	50	if (!SvROK(sv))
4337	0		CROAK(("Not a reference"));
4338	519		sv = SvRV(sv); /* So follow it to know what to store */
4339
4340			/*
4341			* If we're going to store to memory, reset the buffer.
4342			*/
4343
4344	519	100	if (!f)
4345	420	100	MBUF_INIT(0);
4346
4347			/*
4348			* Prepare context and emit headers.
4349			*/
4350
4351	519		init_store_context(aTHX_ cxt, f, optype, network_order);
4352
4353	519	50	if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */
4354	0		return 0; /* Error */
4355
4356			/*
4357			* Recursively store object...
4358			*/
4359
4360			ASSERT(is_storing(aTHX), ("within store operation"));
4361
4362	519		status = store(aTHX_ cxt, sv); /* Just do it! */
4363
4364			/*
4365			* If they asked for a memory store and they provided an SV pointer,
4366			* make an SV string out of the buffer and fill their pointer.
4367			*
4368			* When asking for ST_REAL, it's MANDATORY for the caller to provide
4369			* an SV, since context cleanup might free the buffer if we did recurse.
4370			* (unless caller is dclone(), which is aware of that).
4371			*/
4372
4373	512	100	if (!cxt->fio && res)
		100
4374	254		*res = mbuf2sv(aTHX);
4375
4376			/*
4377			* Final cleanup.
4378			*
4379			* The "root" context is never freed, since it is meant to be always
4380			* handy for the common case where no recursion occurs at all (i.e.
4381			* we enter store() outside of any Storable code and leave it, period).
4382			* We know it's the "root" context because there's nothing stacked
4383			* underneath it.
4384			*
4385			* OPTIMIZATION:
4386			*
4387			* When deep cloning, we don't free the context: doing so would force
4388			* us to copy the data in the memory buffer. Sicne we know we're
4389			* about to enter do_retrieve...
4390			*/
4391
4392	512		clean_store_context(aTHX_ cxt);
4393	512	100	if (cxt->prev && !(cxt->optype & ST_CLONE))
		100
4394	39		free_context(aTHX_ cxt);
4395
4396			TRACEME(("do_store returns %d", status));
4397
4398	512		return status == 0;
4399			}
4400
4401			/***
4402			*** Memory stores.
4403			***/
4404
4405			/*
4406			* mbuf2sv
4407			*
4408			* Build a new SV out of the content of the internal memory buffer.
4409			*/
4410	254		static SV *mbuf2sv(pTHX)
4411			{
4412	254		dSTCXT;
4413
4414			assert(cxt);
4415	254		return newSVpv(mbase, MBUF_SIZE());
4416			}
4417
4418			/***
4419			*** Specific retrieve callbacks.
4420			***/
4421
4422			/*
4423			* retrieve_other
4424			*
4425			* Return an error via croak, since it is not possible that we get here
4426			* under normal conditions, when facing a file produced via pstore().
4427			*/
4428	10		static SV retrieve_other(pTHX_ stcxt_t cxt, const char *cname)
4429			{
4430			PERL_UNUSED_ARG(cname);
4431	10	100	if (
4432	2	50	cxt->ver_major != STORABLE_BIN_MAJOR &&
4433	2		cxt->ver_minor != STORABLE_BIN_MINOR
4434			) {
4435	2	50	CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d",
4436			cxt->fio ? "file" : "string",
4437			cxt->ver_major, cxt->ver_minor,
4438			STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
4439			} else {
4440	8	100	CROAK(("Corrupted storable %s (binary v%d.%d)",
4441			cxt->fio ? "file" : "string",
4442			cxt->ver_major, cxt->ver_minor));
4443			}
4444
4445			return (SV ) 0; / Just in case */
4446			}
4447
4448			/*
4449			* retrieve_idx_blessed
4450			*
4451			* Layout is SX_IX_BLESS
4452			* can be coded on either 1 or 5 bytes.
4453			*/
4454	19		static SV retrieve_idx_blessed(pTHX_ stcxt_t cxt, const char *cname)
4455			{
4456			I32 idx;
4457			const char *classname;
4458			SV **sva;
4459			SV *sv;
4460
4461			PERL_UNUSED_ARG(cname);
4462			TRACEME(("retrieve_idx_blessed (#%d)", (int)cxt->tagnum));
4463			ASSERT(!cname, ("no bless-into class given here, got %s", cname));
4464
4465	19	50	GETMARK(idx); /* Index coded on a single char? */
		50
		0
4466	19	50	if (idx & 0x80)
4467	0	0	RLEN(idx);
		0
		0
		0
		0
4468
4469			/*
4470			* Fetch classname in 'aclass'
4471			*/
4472
4473	19		sva = av_fetch(cxt->aclass, idx, FALSE);
4474	19	50	if (!sva)
4475	0		CROAK(("Class name #%" IVdf " should have been seen already",
4476			(IV) idx));
4477
4478	19		classname = SvPVX(sva); / We know it's a PV, by construction */
4479
4480			TRACEME(("class ID %d => %s", (int)idx, classname));
4481
4482			/*
4483			* Retrieve object and bless it.
4484			*/
4485
4486	19		sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN
4487			will be blessed */
4488
4489	19		return sv;
4490			}
4491
4492			/*
4493			* retrieve_blessed
4494			*
4495			* Layout is SX_BLESS
4496			* can be coded on either 1 or 5 bytes.
4497			*/
4498	80		static SV retrieve_blessed(pTHX_ stcxt_t cxt, const char *cname)
4499			{
4500			U32 len;
4501			SV *sv;
4502			char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
4503	80		char *classname = buf;
4504	80		char *malloced_classname = NULL;
4505
4506			PERL_UNUSED_ARG(cname);
4507			TRACEME(("retrieve_blessed (#%d)", (int)cxt->tagnum));
4508			ASSERT(!cname, ("no bless-into class given here, got %s", cname));
4509
4510			/*
4511			* Decode class name length and read that name.
4512			*
4513			* Short classnames have two advantages: their length is stored on one
4514			* single byte, and the string can be read on the stack.
4515			*/
4516
4517	80	100	GETMARK(len); /* Length coded on a single char? */
		50
		50
4518	80	100	if (len & 0x80) {
4519	2	50	RLEN(len);
		50
		50
		0
		50
4520			TRACEME(("** allocating %ld bytes for class name", (long)len+1));
4521	2	100	if (len > I32_MAX)
4522	1		CROAK(("Corrupted classname length %lu", (long)len));
4523	1		PL_nomemok = TRUE; /* handle error by ourselves */
4524	1		New(10003, classname, len+1, char);
4525	1		PL_nomemok = FALSE;
4526	1	50	if (!classname)
4527	0		CROAK(("Out of memory with len %ld", (long)len));
4528	1		PL_nomemok = FALSE;
4529	1		malloced_classname = classname;
4530			}
4531	79	100	SAFEPVREAD(classname, (I32)len, malloced_classname);
		50
		50
4532	79		classname[len] = '\0'; /* Mark string end */
4533
4534			/*
4535			* It's a new classname, otherwise it would have been an SX_IX_BLESS.
4536			*/
4537
4538			TRACEME(("new class name \"%s\" will bear ID = %d", classname,
4539			(int)cxt->classnum));
4540
4541	79	50	if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) {
4542	0		Safefree(malloced_classname);
4543	0		return (SV *) 0;
4544			}
4545
4546			/*
4547			* Retrieve object and bless it.
4548			*/
4549
4550	79		sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */
4551	79	100	if (malloced_classname)
4552	1		Safefree(malloced_classname);
4553
4554	79		return sv;
4555			}
4556
4557			/*
4558			* retrieve_hook
4559			*
4560			* Layout: SX_HOOK [ ]
4561			* with leading mark already read, as usual.
4562			*
4563			* When recursion was involved during serialization of the object, there
4564			* is an unknown amount of serialized objects after the SX_HOOK mark. Until
4565			* we reach a marker with the recursion bit cleared.
4566			*
4567			* If the first byte contains a type of SHT_EXTRA, then the real type
4568			* is held in the byte, and if the object is tied, the serialized
4569			* magic object comes at the very end:
4570			*
4571			* SX_HOOK ... [ ]
4572			*
4573			* This means the STORABLE_thaw hook will NOT get a tied variable during its
4574			* processing (since we won't have seen the magic object by the time the hook
4575			* is called). See comments below for why it was done that way.
4576			*/
4577	104		static SV retrieve_hook(pTHX_ stcxt_t cxt, const char *cname)
4578			{
4579			U32 len;
4580			char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
4581	104		char *classname = buf;
4582			unsigned int flags;
4583			I32 len2;
4584			SV *frozen;
4585	104		I32 len3 = 0;
4586	104		AV *av = 0;
4587			SV *hook;
4588			SV *sv;
4589			SV *rv;
4590			GV *attach;
4591			HV *stash;
4592			int obj_type;
4593	104		int clone = cxt->optype & ST_CLONE;
4594	104		char mtype = '\0';
4595	104		unsigned int extra_type = 0;
4596
4597			PERL_UNUSED_ARG(cname);
4598			TRACEME(("retrieve_hook (#%d)", (int)cxt->tagnum));
4599			ASSERT(!cname, ("no bless-into class given here, got %s", cname));
4600
4601			/*
4602			* Read flags, which tell us about the type, and whether we need
4603			* to recurse.
4604			*/
4605
4606	104	100	GETMARK(flags);
		50
		50
4607
4608			/*
4609			* Create the (empty) object, and mark it as seen.
4610			*
4611			* This must be done now, because tags are incremented, and during
4612			* serialization, the object tag was affected before recursion could
4613			* take place.
4614			*/
4615
4616	104		obj_type = flags & SHF_TYPE_MASK;
4617	104		switch (obj_type) {
4618			case SHT_SCALAR:
4619	3		sv = newSV(0);
4620	3		break;
4621			case SHT_ARRAY:
4622	75		sv = (SV *) newAV();
4623	75		break;
4624			case SHT_HASH:
4625	25		sv = (SV *) newHV();
4626	25		break;
4627			case SHT_EXTRA:
4628			/*
4629			* Read flag to know the type of the object.
4630			* Record associated magic type for later.
4631			*/
4632	1	50	GETMARK(extra_type);
		50
		0
4633	1		switch (extra_type) {
4634			case SHT_TSCALAR:
4635	0		sv = newSV(0);
4636	0		mtype = 'q';
4637	0		break;
4638			case SHT_TARRAY:
4639	0		sv = (SV *) newAV();
4640	0		mtype = 'P';
4641	0		break;
4642			case SHT_THASH:
4643	1		sv = (SV *) newHV();
4644	1		mtype = 'P';
4645	1		break;
4646			default:
4647	0		return retrieve_other(aTHX_ cxt, 0);/* Let it croak */
4648			}
4649	1		break;
4650			default:
4651	0		return retrieve_other(aTHX_ cxt, 0); /* Let it croak */
4652			}
4653	104	50	SEEN0_NN(sv, 0); /* Don't bless yet */
4654
4655			/*
4656			* Whilst flags tell us to recurse, do so.
4657			*
4658			* We don't need to remember the addresses returned by retrieval, because
4659			* all the references will be obtained through indirection via the object
4660			* tags in the object-ID list.
4661			*
4662			* We need to decrement the reference count for these objects
4663			* because, if the user doesn't save a reference to them in the hook,
4664			* they must be freed when this context is cleaned.
4665			*/
4666
4667	123	100	while (flags & SHF_NEED_RECURSE) {
4668			TRACEME(("retrieve_hook recursing..."));
4669	19		rv = retrieve(aTHX_ cxt, 0);
4670	19	50	if (!rv)
4671	0		return (SV *) 0;
4672	19		SvREFCNT_dec(rv);
4673			TRACEME(("retrieve_hook back with rv=0x%" UVxf,
4674			PTR2UV(rv)));
4675	19	50	GETMARK(flags);
		50
		0
4676			}
4677
4678	104	100	if (flags & SHF_IDX_CLASSNAME) {
4679			SV **sva;
4680			I32 idx;
4681
4682			/*
4683			* Fetch index from 'aclass'
4684			*/
4685
4686	19	50	if (flags & SHF_LARGE_CLASSLEN)
4687	0	0	RLEN(idx);
		0
		0
		0
		0
4688			else
4689	19	50	GETMARK(idx);
		50
		0
4690
4691	19		sva = av_fetch(cxt->aclass, idx, FALSE);
4692	19	50	if (!sva)
4693	0		CROAK(("Class name #%" IVdf " should have been seen already",
4694			(IV) idx));
4695
4696	19		classname = SvPVX(sva); / We know it's a PV, by construction */
4697			TRACEME(("class ID %d => %s", (int)idx, classname));
4698
4699			} else {
4700			/*
4701			* Decode class name length and read that name.
4702			*
4703			* NOTA BENE: even if the length is stored on one byte, we don't read
4704			* on the stack. Just like retrieve_blessed(), we limit the name to
4705			* LG_BLESS bytes. This is an arbitrary decision.
4706			*/
4707	85		char *malloced_classname = NULL;
4708
4709	85	100	if (flags & SHF_LARGE_CLASSLEN)
4710	2	50	RLEN(len);
		50
		50
		0
		50
4711			else
4712	83	100	GETMARK(len);
		50
		50
4713
4714			TRACEME(("** allocating %ld bytes for class name", (long)len+1));
4715	85	100	if (len > I32_MAX) /* security */
4716	1		CROAK(("Corrupted classname length %lu", (long)len));
4717	84	100	else if (len > LG_BLESS) { /* security: signed len */
4718	2		PL_nomemok = TRUE; /* handle error by ourselves */
4719	2		New(10003, classname, len+1, char);
4720	2		PL_nomemok = FALSE;
4721	2	50	if (!classname)
4722	0		CROAK(("Out of memory with len %u", (unsigned)len+1));
4723	2		malloced_classname = classname;
4724			}
4725
4726	84	100	SAFEPVREAD(classname, (I32)len, malloced_classname);
		100
		50
4727	83		classname[len] = '\0'; /* Mark string end */
4728
4729			/*
4730			* Record new classname.
4731			*/
4732
4733	83	50	if (!av_store(cxt->aclass, cxt->classnum++,
4734			newSVpvn(classname, len))) {
4735	0		Safefree(malloced_classname);
4736	0		return (SV *) 0;
4737			}
4738			}
4739
4740			TRACEME(("class name: %s", classname));
4741
4742			/*
4743			* Decode user-frozen string length and read it in an SV.
4744			*
4745			* For efficiency reasons, we read data directly into the SV buffer.
4746			* To understand that code, read retrieve_scalar()
4747			*/
4748
4749	102	100	if (flags & SHF_LARGE_STRLEN)
4750	24	50	RLEN(len2);
		50
		50
		0
		50
4751			else
4752	78	100	GETMARK(len2);
		50
		50
4753
4754	102		frozen = NEWSV(10002, len2);
4755	102	100	if (len2) {
4756	62	50	SAFEREAD(SvPVX(frozen), len2, frozen);
		50
		0
4757	62		SvCUR_set(frozen, len2);
4758	62		*SvEND(frozen) = '\0';
4759			}
4760	102		(void) SvPOK_only(frozen); /* Validates string pointer */
4761	102	100	if (cxt->s_tainted) /* Is input source tainted? */
4762	1	50	SvTAINT(frozen);
		0
4763
4764			TRACEME(("frozen string: %d bytes", (int)len2));
4765
4766			/*
4767			* Decode object-ID list length, if present.
4768			*/
4769
4770	102	100	if (flags & SHF_HAS_LIST) {
4771	80	50	if (flags & SHF_LARGE_LISTLEN)
4772	0	0	RLEN(len3);
		0
		0
		0
		0
4773			else
4774	80	50	GETMARK(len3);
		50
		0
4775	80	50	if (len3) {
4776	80		av = newAV();
4777	80		av_extend(av, len3 + 1); /* Leave room for [0] */
4778	80		AvFILLp(av) = len3; /* About to be filled anyway */
4779			}
4780			}
4781
4782			TRACEME(("has %d object IDs to link", (int)len3));
4783
4784			/*
4785			* Read object-ID list into array.
4786			* Because we pre-extended it, we can cheat and fill it manually.
4787			*
4788			* We read object tags and we can convert them into SV* on the fly
4789			* because we know all the references listed in there (as tags)
4790			* have been already serialized, hence we have a valid correspondence
4791			* between each of those tags and the recreated SV.
4792			*/
4793
4794	102	100	if (av) {
4795	80		SV **ary = AvARRAY(av);
4796			int i;
4797	178	100	for (i = 1; i <= len3; i++) { /* We leave [0] alone */
4798			I32 tag;
4799			SV **svh;
4800			SV *xsv;
4801
4802	98	50	READ_I32(tag);
		50
		100
		0
4803	98		tag = ntohl(tag);
4804	98		svh = av_fetch(cxt->aseen, tag, FALSE);
4805	98	50	if (!svh) {
4806	0	0	if (tag == cxt->where_is_undef) {
4807			/* av_fetch uses PL_sv_undef internally, hence this
4808			somewhat gruesome hack. */
4809	0		xsv = &PL_sv_undef;
4810	0		svh = &xsv;
4811			} else {
4812	0		CROAK(("Object #%" IVdf
4813			" should have been retrieved already",
4814			(IV) tag));
4815			}
4816			}
4817	98		xsv = *svh;
4818	98		ary[i] = SvREFCNT_inc(xsv);
4819			}
4820			}
4821
4822			/*
4823			* Look up the STORABLE_attach hook
4824			* If blessing is disabled, just return what we've got.
4825			*/
4826	102	50	if (!(cxt->flags & FLAG_BLESS_OK)) {
4827			TRACEME(("skipping bless because flags is %d", cxt->flags));
4828	0		return sv;
4829			}
4830
4831			/*
4832			* Bless the object and look up the STORABLE_thaw hook.
4833			*/
4834	102		stash = gv_stashpv(classname, GV_ADD);
4835
4836			/* Handle attach case; again can't use pkg_can because it only
4837			* caches one method */
4838	102		attach = gv_fetchmethod_autoload(stash, "STORABLE_attach", FALSE);
4839	102	100	if (attach && isGV(attach)) {
		50
4840			SV* attached;
4841	13		SV* attach_hook = newRV_inc((SV*) GvCV(attach));
4842
4843	13	100	if (av)
4844	1		CROAK(("STORABLE_attach called with unexpected references"));
4845	12		av = newAV();
4846	12		av_extend(av, 1);
4847	12		AvFILLp(av) = 0;
4848	12		AvARRAY(av)[0] = SvREFCNT_inc(frozen);
4849	12		rv = newSVpv(classname, 0);
4850	12		attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
4851			/* Free memory after a call */
4852	12		SvREFCNT_dec(rv);
4853	12		SvREFCNT_dec(frozen);
4854	12		av_undef(av);
4855	12		sv_free((SV *) av);
4856	12		SvREFCNT_dec(attach_hook);
4857	12	50	if (attached &&
		100
4858	9	100	SvROK(attached) &&
4859	9		sv_derived_from(attached, classname)
4860			) {
4861	5		UNSEE();
4862			/* refcnt of unneeded sv is 2 at this point
4863			(one from newHV, second from SEEN call) */
4864	5		SvREFCNT_dec(sv);
4865	5		SvREFCNT_dec(sv);
4866			/* we need to free RV but preserve value that RV point to */
4867	5		sv = SvRV(attached);
4868	5	50	SEEN0_NN(sv, 0);
4869	5		SvRV_set(attached, NULL);
4870	5		SvREFCNT_dec(attached);
4871	5	50	if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
		50
4872	0		Safefree(classname);
4873	5		return sv;
4874			}
4875	7		CROAK(("STORABLE_attach did not return a %s object", classname));
4876			}
4877
4878			/*
4879			* Bless the object and look up the STORABLE_thaw hook.
4880			*/
4881
4882	89	50	BLESS(sv, stash);
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
4883
4884	89		hook = pkg_can(aTHX_ cxt->hook, stash, "STORABLE_thaw");
4885	89	100	if (!hook) {
4886			/*
4887			* Hook not found. Maybe they did not require the module where this
4888			* hook is defined yet?
4889			*
4890			* If the load below succeeds, we'll be able to find the hook.
4891			* Still, it only works reliably when each class is defined in a
4892			* file of its own.
4893			*/
4894
4895			TRACEME(("No STORABLE_thaw defined for objects of class %s", classname));
4896			TRACEME(("Going to load module '%s'", classname));
4897	2		load_module(PERL_LOADMOD_NOIMPORT, newSVpv(classname, 0), Nullsv);
4898
4899			/*
4900			* We cache results of pkg_can, so we need to uncache before attempting
4901			* the lookup again.
4902			*/
4903
4904	2		pkg_uncache(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
4905	2		hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
4906
4907	2	50	if (!hook)
4908	0		CROAK(("No STORABLE_thaw defined for objects of class %s "
4909			"(even after a \"require %s;\")", classname, classname));
4910			}
4911
4912			/*
4913			* If we don't have an 'av' yet, prepare one.
4914			* Then insert the frozen string as item [0].
4915			*/
4916
4917	89	100	if (!av) {
4918	10		av = newAV();
4919	10		av_extend(av, 1);
4920	10		AvFILLp(av) = 0;
4921			}
4922	89		AvARRAY(av)[0] = SvREFCNT_inc(frozen);
4923
4924			/*
4925			* Call the hook as:
4926			*
4927			* $object->STORABLE_thaw($cloning, $frozen, @refs);
4928			*
4929			* where $object is our blessed (empty) object, $cloning is a boolean
4930			* telling whether we're running a deep clone, $frozen is the frozen
4931			* string the user gave us in his serializing hook, and @refs, which may
4932			* be empty, is the list of extra references he returned along for us
4933			* to serialize.
4934			*
4935			* In effect, the hook is an alternate creation routine for the class,
4936			* the object itself being already created by the runtime.
4937			*/
4938
4939			TRACEME(("calling STORABLE_thaw on %s at 0x%" UVxf " (%" IVdf " args)",
4940			classname, PTR2UV(sv), (IV) AvFILLp(av) + 1));
4941
4942	89		rv = newRV_inc(sv);
4943	89		(void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR\|G_DISCARD);
4944	89		SvREFCNT_dec(rv);
4945
4946			/*
4947			* Final cleanup.
4948			*/
4949
4950	89		SvREFCNT_dec(frozen);
4951	89		av_undef(av);
4952	89		sv_free((SV *) av);
4953	89	100	if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
		100
4954	1		Safefree(classname);
4955
4956			/*
4957			* If we had an type, then the object was not as simple, and
4958			* we need to restore extra magic now.
4959			*/
4960
4961	89	100	if (!extra_type)
4962	88		return sv;
4963
4964			TRACEME(("retrieving magic object for 0x%" UVxf "...", PTR2UV(sv)));
4965
4966	1		rv = retrieve(aTHX_ cxt, 0); /* Retrieve */
4967
4968			TRACEME(("restoring the magic object 0x%" UVxf " part of 0x%" UVxf,
4969			PTR2UV(rv), PTR2UV(sv)));
4970
4971	1		switch (extra_type) {
4972			case SHT_TSCALAR:
4973	0		sv_upgrade(sv, SVt_PVMG);
4974	0		break;
4975			case SHT_TARRAY:
4976	0		sv_upgrade(sv, SVt_PVAV);
4977	0		AvREAL_off((AV *)sv);
4978	0		break;
4979			case SHT_THASH:
4980	1		sv_upgrade(sv, SVt_PVHV);
4981	1		break;
4982			default:
4983	0		CROAK(("Forgot to deal with extra type %d", extra_type));
4984			break;
4985			}
4986
4987			/*
4988			* Adding the magic only now, well after the STORABLE_thaw hook was called
4989			* means the hook cannot know it deals with an object whose variable is
4990			* tied. But this is happening when retrieving $o in the following case:
4991			*
4992			* my %h;
4993			* tie %h, 'FOO';
4994			* my $o = bless \%h, 'BAR';
4995			*
4996			* The 'BAR' class is NOT the one where %h is tied into. Therefore, as
4997			* far as the 'BAR' class is concerned, the fact that %h is not a REAL
4998			* hash but a tied one should not matter at all, and remain transparent.
4999			* This means the magic must be restored by Storable AFTER the hook is
5000			* called.
5001			*
5002			* That looks very reasonable to me, but then I've come up with this
5003			* after a bug report from David Nesting, who was trying to store such
5004			* an object and caused Storable to fail. And unfortunately, it was
5005			* also the easiest way to retrofit support for blessed ref to tied objects
5006			* into the existing design. -- RAM, 17/02/2001
5007			*/
5008
5009	1		sv_magic(sv, rv, mtype, (char *)NULL, 0);
5010	1		SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */
5011
5012	95		return sv;
5013			}
5014
5015			/*
5016			* retrieve_ref
5017			*
5018			* Retrieve reference to some other scalar.
5019			* Layout is SX_REF
5020			*/
5021	11217		static SV retrieve_ref(pTHX_ stcxt_t cxt, const char *cname)
5022			{
5023			SV *rv;
5024			SV *sv;
5025			HV *stash;
5026
5027			TRACEME(("retrieve_ref (#%d)", (int)cxt->tagnum));
5028
5029			/*
5030			* We need to create the SV that holds the reference to the yet-to-retrieve
5031			* object now, so that we may record the address in the seen table.
5032			* Otherwise, if the object to retrieve references us, we won't be able
5033			* to resolve the SX_OBJECT we'll see at that point! Hence we cannot
5034			* do the retrieve first and use rv = newRV(sv) since it will be too late
5035			* for SEEN() recording.
5036			*/
5037
5038	11217		rv = NEWSV(10002, 0);
5039	11217	100	if (cname)
5040	2		stash = gv_stashpv(cname, GV_ADD);
5041			else
5042	11215		stash = 0;
5043	11217	50	SEEN_NN(rv, stash, 0); /* Will return if rv is null */
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
5044	11217		sv = retrieve(aTHX_ cxt, 0);/* Retrieve
5045	11215	50	if (!sv)
5046	0		return (SV ) 0; / Failed */
5047
5048			/*
5049			* WARNING: breaks RV encapsulation.
5050			*
5051			* Now for the tricky part. We have to upgrade our existing SV, so that
5052			* it is now an RV on sv... Again, we cheat by duplicating the code
5053			* held in newSVrv(), since we already got our SV from retrieve().
5054			*
5055			* We don't say:
5056			*
5057			* SvRV(rv) = SvREFCNT_inc(sv);
5058			*
5059			* here because the reference count we got from retrieve() above is
5060			* already correct: if the object was retrieved from the file, then
5061			* its reference count is one. Otherwise, if it was retrieved via
5062			* an SX_OBJECT indication, a ref count increment was done.
5063			*/
5064
5065	11215	100	if (cname) {
5066			/* No need to do anything, as rv will already be PVMG. */
5067			assert (SvTYPE(rv) == SVt_RV \|\| SvTYPE(rv) >= SVt_PV);
5068			} else {
5069	11213		sv_upgrade(rv, SVt_RV);
5070			}
5071
5072	11215		SvRV_set(rv, sv); /* $rv = \$sv */
5073	11215		SvROK_on(rv);
5074			/*if (cxt->entry && ++cxt->ref_cnt > MAX_REF_CNT) {
5075			CROAK(("Max. recursion depth with nested refs exceeded"));
5076			}*/
5077
5078			TRACEME(("ok (retrieve_ref at 0x%" UVxf ")", PTR2UV(rv)));
5079
5080	11215		return rv;
5081			}
5082
5083			/*
5084			* retrieve_weakref
5085			*
5086			* Retrieve weak reference to some other scalar.
5087			* Layout is SX_WEAKREF
5088			*/
5089	12		static SV retrieve_weakref(pTHX_ stcxt_t cxt, const char *cname)
5090			{
5091			SV *sv;
5092
5093			TRACEME(("retrieve_weakref (#%d)", (int)cxt->tagnum));
5094
5095	12		sv = retrieve_ref(aTHX_ cxt, cname);
5096	12	50	if (sv) {
5097			#ifdef SvWEAKREF
5098	12		sv_rvweaken(sv);
5099			#else
5100			WEAKREF_CROAK();
5101			#endif
5102			}
5103	12		return sv;
5104			}
5105
5106			/*
5107			* retrieve_overloaded
5108			*
5109			* Retrieve reference to some other scalar with overloading.
5110			* Layout is SX_OVERLOAD
5111			*/
5112	34		static SV retrieve_overloaded(pTHX_ stcxt_t cxt, const char *cname)
5113			{
5114			SV *rv;
5115			SV *sv;
5116			HV *stash;
5117
5118			TRACEME(("retrieve_overloaded (#%d)", (int)cxt->tagnum));
5119
5120			/*
5121			* Same code as retrieve_ref(), duplicated to avoid extra call.
5122			*/
5123
5124	34		rv = NEWSV(10002, 0);
5125	34	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5126	34	50	SEEN_NN(rv, stash, 0); /* Will return if rv is null */
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
5127	34		cxt->in_retrieve_overloaded = 1; /* so sv_bless doesn't call S_reset_amagic */
5128	34		sv = retrieve(aTHX_ cxt, 0); /* Retrieve
5129	34		cxt->in_retrieve_overloaded = 0;
5130	34	50	if (!sv)
5131	0		return (SV ) 0; / Failed */
5132
5133			/*
5134			* WARNING: breaks RV encapsulation.
5135			*/
5136
5137	34	100	SvUPGRADE(rv, SVt_RV);
5138	34		SvRV_set(rv, sv); /* $rv = \$sv */
5139	34		SvROK_on(rv);
5140
5141			/*
5142			* Restore overloading magic.
5143			*/
5144
5145	34	50	stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0;
5146	34	50	if (!stash) {
5147	0		CROAK(("Cannot restore overloading on %s(0x%" UVxf
5148			") (package )",
5149			sv_reftype(sv, FALSE),
5150			PTR2UV(sv)));
5151			}
5152	34	50	if (!Gv_AMG(stash)) {
		50
		50
		0
		50
		50
		50
		50
		50
5153	0	0	const char *package = HvNAME_get(stash);
		0
		0
		0
		0
		0
5154			TRACEME(("No overloading defined for package %s", package));
5155			TRACEME(("Going to load module '%s'", package));
5156	0		load_module(PERL_LOADMOD_NOIMPORT, newSVpv(package, 0), Nullsv);
5157	0	0	if (!Gv_AMG(stash)) {
		0
		0
		0
		0
		0
		0
		0
		0
5158	0		CROAK(("Cannot restore overloading on %s(0x%" UVxf
5159			") (package %s) (even after a \"require %s;\")",
5160			sv_reftype(sv, FALSE),
5161			PTR2UV(sv),
5162			package, package));
5163			}
5164			}
5165
5166	34		SvAMAGIC_on(rv);
5167
5168			TRACEME(("ok (retrieve_overloaded at 0x%" UVxf ")", PTR2UV(rv)));
5169
5170	34		return rv;
5171			}
5172
5173			/*
5174			* retrieve_weakoverloaded
5175			*
5176			* Retrieve weak overloaded reference to some other scalar.
5177			* Layout is SX_WEAKOVERLOADED
5178			*/
5179	4		static SV retrieve_weakoverloaded(pTHX_ stcxt_t cxt, const char *cname)
5180			{
5181			SV *sv;
5182
5183			TRACEME(("retrieve_weakoverloaded (#%d)", (int)cxt->tagnum));
5184
5185	4		sv = retrieve_overloaded(aTHX_ cxt, cname);
5186	4	50	if (sv) {
5187			#ifdef SvWEAKREF
5188	4		sv_rvweaken(sv);
5189			#else
5190			WEAKREF_CROAK();
5191			#endif
5192			}
5193	4		return sv;
5194			}
5195
5196			/*
5197			* retrieve_tied_array
5198			*
5199			* Retrieve tied array
5200			* Layout is SX_TIED_ARRAY
5201			*/
5202	4		static SV retrieve_tied_array(pTHX_ stcxt_t cxt, const char *cname)
5203			{
5204			SV *tv;
5205			SV *sv;
5206			HV *stash;
5207
5208			TRACEME(("retrieve_tied_array (#%d)", (int)cxt->tagnum));
5209
5210	4	50	if (!(cxt->flags & FLAG_TIE_OK)) {
5211	0		CROAK(("Tying is disabled."));
5212			}
5213
5214	4		tv = NEWSV(10002, 0);
5215	4	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5216	4	50	SEEN_NN(tv, stash, 0); /* Will return if tv is null */
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
5217	4		sv = retrieve(aTHX_ cxt, 0); /* Retrieve
5218	4	50	if (!sv)
5219	0		return (SV ) 0; / Failed */
5220
5221	4		sv_upgrade(tv, SVt_PVAV);
5222	4		sv_magic(tv, sv, 'P', (char *)NULL, 0);
5223	4		SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
5224
5225			TRACEME(("ok (retrieve_tied_array at 0x%" UVxf ")", PTR2UV(tv)));
5226
5227	4		return tv;
5228			}
5229
5230			/*
5231			* retrieve_tied_hash
5232			*
5233			* Retrieve tied hash
5234			* Layout is SX_TIED_HASH
5235			*/
5236	4		static SV retrieve_tied_hash(pTHX_ stcxt_t cxt, const char *cname)
5237			{
5238			SV *tv;
5239			SV *sv;
5240			HV *stash;
5241
5242			TRACEME(("retrieve_tied_hash (#%d)", (int)cxt->tagnum));
5243
5244	4	50	if (!(cxt->flags & FLAG_TIE_OK)) {
5245	0		CROAK(("Tying is disabled."));
5246			}
5247
5248	4		tv = NEWSV(10002, 0);
5249	4	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5250	4	50	SEEN_NN(tv, stash, 0); /* Will return if tv is null */
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
5251	4		sv = retrieve(aTHX_ cxt, 0); /* Retrieve
5252	4	50	if (!sv)
5253	0		return (SV ) 0; / Failed */
5254
5255	4		sv_upgrade(tv, SVt_PVHV);
5256	4		sv_magic(tv, sv, 'P', (char *)NULL, 0);
5257	4		SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
5258
5259			TRACEME(("ok (retrieve_tied_hash at 0x%" UVxf ")", PTR2UV(tv)));
5260
5261	4		return tv;
5262			}
5263
5264			/*
5265			* retrieve_tied_scalar
5266			*
5267			* Retrieve tied scalar
5268			* Layout is SX_TIED_SCALAR
5269			*/
5270	4		static SV retrieve_tied_scalar(pTHX_ stcxt_t cxt, const char *cname)
5271			{
5272			SV *tv;
5273	4		SV sv, obj = NULL;
5274			HV *stash;
5275
5276			TRACEME(("retrieve_tied_scalar (#%d)", (int)cxt->tagnum));
5277
5278	4	50	if (!(cxt->flags & FLAG_TIE_OK)) {
5279	0		CROAK(("Tying is disabled."));
5280			}
5281
5282	4		tv = NEWSV(10002, 0);
5283	4	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5284	4	50	SEEN_NN(tv, stash, 0); /* Will return if rv is null */
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
5285	4		sv = retrieve(aTHX_ cxt, 0); /* Retrieve
5286	4	50	if (!sv) {
5287	0		return (SV ) 0; / Failed */
5288			}
5289	4	100	else if (SvTYPE(sv) != SVt_NULL) {
5290	3		obj = sv;
5291			}
5292
5293	4		sv_upgrade(tv, SVt_PVMG);
5294	4		sv_magic(tv, obj, 'q', (char *)NULL, 0);
5295
5296	4	100	if (obj) {
5297			/* Undo refcnt inc from sv_magic() */
5298	3		SvREFCNT_dec(obj);
5299			}
5300
5301			TRACEME(("ok (retrieve_tied_scalar at 0x%" UVxf ")", PTR2UV(tv)));
5302
5303	4		return tv;
5304			}
5305
5306			/*
5307			* retrieve_tied_key
5308			*
5309			* Retrieve reference to value in a tied hash.
5310			* Layout is SX_TIED_KEY
5311			*/
5312	1		static SV retrieve_tied_key(pTHX_ stcxt_t cxt, const char *cname)
5313			{
5314			SV *tv;
5315			SV *sv;
5316			SV *key;
5317			HV *stash;
5318
5319			TRACEME(("retrieve_tied_key (#%d)", (int)cxt->tagnum));
5320
5321	1	50	if (!(cxt->flags & FLAG_TIE_OK)) {
5322	0		CROAK(("Tying is disabled."));
5323			}
5324
5325	1		tv = NEWSV(10002, 0);
5326	1	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5327	1	50	SEEN_NN(tv, stash, 0); /* Will return if tv is null */
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5328	1		sv = retrieve(aTHX_ cxt, 0); /* Retrieve
5329	1	50	if (!sv)
5330	0		return (SV ) 0; / Failed */
5331
5332	1		key = retrieve(aTHX_ cxt, 0); /* Retrieve */
5333	1	50	if (!key)
5334	0		return (SV ) 0; / Failed */
5335
5336	1		sv_upgrade(tv, SVt_PVMG);
5337	1		sv_magic(tv, sv, 'p', (char *)key, HEf_SVKEY);
5338	1		SvREFCNT_dec(key); /* Undo refcnt inc from sv_magic() */
5339	1		SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
5340
5341	1		return tv;
5342			}
5343
5344			/*
5345			* retrieve_tied_idx
5346			*
5347			* Retrieve reference to value in a tied array.
5348			* Layout is SX_TIED_IDX
5349			*/
5350	1		static SV retrieve_tied_idx(pTHX_ stcxt_t cxt, const char *cname)
5351			{
5352			SV *tv;
5353			SV *sv;
5354			HV *stash;
5355			I32 idx;
5356
5357			TRACEME(("retrieve_tied_idx (#%d)", (int)cxt->tagnum));
5358
5359	1	50	if (!(cxt->flags & FLAG_TIE_OK)) {
5360	0		CROAK(("Tying is disabled."));
5361			}
5362
5363	1		tv = NEWSV(10002, 0);
5364	1	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5365	1	50	SEEN_NN(tv, stash, 0); /* Will return if tv is null */
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5366	1		sv = retrieve(aTHX_ cxt, 0); /* Retrieve
5367	1	50	if (!sv)
5368	0		return (SV ) 0; / Failed */
5369
5370	1	50	RLEN(idx); /* Retrieve */
		50
		50
		0
		50
5371
5372	1		sv_upgrade(tv, SVt_PVMG);
5373	1		sv_magic(tv, sv, 'p', (char *)NULL, idx);
5374	1		SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
5375
5376	1		return tv;
5377			}
5378
5379			/*
5380			* get_lstring
5381			*
5382			* Helper to read a string
5383			*/
5384	3173		static SV get_lstring(pTHX_ stcxt_t cxt, UV len, int isutf8, const char *cname)
5385			{
5386			SV *sv;
5387			HV *stash;
5388
5389			TRACEME(("get_lstring (#%d), len = %" UVuf, (int)cxt->tagnum, len));
5390
5391			/*
5392			* Allocate an empty scalar of the suitable length.
5393			*/
5394
5395	3173		sv = NEWSV(10002, len);
5396	3173	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5397	3173	50	SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
		100
		50
		100
		50
		50
		50
		0
		50
		50
		50
		50
		50
5398
5399	3173	100	if (len == 0) {
5400	4		SvPVCLEAR(sv);
5401	4		return sv;
5402			}
5403
5404			/*
5405			* WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
5406			*
5407			* Now, for efficiency reasons, read data directly inside the SV buffer,
5408			* and perform the SV final settings directly by duplicating the final
5409			* work done by sv_setpv. Since we're going to allocate lots of scalars
5410			* this way, it's worth the hassle and risk.
5411			*/
5412
5413	3169	100	SAFEREAD(SvPVX(sv), len, sv);
		100
		100
5414	3148		SvCUR_set(sv, len); /* Record C string length */
5415	3148		SvEND(sv) = '\0'; / Ensure it's null terminated anyway */
5416	3148		(void) SvPOK_only(sv); /* Validate string pointer */
5417	3148	100	if (cxt->s_tainted) /* Is input source tainted? */
5418	108	50	SvTAINT(sv); /* External data cannot be trusted */
		0
5419
5420			/* Check for CVE-215-1592 */
5421	3148	100	if (cname && len == 13 && strEQc(cname, "CGITempFile")
		50
		0
5422	0	0	&& strEQc(SvPVX(sv), "mt-config.cgi")) {
5423			#if defined(USE_CPERL) && defined(WARN_SECURITY)
5424			Perl_warn_security(aTHX_
5425			"Movable-Type CVE-2015-1592 Storable metasploit attack");
5426			#else
5427	0		Perl_warn(aTHX_
5428			"SECURITY: Movable-Type CVE-2015-1592 Storable metasploit attack");
5429			#endif
5430			}
5431
5432	3148	100	if (isutf8) {
5433			TRACEME(("large utf8 string len %" UVuf " '%s'", len,
5434			len >= 2048 ? "" : SvPVX(sv)));
5435			#ifdef HAS_UTF8_SCALARS
5436	28		SvUTF8_on(sv);
5437			#else
5438			if (cxt->use_bytes < 0)
5439			cxt->use_bytes
5440			= (SvTRUE(get_sv("Storable::drop_utf8", GV_ADD))
5441			? 1 : 0);
5442			if (cxt->use_bytes == 0)
5443			UTF8_CROAK();
5444			#endif
5445			} else {
5446			TRACEME(("large string len %" UVuf " '%s'", len,
5447			len >= 2048 ? "" : SvPVX(sv)));
5448			}
5449			TRACEME(("ok (get_lstring at 0x%" UVxf ")", PTR2UV(sv)));
5450
5451	3148		return sv;
5452			}
5453
5454			/*
5455			* retrieve_lscalar
5456			*
5457			* Retrieve defined long (string) scalar.
5458			*
5459			* Layout is SX_LSCALAR , with SX_LSCALAR already read.
5460			* The scalar is "long" in that is larger than LG_SCALAR so it
5461			* was not stored on a single byte, but in 4 bytes. For strings longer than
5462			* 4 byte (>2GB) see retrieve_lobject.
5463			*/
5464	4		static SV retrieve_lscalar(pTHX_ stcxt_t cxt, const char *cname)
5465			{
5466			I32 len;
5467	4	100	RLEN(len);
		50
		50
		50
		100
5468	4		return get_lstring(aTHX_ cxt, len, 0, cname);
5469			}
5470
5471			/*
5472			* retrieve_scalar
5473			*
5474			* Retrieve defined short (string) scalar.
5475			*
5476			* Layout is SX_SCALAR , with SX_SCALAR already read.
5477			* The scalar is "short" so is single byte. If it is 0, there
5478			* is no section.
5479			*/
5480	3145		static SV retrieve_scalar(pTHX_ stcxt_t cxt, const char *cname)
5481			{
5482			int len;
5483			/SV sv;
5484			HV stash;/
5485
5486	3145	100	GETMARK(len);
		100
		100
5487			TRACEME(("retrieve_scalar (#%d), len = %d", (int)cxt->tagnum, len));
5488	3141		return get_lstring(aTHX_ cxt, (UV)len, 0, cname);
5489			}
5490
5491			/*
5492			* retrieve_utf8str
5493			*
5494			* Like retrieve_scalar(), but tag result as utf8.
5495			* If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
5496			*/
5497	20		static SV retrieve_utf8str(pTHX_ stcxt_t cxt, const char *cname)
5498			{
5499			int len;
5500			/SV sv;*/
5501
5502			TRACEME(("retrieve_utf8str"));
5503	20	50	GETMARK(len);
		50
		0
5504	20		return get_lstring(aTHX_ cxt, (UV)len, 1, cname);
5505			}
5506
5507			/*
5508			* retrieve_lutf8str
5509			*
5510			* Like retrieve_lscalar(), but tag result as utf8.
5511			* If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
5512			*/
5513	8		static SV retrieve_lutf8str(pTHX_ stcxt_t cxt, const char *cname)
5514			{
5515			int len;
5516
5517			TRACEME(("retrieve_lutf8str"));
5518
5519	8	100	RLEN(len);
		50
		100
		50
		100
5520	8		return get_lstring(aTHX_ cxt, (UV)len, 1, cname);
5521			}
5522
5523			/*
5524			* retrieve_vstring
5525			*
5526			* Retrieve a vstring, and then retrieve the stringy scalar following it,
5527			* attaching the vstring to the scalar via magic.
5528			* If we're retrieving a vstring in a perl without vstring magic, croaks.
5529			*
5530			* The vstring layout mirrors an SX_SCALAR string:
5531			* SX_VSTRING with SX_VSTRING already read.
5532			*/
5533	1		static SV retrieve_vstring(pTHX_ stcxt_t cxt, const char *cname)
5534			{
5535			#ifdef SvVOK
5536			char s[256];
5537			int len;
5538			SV *sv;
5539
5540	1	50	GETMARK(len);
		50
		0
5541			TRACEME(("retrieve_vstring (#%d), len = %d", (int)cxt->tagnum, len));
5542
5543	1	50	READ(s, len);
		50
		0
5544	1		sv = retrieve(aTHX_ cxt, cname);
5545	1	50	if (!sv)
5546	0		return (SV ) 0; / Failed */
5547	1		sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len);
5548			/* 5.10.0 and earlier seem to need this */
5549	1		SvRMAGICAL_on(sv);
5550
5551			TRACEME(("ok (retrieve_vstring at 0x%" UVxf ")", PTR2UV(sv)));
5552	1		return sv;
5553			#else
5554			VSTRING_CROAK();
5555			return Nullsv;
5556			#endif
5557			}
5558
5559			/*
5560			* retrieve_lvstring
5561			*
5562			* Like retrieve_vstring, but for longer vstrings.
5563			*/
5564	1		static SV retrieve_lvstring(pTHX_ stcxt_t cxt, const char *cname)
5565			{
5566			#ifdef SvVOK
5567			char *s;
5568			I32 len;
5569			SV *sv;
5570
5571	1	50	RLEN(len);
		50
		50
		0
		50
5572			TRACEME(("retrieve_lvstring (#%d), len = %" IVdf,
5573			(int)cxt->tagnum, (IV)len));
5574
5575	1		New(10003, s, len+1, char);
5576	1	50	SAFEPVREAD(s, len, s);
		50
		0
5577
5578	1		sv = retrieve(aTHX_ cxt, cname);
5579	1	50	if (!sv) {
5580	0		Safefree(s);
5581	0		return (SV ) 0; / Failed */
5582			}
5583	1		sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len);
5584			/* 5.10.0 and earlier seem to need this */
5585	1		SvRMAGICAL_on(sv);
5586
5587	1		Safefree(s);
5588
5589			TRACEME(("ok (retrieve_lvstring at 0x%" UVxf ")", PTR2UV(sv)));
5590	1		return sv;
5591			#else
5592			VSTRING_CROAK();
5593			return Nullsv;
5594			#endif
5595			}
5596
5597			/*
5598			* retrieve_integer
5599			*
5600			* Retrieve defined integer.
5601			* Layout is SX_INTEGER , whith SX_INTEGER already read.
5602			*/
5603	85		static SV retrieve_integer(pTHX_ stcxt_t cxt, const char *cname)
5604			{
5605			SV *sv;
5606			HV *stash;
5607			IV iv;
5608
5609			TRACEME(("retrieve_integer (#%d)", (int)cxt->tagnum));
5610
5611	85	100	READ(&iv, sizeof(iv));
		50
		50
5612	85		sv = newSViv(iv);
5613	85	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5614	85	50	SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5615
5616			TRACEME(("integer %" IVdf, iv));
5617			TRACEME(("ok (retrieve_integer at 0x%" UVxf ")", PTR2UV(sv)));
5618
5619	85		return sv;
5620			}
5621
5622			/*
5623			* retrieve_lobject
5624			*
5625			* Retrieve overlong scalar, array or hash.
5626			* Layout is SX_LOBJECT type U64_len ...
5627			*/
5628	0		static SV retrieve_lobject(pTHX_ stcxt_t cxt, const char *cname)
5629			{
5630			SV *sv;
5631			int type;
5632			UV len;
5633
5634			TRACEME(("retrieve_lobject (#%d)", (int)cxt->tagnum));
5635
5636	0	0	GETMARK(type);
		0
		0
5637			TRACEME(("object type %d", type));
5638			#ifdef HAS_U64
5639	0	0	READ(&len, 8);
		0
		0
5640			#else
5641			READ(&len, 4);
5642			/* little-endian: ignore lower word */
5643			# if (BYTEORDER == 0x1234 \|\| BYTEORDER == 0x12345678)
5644			READ(&len, 4);
5645			# endif
5646			if (len > 0)
5647			CROAK(("Invalid large object for this 32bit system"));
5648			#endif
5649			TRACEME(("wlen %" UVuf, len));
5650	0		switch (type) {
5651			case SX_LSCALAR:
5652	0		sv = get_lstring(aTHX_ cxt, len, 0, cname);
5653	0		break;
5654			case SX_LUTF8STR:
5655	0		sv = get_lstring(aTHX_ cxt, len, 1, cname);
5656	0		break;
5657			case SX_ARRAY:
5658	0		sv = get_larray(aTHX_ cxt, len, cname);
5659	0		break;
5660			/* <5.12 you could store larger hashes, but cannot iterate over them.
5661			So we reject them, it's a bug. */
5662			case SX_FLAG_HASH:
5663			#ifdef HAS_U64
5664	0		sv = get_lhash(aTHX_ cxt, len, 1, cname);
5665			#else
5666			CROAK(("Invalid large object for this 32bit system"));
5667			#endif
5668	0		break;
5669			case SX_HASH:
5670			#ifdef HAS_U64
5671	0		sv = get_lhash(aTHX_ cxt, len, 0, cname);
5672			#else
5673			CROAK(("Invalid large object for this 32bit system"));
5674			#endif
5675	0		break;
5676			default:
5677	0		CROAK(("Unexpected type %d in retrieve_lobject\n", type));
5678			}
5679
5680			TRACEME(("ok (retrieve_lobject at 0x%" UVxf ")", PTR2UV(sv)));
5681	0		return sv;
5682			}
5683
5684			/*
5685			* retrieve_netint
5686			*
5687			* Retrieve defined integer in network order.
5688			* Layout is SX_NETINT , whith SX_NETINT already read.
5689			*/
5690	26		static SV retrieve_netint(pTHX_ stcxt_t cxt, const char *cname)
5691			{
5692			SV *sv;
5693			HV *stash;
5694			I32 iv;
5695
5696			TRACEME(("retrieve_netint (#%d)", (int)cxt->tagnum));
5697
5698	26	100	READ_I32(iv);
		50
		50
		50
5699			#ifdef HAS_NTOHL
5700	26		sv = newSViv((int) ntohl(iv));
5701			TRACEME(("network integer %d", (int) ntohl(iv)));
5702			#else
5703			sv = newSViv(iv);
5704			TRACEME(("network integer (as-is) %d", iv));
5705			#endif
5706	26	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5707	26	50	SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5708
5709			TRACEME(("ok (retrieve_netint at 0x%" UVxf ")", PTR2UV(sv)));
5710
5711	26		return sv;
5712			}
5713
5714			/*
5715			* retrieve_double
5716			*
5717			* Retrieve defined double.
5718			* Layout is SX_DOUBLE , whith SX_DOUBLE already read.
5719			*/
5720	16		static SV retrieve_double(pTHX_ stcxt_t cxt, const char *cname)
5721			{
5722			SV *sv;
5723			HV *stash;
5724			NV nv;
5725
5726			TRACEME(("retrieve_double (#%d)", (int)cxt->tagnum));
5727
5728	16	100	READ(&nv, sizeof(nv));
		50
		50
5729	16		sv = newSVnv(nv);
5730	16	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5731	16	50	SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5732
5733			TRACEME(("double %" NVff, nv));
5734			TRACEME(("ok (retrieve_double at 0x%" UVxf ")", PTR2UV(sv)));
5735
5736	16		return sv;
5737			}
5738
5739			/*
5740			* retrieve_byte
5741			*
5742			* Retrieve defined byte (small integer within the [-128, +127] range).
5743			* Layout is SX_BYTE , whith SX_BYTE already read.
5744			*/
5745	171		static SV retrieve_byte(pTHX_ stcxt_t cxt, const char *cname)
5746			{
5747			SV *sv;
5748			HV *stash;
5749			int siv;
5750			signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */
5751
5752			TRACEME(("retrieve_byte (#%d)", (int)cxt->tagnum));
5753
5754	171	100	GETMARK(siv);
		50
		50
5755			TRACEME(("small integer read as %d", (unsigned char) siv));
5756	171		tmp = (unsigned char) siv - 128;
5757	171		sv = newSViv(tmp);
5758	171	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5759	171	50	SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5760
5761			TRACEME(("byte %d", tmp));
5762			TRACEME(("ok (retrieve_byte at 0x%" UVxf ")", PTR2UV(sv)));
5763
5764	171		return sv;
5765			}
5766
5767			/*
5768			* retrieve_undef
5769			*
5770			* Return the undefined value.
5771			*/
5772	21		static SV retrieve_undef(pTHX_ stcxt_t cxt, const char *cname)
5773			{
5774			SV *sv;
5775			HV *stash;
5776
5777			TRACEME(("retrieve_undef"));
5778
5779	21		sv = newSV(0);
5780	21	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5781	21	50	SEEN_NN(sv, stash, 0);
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
5782
5783	21		return sv;
5784			}
5785
5786			/*
5787			* retrieve_sv_undef
5788			*
5789			* Return the immortal undefined value.
5790			*/
5791	5135		static SV retrieve_sv_undef(pTHX_ stcxt_t cxt, const char *cname)
5792			{
5793	5135		SV *sv = &PL_sv_undef;
5794			HV *stash;
5795
5796			TRACEME(("retrieve_sv_undef"));
5797
5798			/* Special case PL_sv_undef, as av_fetch uses it internally to mark
5799			deleted elements, and will return NULL (fetch failed) whenever it
5800			is fetched. */
5801	5135	100	if (cxt->where_is_undef == -1) {
5802	120		cxt->where_is_undef = (int)cxt->tagnum;
5803			}
5804	5135	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5805	5135	50	SEEN_NN(sv, stash, 1);
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5806	5135		return sv;
5807			}
5808
5809			/*
5810			* retrieve_sv_yes
5811			*
5812			* Return the immortal yes value.
5813			*/
5814	3		static SV retrieve_sv_yes(pTHX_ stcxt_t cxt, const char *cname)
5815			{
5816	3		SV *sv = &PL_sv_yes;
5817			HV *stash;
5818
5819			TRACEME(("retrieve_sv_yes"));
5820
5821	3	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5822	3	50	SEEN_NN(sv, stash, 1);
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5823	3		return sv;
5824			}
5825
5826			/*
5827			* retrieve_sv_no
5828			*
5829			* Return the immortal no value.
5830			*/
5831	3		static SV retrieve_sv_no(pTHX_ stcxt_t cxt, const char *cname)
5832			{
5833	3		SV *sv = &PL_sv_no;
5834			HV *stash;
5835
5836			TRACEME(("retrieve_sv_no"));
5837
5838	3	50	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5839	3	50	SEEN_NN(sv, stash, 1);
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5840	3		return sv;
5841			}
5842
5843			/*
5844			* retrieve_svundef_elem
5845			*
5846			* Return &PL_sv_placeholder, representing &PL_sv_undef in an array. This
5847			* is a bit of a hack, but we already use SX_SV_UNDEF to mean a nonexistent
5848			* element, for historical reasons.
5849			*/
5850	0		static SV retrieve_svundef_elem(pTHX_ stcxt_t cxt, const char *cname)
5851			{
5852			TRACEME(("retrieve_svundef_elem"));
5853
5854			/* SEEN reads the contents of its SV argument, which we are not
5855			supposed to do with &PL_sv_placeholder. */
5856	0	0	SEEN_NN(&PL_sv_undef, cname, 1);
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5857
5858	0		return &PL_sv_placeholder;
5859			}
5860
5861			/*
5862			* retrieve_array
5863			*
5864			* Retrieve a whole array.
5865			* Layout is SX_ARRAY followed by each item, in increasing index order.
5866			* Each item is stored as
5867			*
5868			* When we come here, SX_ARRAY has been read already.
5869			*/
5870	5662		static SV retrieve_array(pTHX_ stcxt_t cxt, const char *cname)
5871			{
5872			I32 len, i;
5873			AV *av;
5874			SV *sv;
5875			HV *stash;
5876	5662		bool seen_null = FALSE;
5877
5878			TRACEME(("retrieve_array (#%d)", (int)cxt->tagnum));
5879
5880			/*
5881			* Read length, and allocate array, then pre-extend it.
5882			*/
5883
5884	5662	100	RLEN(len);
		50
		100
		50
		100
5885			TRACEME(("size = %d", (int)len));
5886	5662		av = newAV();
5887	5662	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5888	5662	50	SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */
		100
		50
		100
		50
		50
		50
		0
		50
		50
		50
		50
		50
5889	5662	100	if (len)
5890	5629		av_extend(av, len);
5891			else
5892	33		return (SV ) av; / No data follow if array is empty */
5893
5894			/*
5895			* Now get each item in turn...
5896			*/
5897
5898	17960	100	for (i = 0; i < len; i++) {
5899			TRACEME(("(#%d) item", (int)i));
5900	12332		sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
5901	12331	50	if (!sv)
5902	0		return (SV *) 0;
5903	12331	100	if (sv == &PL_sv_undef) {
5904	2		seen_null = TRUE;
5905	2		continue;
5906			}
5907	12329	50	if (sv == &PL_sv_placeholder)
5908	0		sv = &PL_sv_undef;
5909	12329	50	if (av_store(av, i, sv) == 0)
5910	0		return (SV *) 0;
5911			}
5912	5628	100	if (seen_null) av_fill(av, len-1);
5913
5914			TRACEME(("ok (retrieve_array at 0x%" UVxf ")", PTR2UV(av)));
5915
5916	5661		return (SV *) av;
5917			}
5918
5919			/* internal method with len already read */
5920
5921	0		static SV get_larray(pTHX_ stcxt_t cxt, UV len, const char *cname)
5922			{
5923			UV i;
5924			AV *av;
5925			SV *sv;
5926			HV *stash;
5927	0		bool seen_null = FALSE;
5928
5929			TRACEME(("get_larray (#%d) %lu", (int)cxt->tagnum, (unsigned long)len));
5930
5931			/*
5932			* allocate array, then pre-extend it.
5933			*/
5934
5935	0		av = newAV();
5936	0	0	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5937	0	0	SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
5938			assert(len);
5939	0		av_extend(av, len);
5940
5941			/*
5942			* Now get each item in turn...
5943			*/
5944
5945	0	0	for (i = 0; i < len; i++) {
5946			TRACEME(("(#%d) item", (int)i));
5947	0		sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
5948	0	0	if (!sv)
5949	0		return (SV *) 0;
5950	0	0	if (sv == &PL_sv_undef) {
5951	0		seen_null = TRUE;
5952	0		continue;
5953			}
5954	0	0	if (sv == &PL_sv_placeholder)
5955	0		sv = &PL_sv_undef;
5956	0	0	if (av_store(av, i, sv) == 0)
5957	0		return (SV *) 0;
5958			}
5959	0	0	if (seen_null) av_fill(av, len-1);
5960
5961			TRACEME(("ok (get_larray at 0x%" UVxf ")", PTR2UV(av)));
5962
5963	0		return (SV *) av;
5964			}
5965
5966			#ifdef HAS_U64
5967			/*
5968			* get_lhash
5969			*
5970			* Retrieve a overlong hash table.
5971			* is already read. What follows is each key/value pair, in random order.
5972			* Keys are stored as , the section being omitted
5973			* if length is 0.
5974			* Values are stored as
5975			*
5976			*/
5977	0		static SV get_lhash(pTHX_ stcxt_t cxt, UV len, int hash_flags, const char *cname)
5978			{
5979			UV size;
5980			UV i;
5981			HV *hv;
5982			SV *sv;
5983			HV *stash;
5984
5985			TRACEME(("get_lhash (#%d)", (int)cxt->tagnum));
5986
5987			#ifdef HAS_RESTRICTED_HASHES
5988			PERL_UNUSED_ARG(hash_flags);
5989			#else
5990			if (hash_flags & SHV_RESTRICTED) {
5991			if (cxt->derestrict < 0)
5992			cxt->derestrict = (SvTRUE
5993			(get_sv("Storable::downgrade_restricted", GV_ADD))
5994			? 1 : 0);
5995			if (cxt->derestrict == 0)
5996			RESTRICTED_HASH_CROAK();
5997			}
5998			#endif
5999
6000			TRACEME(("size = %lu", (unsigned long)len));
6001	0		hv = newHV();
6002	0	0	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6003	0	0	SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
		0
6004	0	0	if (len == 0)
6005	0		return (SV ) hv; / No data follow if table empty */
6006			TRACEME(("split %lu", (unsigned long)len+1));
6007	0		hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */
6008
6009			/*
6010			* Now get each key/value pair in turn...
6011			*/
6012
6013	0	0	for (i = 0; i < len; i++) {
6014			/*
6015			* Get value first.
6016			*/
6017
6018			TRACEME(("(#%d) value", (int)i));
6019	0		sv = retrieve(aTHX_ cxt, 0);
6020	0	0	if (!sv)
6021	0		return (SV *) 0;
6022
6023			/*
6024			* Get key.
6025			* Since we're reading into kbuf, we must ensure we're not
6026			* recursing between the read and the hv_store() where it's used.
6027			* Hence the key comes after the value.
6028			*/
6029
6030	0	0	RLEN(size); /* Get key size */
		0
		0
		0
		0
6031	0	0	KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
		0
6032	0	0	if (size)
6033	0	0	READ(kbuf, size);
		0
		0
6034	0		kbuf[size] = '\0'; /* Mark string end, just in case */
6035			TRACEME(("(#%d) key '%s'", (int)i, kbuf));
6036
6037			/*
6038			* Enter key/value pair into hash table.
6039			*/
6040
6041	0	0	if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0)
6042	0		return (SV *) 0;
6043			}
6044
6045			TRACEME(("ok (get_lhash at 0x%" UVxf ")", PTR2UV(hv)));
6046	0		return (SV *) hv;
6047			}
6048			#endif
6049
6050			/*
6051			* retrieve_hash
6052			*
6053			* Retrieve a whole hash table.
6054			* Layout is SX_HASH followed by each key/value pair, in random order.
6055			* Keys are stored as , the section being omitted
6056			* if length is 0.
6057			* Values are stored as
6058			*
6059			* When we come here, SX_HASH has been read already.
6060			*/
6061	5442		static SV retrieve_hash(pTHX_ stcxt_t cxt, const char *cname)
6062			{
6063			I32 len;
6064			I32 size;
6065			I32 i;
6066			HV *hv;
6067			SV *sv;
6068			HV *stash;
6069
6070			TRACEME(("retrieve_hash (#%d)", (int)cxt->tagnum));
6071
6072			/*
6073			* Read length, allocate table.
6074			*/
6075
6076	5442	100	RLEN(len);
		50
		100
		50
		100
6077			TRACEME(("size = %d", (int)len));
6078	5442		hv = newHV();
6079	5442	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6080	5442	50	SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
6081	5442	100	if (len == 0)
6082	5016		return (SV ) hv; / No data follow if table empty */
6083			TRACEME(("split %d", (int)len+1));
6084	426		hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */
6085
6086			/*
6087			* Now get each key/value pair in turn...
6088			*/
6089
6090	2348	100	for (i = 0; i < len; i++) {
6091			/*
6092			* Get value first.
6093			*/
6094
6095			TRACEME(("(#%d) value", (int)i));
6096	1923		sv = retrieve(aTHX_ cxt, 0);
6097	1922	50	if (!sv)
6098	0		return (SV *) 0;
6099
6100			/*
6101			* Get key.
6102			* Since we're reading into kbuf, we must ensure we're not
6103			* recursing between the read and the hv_store() where it's used.
6104			* Hence the key comes after the value.
6105			*/
6106
6107	1922	100	RLEN(size); /* Get key size */
		50
		100
		50
		100
6108	1922	50	KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
		0
6109	1922	100	if (size)
6110	1918	100	READ(kbuf, size);
		50
		50
6111	1922		kbuf[size] = '\0'; /* Mark string end, just in case */
6112			TRACEME(("(#%d) key '%s'", (int)i, kbuf));
6113
6114			/*
6115			* Enter key/value pair into hash table.
6116			*/
6117
6118	1922	50	if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0)
6119	0		return (SV *) 0;
6120			}
6121
6122			TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv)));
6123
6124	5441		return (SV *) hv;
6125			}
6126
6127			/*
6128			* retrieve_hash
6129			*
6130			* Retrieve a whole hash table.
6131			* Layout is SX_HASH followed by each key/value pair, in random order.
6132			* Keys are stored as , the section being omitted
6133			* if length is 0.
6134			* Values are stored as
6135			*
6136			* When we come here, SX_HASH has been read already.
6137			*/
6138	244		static SV retrieve_flag_hash(pTHX_ stcxt_t cxt, const char *cname)
6139			{
6140			dVAR;
6141			I32 len;
6142			I32 size;
6143			I32 i;
6144			HV *hv;
6145			SV *sv;
6146			HV *stash;
6147			int hash_flags;
6148
6149	244	100	GETMARK(hash_flags);
		100
		100
6150			TRACEME(("retrieve_flag_hash (#%d)", (int)cxt->tagnum));
6151			/*
6152			* Read length, allocate table.
6153			*/
6154
6155			#ifndef HAS_RESTRICTED_HASHES
6156			if (hash_flags & SHV_RESTRICTED) {
6157			if (cxt->derestrict < 0)
6158			cxt->derestrict = (SvTRUE
6159			(get_sv("Storable::downgrade_restricted", GV_ADD))
6160			? 1 : 0);
6161			if (cxt->derestrict == 0)
6162			RESTRICTED_HASH_CROAK();
6163			}
6164			#endif
6165
6166	240	100	RLEN(len);
		100
		100
		100
		100
6167			TRACEME(("size = %d, flags = %d", (int)len, hash_flags));
6168	224		hv = newHV();
6169	224	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6170	224	50	SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
6171	224	50	if (len == 0)
6172	0		return (SV ) hv; / No data follow if table empty */
6173			TRACEME(("split %d", (int)len+1));
6174	224		hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */
6175
6176			/*
6177			* Now get each key/value pair in turn...
6178			*/
6179
6180	5457	100	for (i = 0; i < len; i++) {
6181			int flags;
6182	5298		int store_flags = 0;
6183			/*
6184			* Get value first.
6185			*/
6186
6187			TRACEME(("(#%d) value", (int)i));
6188	5298		sv = retrieve(aTHX_ cxt, 0);
6189	5297	100	if (!sv)
6190	28		return (SV *) 0;
6191
6192	5269	100	GETMARK(flags);
		100
		100
6193			#ifdef HAS_RESTRICTED_HASHES
6194	5265	100	if ((hash_flags & SHV_RESTRICTED) && (flags & SHV_K_LOCKED))
		100
6195	5150		SvREADONLY_on(sv);
6196			#endif
6197
6198	5265	50	if (flags & SHV_K_ISSV) {
6199			/* XXX you can't set a placeholder with an SV key.
6200			Then again, you can't get an SV key.
6201			Without messing around beyond what the API is supposed to do.
6202			*/
6203			SV *keysv;
6204			TRACEME(("(#%d) keysv, flags=%d", (int)i, flags));
6205	0		keysv = retrieve(aTHX_ cxt, 0);
6206	0	0	if (!keysv)
6207	0		return (SV *) 0;
6208
6209	0	0	if (!hv_store_ent(hv, keysv, sv, 0))
6210	0		return (SV *) 0;
6211			} else {
6212			/*
6213			* Get key.
6214			* Since we're reading into kbuf, we must ensure we're not
6215			* recursing between the read and the hv_store() where it's used.
6216			* Hence the key comes after the value.
6217			*/
6218
6219	5265	100	if (flags & SHV_K_PLACEHOLDER) {
6220	5130		SvREFCNT_dec (sv);
6221	5130		sv = &PL_sv_placeholder;
6222	5130		store_flags \|= HVhek_PLACEHOLD;
6223			}
6224	5265	100	if (flags & SHV_K_UTF8) {
6225			#ifdef HAS_UTF8_HASHES
6226	20		store_flags \|= HVhek_UTF8;
6227			#else
6228			if (cxt->use_bytes < 0)
6229			cxt->use_bytes
6230			= (SvTRUE(get_sv("Storable::drop_utf8", GV_ADD))
6231			? 1 : 0);
6232			if (cxt->use_bytes == 0)
6233			UTF8_CROAK();
6234			#endif
6235			}
6236			#ifdef HAS_UTF8_HASHES
6237	5265	100	if (flags & SHV_K_WASUTF8)
6238	12		store_flags \|= HVhek_WASUTF8;
6239			#endif
6240
6241	5265	100	RLEN(size); /* Get key size */
		100
		100
		100
		100
6242	5249	50	KBUFCHK((STRLEN)size);/* Grow hash key read pool if needed */
		0
6243	5249	50	if (size)
6244	5249	100	READ(kbuf, size);
		100
		100
6245	5233		kbuf[size] = '\0'; /* Mark string end, just in case */
6246			TRACEME(("(#%d) key '%s' flags %X store_flags %X", (int)i, kbuf,
6247			flags, store_flags));
6248
6249			/*
6250			* Enter key/value pair into hash table.
6251			*/
6252
6253			#ifdef HAS_RESTRICTED_HASHES
6254	5233	50	if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0)
6255	0		return (SV *) 0;
6256			#else
6257			if (!(store_flags & HVhek_PLACEHOLD))
6258			if (hv_store(hv, kbuf, size, sv, 0) == 0)
6259			return (SV *) 0;
6260			#endif
6261			}
6262			}
6263			#ifdef HAS_RESTRICTED_HASHES
6264	159	100	if (hash_flags & SHV_RESTRICTED)
6265	129		SvREADONLY_on(hv);
6266			#endif
6267
6268			TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv)));
6269
6270	243		return (SV *) hv;
6271			}
6272
6273			/*
6274			* retrieve_code
6275			*
6276			* Return a code reference.
6277			*/
6278	63		static SV retrieve_code(pTHX_ stcxt_t cxt, const char *cname)
6279			{
6280			#if PERL_VERSION < 6
6281			CROAK(("retrieve_code does not work with perl 5.005 or less\n"));
6282			#else
6283	63		dSP;
6284			I32 type, count;
6285			IV tagnum;
6286			SV *cv;
6287			SV sv, text, sub, errsv;
6288			HV *stash;
6289
6290			TRACEME(("retrieve_code (#%d)", (int)cxt->tagnum));
6291
6292			/*
6293			* Insert dummy SV in the aseen array so that we don't screw
6294			* up the tag numbers. We would just make the internal
6295			* scalar an untagged item in the stream, but
6296			* retrieve_scalar() calls SEEN(). So we just increase the
6297			* tag number.
6298			*/
6299	63		tagnum = cxt->tagnum;
6300	63		sv = newSViv(0);
6301	63	100	stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6302	63	50	SEEN_NN(sv, stash, 0);
		100
		50
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
6303
6304			/*
6305			* Retrieve the source of the code reference
6306			* as a small or large scalar
6307			*/
6308
6309	63	100	GETMARK(type);
		50
		50
6310	63		switch (type) {
6311			case SX_SCALAR:
6312	53		text = retrieve_scalar(aTHX_ cxt, cname);
6313	53		break;
6314			case SX_LSCALAR:
6315	3		text = retrieve_lscalar(aTHX_ cxt, cname);
6316	3		break;
6317			case SX_UTF8STR:
6318	2		text = retrieve_utf8str(aTHX_ cxt, cname);
6319	2		break;
6320			case SX_LUTF8STR:
6321	5		text = retrieve_lutf8str(aTHX_ cxt, cname);
6322	5		break;
6323			default:
6324	0		CROAK(("Unexpected type %d in retrieve_code\n", (int)type));
6325			}
6326
6327	63	100	if (!text) {
6328	1		CROAK(("Unable to retrieve code\n"));
6329			}
6330
6331			/*
6332			* prepend "sub " to the source
6333			*/
6334
6335	62		sub = newSVpvs("sub ");
6336	62	100	if (SvUTF8(text))
6337	7		SvUTF8_on(sub);
6338	62	50	sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
6339	62		SvREFCNT_dec(text);
6340
6341			/*
6342			* evaluate the source to a code reference and use the CV value
6343			*/
6344
6345	62	100	if (cxt->eval == NULL) {
6346	37		cxt->eval = get_sv("Storable::Eval", GV_ADD);
6347	37		SvREFCNT_inc(cxt->eval);
6348			}
6349	62	50	if (!SvTRUE(cxt->eval)) {
		50
		0
		50
		0
		0
		50
		0
		0
		0
		0
		0
		100
		50
		100
		50
		0
		100
		50
6350	7	50	if (cxt->forgive_me == 0 \|\|
		50
6351	7	100	(cxt->forgive_me < 0 &&
6352	38	50	!(cxt->forgive_me = SvTRUE
		50
		0
		0
		0
		0
		0
		50
		50
		0
		0
		50
		0
6353	38		(get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
6354			) {
6355	2		CROAK(("Can't eval, please set $Storable::Eval to a true value"));
6356			} else {
6357	5		sv = newSVsv(sub);
6358			/* fix up the dummy entry... */
6359	5		av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
6360	5		return sv;
6361			}
6362			}
6363
6364	55		ENTER;
6365	55		SAVETMPS;
6366
6367	55		errsv = get_sv("@", GV_ADD);
6368	55		SvPVCLEAR(errsv); /* clear $@ */
6369	55	100	if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) {
		50
6370	11	50	PUSHMARK(sp);
6371	11	50	XPUSHs(sv_2mortal(newSVsv(sub)));
6372	11		PUTBACK;
6373	11		count = call_sv(cxt->eval, G_SCALAR);
6374	11	50	if (count != 1)
6375	0		CROAK(("Unexpected return value from $Storable::Eval callback\n"));
6376			} else {
6377	44		eval_sv(sub, G_SCALAR);
6378			}
6379	55		SPAGAIN;
6380	55		cv = POPs;
6381	55		PUTBACK;
6382
6383	55	50	if (SvTRUE(errsv)) {
		50
		50
		0
		0
		50
		50
		100
		50
		0
		0
		0
		0
		0
		0
		100
6384	2	50	CROAK(("code %s caused an error: %s",
		50
6385			SvPV_nolen(sub), SvPV_nolen(errsv)));
6386			}
6387
6388	53	50	if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
		50
		50
6389	53		sv = SvRV(cv);
6390			} else {
6391	0	0	CROAK(("code %s did not evaluate to a subroutine reference\n",
6392			SvPV_nolen(sub)));
6393			}
6394
6395	53		SvREFCNT_inc(sv); /* XXX seems to be necessary */
6396	53		SvREFCNT_dec(sub);
6397
6398	53	50	FREETMPS;
6399	53		LEAVE;
6400			/* fix up the dummy entry... */
6401	53		av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
6402
6403	53		return sv;
6404			#endif
6405			}
6406
6407			/*
6408			* old_retrieve_array
6409			*
6410			* Retrieve a whole array in pre-0.6 binary format.
6411			*
6412			* Layout is SX_ARRAY followed by each item, in increasing index order.
6413			* Each item is stored as SX_ITEM
6414			*
6415			* When we come here, SX_ARRAY has been read already.
6416			*/
6417	1		static SV old_retrieve_array(pTHX_ stcxt_t cxt, const char *cname)
6418			{
6419			I32 len;
6420			I32 i;
6421			AV *av;
6422			SV *sv;
6423			int c;
6424
6425			PERL_UNUSED_ARG(cname);
6426			TRACEME(("old_retrieve_array (#%d)", (int)cxt->tagnum));
6427
6428			/*
6429			* Read length, and allocate array, then pre-extend it.
6430			*/
6431
6432	1	50	RLEN(len);
		0
		0
		50
		50
6433			TRACEME(("size = %d", (int)len));
6434	1		av = newAV();
6435	1	50	SEEN0_NN(av, 0); /* Will return if array not allocated nicely */
6436	1	50	if (len)
6437	1		av_extend(av, len);
6438			else
6439	0		return (SV ) av; / No data follow if array is empty */
6440
6441			/*
6442			* Now get each item in turn...
6443			*/
6444
6445	1	50	for (i = 0; i < len; i++) {
6446	1	50	GETMARK(c);
		0
		50
6447	1	50	if (c == SX_IT_UNDEF) {
6448			TRACEME(("(#%d) undef item", (int)i));
6449	0		continue; /* av_extend() already filled us with undef */
6450			}
6451	1	50	if (c != SX_ITEM)
6452	1		(void) retrieve_other(aTHX_ cxt, 0);/* Will croak out */
6453			TRACEME(("(#%d) item", (int)i));
6454	0		sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
6455	0	0	if (!sv)
6456	0		return (SV *) 0;
6457	0	0	if (av_store(av, i, sv) == 0)
6458	0		return (SV *) 0;
6459			}
6460
6461			TRACEME(("ok (old_retrieve_array at 0x%" UVxf ")", PTR2UV(av)));
6462
6463	0		return (SV *) av;
6464			}
6465
6466			/*
6467			* old_retrieve_hash
6468			*
6469			* Retrieve a whole hash table in pre-0.6 binary format.
6470			*
6471			* Layout is SX_HASH followed by each key/value pair, in random order.
6472			* Keys are stored as SX_KEY , the section being omitted
6473			* if length is 0.
6474			* Values are stored as SX_VALUE
6475			*
6476			* When we come here, SX_HASH has been read already.
6477			*/
6478	1		static SV old_retrieve_hash(pTHX_ stcxt_t cxt, const char *cname)
6479			{
6480			I32 len;
6481			I32 size;
6482			I32 i;
6483			HV *hv;
6484	1		SV sv = (SV ) 0;
6485			int c;
6486	1		SV sv_h_undef = (SV ) 0; /* hv_store() bug */
6487
6488			PERL_UNUSED_ARG(cname);
6489			TRACEME(("old_retrieve_hash (#%d)", (int)cxt->tagnum));
6490
6491			/*
6492			* Read length, allocate table.
6493			*/
6494
6495	1	50	RLEN(len);
		0
		0
		50
		50
6496			TRACEME(("size = %d", (int)len));
6497	1		hv = newHV();
6498	1	50	SEEN0_NN(hv, 0); /* Will return if table not allocated properly */
6499	1	50	if (len == 0)
6500	0		return (SV ) hv; / No data follow if table empty */
6501			TRACEME(("split %d", (int)len+1));
6502	1		hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */
6503
6504			/*
6505			* Now get each key/value pair in turn...
6506			*/
6507
6508	1	50	for (i = 0; i < len; i++) {
6509			/*
6510			* Get value first.
6511			*/
6512
6513	1	50	GETMARK(c);
		0
		50
6514	1	50	if (c == SX_VL_UNDEF) {
6515			TRACEME(("(#%d) undef value", (int)i));
6516			/*
6517			* Due to a bug in hv_store(), it's not possible to pass
6518			* &PL_sv_undef to hv_store() as a value, otherwise the
6519			* associated key will not be creatable any more. -- RAM, 14/01/97
6520			*/
6521	0	0	if (!sv_h_undef)
6522	0		sv_h_undef = newSVsv(&PL_sv_undef);
6523	0		sv = SvREFCNT_inc(sv_h_undef);
6524	1	50	} else if (c == SX_VALUE) {
6525			TRACEME(("(#%d) value", (int)i));
6526	0		sv = retrieve(aTHX_ cxt, 0);
6527	0	0	if (!sv)
6528	0		return (SV *) 0;
6529			} else
6530	1		(void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
6531
6532			/*
6533			* Get key.
6534			* Since we're reading into kbuf, we must ensure we're not
6535			* recursing between the read and the hv_store() where it's used.
6536			* Hence the key comes after the value.
6537			*/
6538
6539	0	0	GETMARK(c);
		0
		0
6540	0	0	if (c != SX_KEY)
6541	0		(void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
6542	0	0	RLEN(size); /* Get key size */
		0
		0
		0
		0
6543	0	0	KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
		0
6544	0	0	if (size)
6545	0	0	READ(kbuf, size);
		0
		0
6546	0		kbuf[size] = '\0'; /* Mark string end, just in case */
6547			TRACEME(("(#%d) key '%s'", (int)i, kbuf));
6548
6549			/*
6550			* Enter key/value pair into hash table.
6551			*/
6552
6553	0	0	if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0)
6554	0		return (SV *) 0;
6555			}
6556
6557			TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv)));
6558
6559	0		return (SV *) hv;
6560			}
6561
6562			/***
6563			*** Retrieval engine.
6564			***/
6565
6566			/*
6567			* magic_check
6568			*
6569			* Make sure the stored data we're trying to retrieve has been produced
6570			* on an ILP compatible system with the same byteorder. It croaks out in
6571			* case an error is detected. [ILP = integer-long-pointer sizes]
6572			* Returns null if error is detected, &PL_sv_undef otherwise.
6573			*
6574			* Note that there's no byte ordering info emitted when network order was
6575			* used at store time.
6576			*/
6577	712		static SV magic_check(pTHX_ stcxt_t cxt)
6578			{
6579			/* The worst case for a malicious header would be old magic (which is
6580			longer), major, minor, byteorder length byte of 255, 255 bytes of
6581			garbage, sizeof int, long, pointer, NV.
6582			So the worse of that we can read is 255 bytes of garbage plus 4.
6583			Err, I am assuming 8 bit bytes here. Please file a bug report if you're
6584			compiling perl on a system with chars that are larger than 8 bits.
6585			(Even Crays aren't that perverse).
6586			*/
6587			unsigned char buf[4 + 255];
6588			unsigned char *current;
6589			int c;
6590			int length;
6591			int use_network_order;
6592			int use_NV_size;
6593	712		int old_magic = 0;
6594			int version_major;
6595	712		int version_minor = 0;
6596
6597			TRACEME(("magic_check"));
6598
6599			/*
6600			* The "magic number" is only for files, not when freezing in memory.
6601			*/
6602
6603	712	100	if (cxt->fio) {
6604			/* This includes the '\0' at the end. I want to read the extra byte,
6605			which is usually going to be the major version number. */
6606	195		STRLEN len = sizeof(magicstr);
6607			STRLEN old_len;
6608
6609	195	50	READ(buf, (SSize_t)(len)); /* Not null-terminated */
		0
		100
6610
6611			/* Point at the byte after the byte we read. */
6612	184		current = buf + --len; /* Do the -- outside of macros. */
6613
6614	184	100	if (memNE(buf, magicstr, len)) {
6615			/*
6616			* Try to read more bytes to check for the old magic number, which
6617			* was longer.
6618			*/
6619
6620			TRACEME(("trying for old magic number"));
6621
6622	2		old_len = sizeof(old_magicstr) - 1;
6623	2	50	READ(current + 1, (SSize_t)(old_len - len));
		0
		50
6624
6625	2	50	if (memNE(buf, old_magicstr, old_len))
6626	2		CROAK(("File is not a perl storable"));
6627	0		old_magic++;
6628	0		current = buf + old_len;
6629			}
6630	182		use_network_order = *current;
6631			} else {
6632	517	50	GETMARK(use_network_order);
		100
		0
6633			}
6634
6635			/*
6636			* Starting with 0.6, the "use_network_order" byte flag is also used to
6637			* indicate the version number of the binary, and therefore governs the
6638			* setting of sv_retrieve_vtbl. See magic_write().
6639			*/
6640	697	50	if (old_magic && use_network_order > 1) {
		0
6641			/* 0.1 dump - use_network_order is really byte order length */
6642	0		version_major = -1;
6643			}
6644			else {
6645	697		version_major = use_network_order >> 1;
6646			}
6647	697	100	cxt->retrieve_vtbl = (SV()(pTHX_ stcxt_t cxt, const char *cname)) (version_major > 0 ? sv_retrieve : sv_old_retrieve);
6648
6649			TRACEME(("magic_check: netorder = 0x%x", use_network_order));
6650
6651
6652			/*
6653			* Starting with 0.7 (binary major 2), a full byte is dedicated to the
6654			* minor version of the protocol. See magic_write().
6655			*/
6656
6657	697	100	if (version_major > 1)
6658	694	100	GETMARK(version_minor);
		100
		100
6659
6660	693		cxt->ver_major = version_major;
6661	693		cxt->ver_minor = version_minor;
6662
6663			TRACEME(("binary image version is %d.%d", version_major, version_minor));
6664
6665			/*
6666			* Inter-operability sanity check: we can't retrieve something stored
6667			* using a format more recent than ours, because we have no way to
6668			* know what has changed, and letting retrieval go would mean a probable
6669			* failure reporting a "corrupted" storable file.
6670			*/
6671
6672	693	100	if (
6673	683	100	version_major > STORABLE_BIN_MAJOR \|\|
6674	680	100	(version_major == STORABLE_BIN_MAJOR &&
6675			version_minor > STORABLE_BIN_MINOR)
6676			) {
6677	26		int croak_now = 1;
6678			TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR,
6679			STORABLE_BIN_MINOR));
6680
6681	26	100	if (version_major == STORABLE_BIN_MAJOR) {
6682			TRACEME(("cxt->accept_future_minor is %d",
6683			cxt->accept_future_minor));
6684	16	50	if (cxt->accept_future_minor < 0)
6685			cxt->accept_future_minor
6686	112	0	= (SvTRUE(get_sv("Storable::accept_future_minor",
		0
		0
		0
		0
		0
		0
		50
		100
		50
		0
		100
		0
6687			GV_ADD))
6688	96		? 1 : 0);
6689	16	100	if (cxt->accept_future_minor == 1)
6690	8		croak_now = 0; /* Don't croak yet. */
6691			}
6692	26	100	if (croak_now) {
6693	18		CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)",
6694			version_major, version_minor,
6695			STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
6696			}
6697			}
6698
6699			/*
6700			* If they stored using network order, there's no byte ordering
6701			* information to check.
6702			*/
6703
6704	675	100	if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
6705	167		return &PL_sv_undef; /* No byte ordering info */
6706
6707			/* In C truth is 1, falsehood is 0. Very convenient. */
6708	508	50	use_NV_size = version_major >= 2 && version_minor >= 2;
		50
6709
6710	508	50	if (version_major >= 0) {
6711	508	100	GETMARK(c);
		100
		100
6712			}
6713			else {
6714	0		c = use_network_order;
6715			}
6716	506		length = c + 3 + use_NV_size;
6717	506	100	READ(buf, length); /* Not null-terminated */
		100
		100
6718
6719			TRACEME(("byte order '%.*s' %d", c, buf, c));
6720
6721			#ifdef USE_56_INTERWORK_KLUDGE
6722			/* No point in caching this in the context as we only need it once per
6723			retrieve, and we need to recheck it each read. */
6724			if (SvTRUE(get_sv("Storable::interwork_56_64bit", GV_ADD))) {
6725			if ((c != (sizeof (byteorderstr_56) - 1))
6726			\|\| memNE(buf, byteorderstr_56, c))
6727			CROAK(("Byte order is not compatible"));
6728			} else
6729			#endif
6730			{
6731	482	50	if ((c != (sizeof (byteorderstr) - 1))
6732	482	100	\|\| memNE(buf, byteorderstr, c))
6733	2		CROAK(("Byte order is not compatible"));
6734			}
6735
6736	480		current = buf + c;
6737
6738			/* sizeof(int) */
6739	480	100	if ((int) *current++ != sizeof(int))
6740	2		CROAK(("Integer size is not compatible"));
6741
6742			/* sizeof(long) */
6743	478	100	if ((int) *current++ != sizeof(long))
6744	2		CROAK(("Long integer size is not compatible"));
6745
6746			/* sizeof(char ) /
6747	476	100	if ((int) current != sizeof(char ))
6748	2		CROAK(("Pointer size is not compatible"));
6749
6750	474	50	if (use_NV_size) {
6751			/* sizeof(NV) */
6752	474	100	if ((int) *++current != sizeof(NV))
6753	2		CROAK(("Double size is not compatible"));
6754			}
6755
6756	682		return &PL_sv_undef; /* OK */
6757			}
6758
6759			/*
6760			* retrieve
6761			*
6762			* Recursively retrieve objects from the specified file and return their
6763			* root SV (which may be an AV or an HV for what we care).
6764			* Returns null if there is a problem.
6765			*/
6766	31578		static SV retrieve(pTHX_ stcxt_t cxt, const char *cname)
6767			{
6768			int type;
6769			SV **svh;
6770			SV *sv;
6771
6772			TRACEME(("retrieve"));
6773
6774			/*
6775			* Grab address tag which identifies the object if we are retrieving
6776			* an older format. Since the new binary format counts objects and no
6777			* longer explicitly tags them, we must keep track of the correspondence
6778			* ourselves.
6779			*
6780			* The following section will disappear one day when the old format is
6781			* no longer supported, hence the final "goto" in the "if" block.
6782			*/
6783
6784	31578	100	if (cxt->hseen) { /* Retrieving old binary */
6785			stag_t tag;
6786	2	50	if (cxt->netorder) {
6787			I32 nettag;
6788	2	50	READ(&nettag, sizeof(I32)); /* Ordered sequence of I32 */
		0
		50
6789	2		tag = (stag_t) nettag;
6790			} else
6791	0	0	READ(&tag, sizeof(stag_t)); /* Original address of the SV */
		0
		0
6792
6793	2	50	GETMARK(type);
		0
		50
6794	2	50	if (type == SX_OBJECT) {
6795			I32 tagn;
6796	0		svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
6797	0	0	if (!svh)
6798	0		CROAK(("Old tag 0x%" UVxf " should have been mapped already",
6799			(UV) tag));
6800	0	0	tagn = SvIV(svh); / Mapped tag number computed earlier below */
6801
6802			/*
6803			* The following code is common with the SX_OBJECT case below.
6804			*/
6805
6806	0		svh = av_fetch(cxt->aseen, tagn, FALSE);
6807	0	0	if (!svh)
6808	0		CROAK(("Object #%" IVdf " should have been retrieved already",
6809			(IV) tagn));
6810	0		sv = *svh;
6811			TRACEME(("has retrieved #%d at 0x%" UVxf, (int)tagn, PTR2UV(sv)));
6812	0		SvREFCNT_inc(sv); /* One more reference to this same sv */
6813	0		return sv; /* The SV pointer where object was retrieved */
6814			}
6815
6816			/*
6817			* Map new object, but don't increase tagnum. This will be done
6818			* by each of the retrieve_* functions when they call SEEN().
6819			*
6820			* The mapping associates the "tag" initially present with a unique
6821			* tag number. See test for SX_OBJECT above to see how this is perused.
6822			*/
6823
6824	2	50	if (!hv_store(cxt->hseen, (char *) &tag, sizeof(tag),
6825			newSViv(cxt->tagnum), 0))
6826	0		return (SV *) 0;
6827
6828	2		goto first_time;
6829			}
6830
6831			/*
6832			* Regular post-0.6 binary format.
6833			*/
6834
6835	31576	100	GETMARK(type);
		100
		100
6836
6837			TRACEME(("retrieve type = %d", type));
6838
6839			/*
6840			* Are we dealing with an object we should have already retrieved?
6841			*/
6842
6843	31568	100	if (type == SX_OBJECT) {
6844			I32 tag;
6845	101	100	READ_I32(tag);
		50
		100
		50
6846	101		tag = ntohl(tag);
6847	101		svh = av_fetch(cxt->aseen, tag, FALSE);
6848	101	50	if (!svh)
6849	0		CROAK(("Object #%" IVdf " should have been retrieved already",
6850			(IV) tag));
6851	101		sv = *svh;
6852			TRACEME(("had retrieved #%d at 0x%" UVxf, (int)tag, PTR2UV(sv)));
6853	101		SvREFCNT_inc(sv); /* One more reference to this same sv */
6854	101		return sv; /* The SV pointer where object was retrieved */
6855	31467	100	} else if (type >= SX_ERROR && cxt->ver_minor > STORABLE_BIN_MINOR) {
		100
6856	4	50	if (cxt->accept_future_minor < 0)
6857			cxt->accept_future_minor
6858	28	0	= (SvTRUE(get_sv("Storable::accept_future_minor",
		0
		0
		0
		0
		0
		0
		50
		50
		0
		0
		50
		0
6859			GV_ADD))
6860	24		? 1 : 0);
6861	4	50	if (cxt->accept_future_minor == 1) {
6862	4		CROAK(("Storable binary image v%d.%d contains data of type %d. "
6863			"This Storable is v%d.%d and can only handle data types up to %d",
6864			cxt->ver_major, cxt->ver_minor, type,
6865			STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_ERROR - 1));
6866			}
6867			}
6868
6869			first_time: /* Will disappear when support for old format is dropped */
6870
6871			/*
6872			* Okay, first time through for this one.
6873			*/
6874
6875	31465	100	sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname);
6876	31435	100	if (!sv)
6877	109		return (SV ) 0; / Failed */
6878
6879			/*
6880			* Old binary formats (pre-0.7).
6881			*
6882			* Final notifications, ended by SX_STORED may now follow.
6883			* Currently, the only pertinent notification to apply on the
6884			* freshly retrieved object is either:
6885			* SX_CLASS for short classnames.
6886			* SX_LG_CLASS for larger one (rare!).
6887			* Class name is then read into the key buffer pool used by
6888			* hash table key retrieval.
6889			*/
6890
6891	31326	100	if (cxt->ver_major < 2) {
6892	45	50	while ((type = GETCHAR()) != SX_STORED) {
		50
		100
6893			I32 len;
6894			HV* stash;
6895	7		switch (type) {
6896			case SX_CLASS:
6897	7	50	GETMARK(len); /* Length coded on a single char */
		50
		0
6898	7		break;
6899			case SX_LG_CLASS: /* Length coded on a regular integer */
6900	0	0	RLEN(len);
		0
		0
		0
		0
6901	0		break;
6902			case EOF:
6903			default:
6904	0		return (SV ) 0; / Failed */
6905			}
6906	7	50	KBUFCHK((STRLEN)len); /* Grow buffer as necessary */
		0
6907	7	50	if (len)
6908	7	50	READ(kbuf, len);
		50
		0
6909	7		kbuf[len] = '\0'; /* Mark string end */
6910	7		stash = gv_stashpvn(kbuf, len, GV_ADD);
6911	7	50	BLESS(sv, stash);
		50
		0
		0
		0
		0
		0
		0
		0
		0
		0
6912			}
6913			}
6914
6915			TRACEME(("ok (retrieved 0x%" UVxf ", refcnt=%d, %s)", PTR2UV(sv),
6916			(int)SvREFCNT(sv) - 1, sv_reftype(sv, FALSE)));
6917
6918	31326		return sv; /* Ok */
6919			}
6920
6921			/*
6922			* do_retrieve
6923			*
6924			* Retrieve data held in file and return the root object.
6925			* Common routine for pretrieve and mretrieve.
6926			*/
6927	713		static SV *do_retrieve(
6928			pTHX_
6929			PerlIO *f,
6930			SV *in,
6931			int optype,
6932			int flags)
6933			{
6934	713		dSTCXT;
6935			SV *sv;
6936			int is_tainted; /* Is input source tainted? */
6937	713		int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */
6938
6939			TRACEME(("do_retrieve (optype = 0x%x)", optype));
6940			TRACEME(("do_retrieve (flags = 0x%x)", flags));
6941
6942	713		optype \|= ST_RETRIEVE;
6943	713		cxt->flags = flags;
6944
6945			/*
6946			* Sanity assertions for retrieve dispatch tables.
6947			*/
6948
6949			ASSERT(sizeof(sv_old_retrieve) == sizeof(sv_retrieve),
6950			("old and new retrieve dispatch table have same size"));
6951			ASSERT(sv_old_retrieve[(int)SX_ERROR] == retrieve_other,
6952			("SX_ERROR entry correctly initialized in old dispatch table"));
6953			ASSERT(sv_retrieve[(int)SX_ERROR] == retrieve_other,
6954			("SX_ERROR entry correctly initialized in new dispatch table"));
6955
6956			/*
6957			* Workaround for CROAK leak: if they enter with a "dirty" context,
6958			* free up memory for them now.
6959			*/
6960
6961			assert(cxt);
6962	713	100	if (cxt->s_dirty)
6963	89		clean_context(aTHX_ cxt);
6964
6965			/*
6966			* Now that STORABLE_xxx hooks exist, it is possible that they try to
6967			* re-enter retrieve() via the hooks.
6968			*/
6969
6970	713	100	if (cxt->entry) {
6971	39		cxt = allocate_context(aTHX_ cxt);
6972	39		cxt->flags = flags;
6973			}
6974
6975	713		cxt->entry++;
6976
6977			ASSERT(cxt->entry == 1, ("starting new recursion"));
6978			ASSERT(!cxt->s_dirty, ("clean context"));
6979
6980			/*
6981			* Prepare context.
6982			*
6983			* Data is loaded into the memory buffer when f is NULL, unless 'in' is
6984			* also NULL, in which case we're expecting the data to already lie
6985			* in the buffer (dclone case).
6986			*/
6987
6988	713	100	KBUFINIT(); /* Allocate hash key reading pool once */
6989
6990	713	100	if (!f && in) {
		100
6991			#ifdef SvUTF8_on
6992	358	100	if (SvUTF8(in)) {
6993			STRLEN length;
6994	2	50	const char *orig = SvPV(in, length);
6995			char *asbytes;
6996			/* This is quite deliberate. I want the UTF8 routines
6997			to encounter the '\0' which perl adds at the end
6998			of all scalars, so that any new string also has
6999			this.
7000			*/
7001	2		STRLEN klen_tmp = length + 1;
7002	2		bool is_utf8 = TRUE;
7003
7004			/* Just casting the &klen to (STRLEN) won't work
7005			well if STRLEN and I32 are of different widths.
7006			--jhi */
7007	2		asbytes = (char)bytes_from_utf8((U8)orig,
7008			&klen_tmp,
7009			&is_utf8);
7010	2	100	if (is_utf8) {
7011	1		CROAK(("Frozen string corrupt - contains characters outside 0-255"));
7012			}
7013	1	50	if (asbytes != orig) {
7014			/* String has been converted.
7015			There is no need to keep any reference to
7016			the old string. */
7017	1		in = sv_newmortal();
7018			/* We donate the SV the malloc()ed string
7019			bytes_from_utf8 returned us. */
7020	1	50	SvUPGRADE(in, SVt_PV);
7021	1		SvPOK_on(in);
7022	1		SvPV_set(in, asbytes);
7023	1		SvLEN_set(in, klen_tmp);
7024	1		SvCUR_set(in, klen_tmp - 1);
7025			}
7026			}
7027			#endif
7028	357	50	MBUF_SAVE_AND_LOAD(in);
		50
7029			}
7030
7031			/*
7032			* Magic number verifications.
7033			*
7034			* This needs to be done before calling init_retrieve_context()
7035			* since the format indication in the file are necessary to conduct
7036			* some of the initializations.
7037			*/
7038
7039	712		cxt->fio = f; /* Where I/O are performed */
7040
7041	712	100	if (!magic_check(aTHX_ cxt))
7042	43	100	CROAK(("Magic number checking on storable %s failed",
7043			cxt->fio ? "file" : "string"));
7044
7045			TRACEME(("data stored in %s format",
7046			cxt->netorder ? "net order" : "native"));
7047
7048			/*
7049			* Check whether input source is tainted, so that we don't wrongly
7050			* taint perfectly good values...
7051			*
7052			* We assume file input is always tainted. If both 'f' and 'in' are
7053			* NULL, then we come from dclone, and tainted is already filled in
7054			* the context. That's a kludge, but the whole dclone() thing is
7055			* already quite a kludge anyway! -- RAM, 15/09/2000.
7056			*/
7057
7058	639	100	is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted);
		100
		50
		0
7059			TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted"));
7060	639		init_retrieve_context(aTHX_ cxt, optype, is_tainted);
7061
7062			ASSERT(is_retrieving(aTHX), ("within retrieve operation"));
7063
7064	639		sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */
7065
7066			/*
7067			* Final cleanup.
7068			*/
7069
7070	610	100	if (!f && in)
		100
7071	305		MBUF_RESTORE();
7072
7073	610		pre_06_fmt = cxt->hseen != NULL; /* Before we clean context */
7074
7075			/*
7076			* The "root" context is never freed.
7077			*/
7078
7079	610		clean_retrieve_context(aTHX_ cxt);
7080	610	100	if (cxt->prev) /* This context was stacked */
7081	40		free_context(aTHX_ cxt); /* It was not the "root" context */
7082
7083			/*
7084			* Prepare returned value.
7085			*/
7086
7087	610	100	if (!sv) {
7088			TRACEME(("retrieve ERROR"));
7089			#if (PATCHLEVEL <= 4)
7090			/* perl 5.00405 seems to screw up at this point with an
7091			'attempt to modify a read only value' error reported in the
7092			eval { $self = pretrieve(*FILE) } in _retrieve.
7093			I can't see what the cause of this error is, but I suspect a
7094			bug in 5.004, as it seems to be capable of issuing spurious
7095			errors or core dumping with matches on $@. I'm not going to
7096			spend time on what could be a fruitless search for the cause,
7097			so here's a bodge. If you're running 5.004 and don't like
7098			this inefficiency, either upgrade to a newer perl, or you are
7099			welcome to find the problem and send in a patch.
7100			*/
7101			return newSV(0);
7102			#else
7103	89		return &PL_sv_undef; /* Something went wrong, return undef */
7104			#endif
7105			}
7106
7107			TRACEME(("retrieve got %s(0x%" UVxf ")",
7108			sv_reftype(sv, FALSE), PTR2UV(sv)));
7109
7110			/*
7111			* Backward compatibility with Storable-0.5@9 (which we know we
7112			* are retrieving if hseen is non-null): don't create an extra RV
7113			* for objects since we special-cased it at store time.
7114			*
7115			* Build a reference to the SV returned by pretrieve even if it is
7116			* already one and not a scalar, for consistency reasons.
7117			*/
7118
7119	521	50	if (pre_06_fmt) { /* Was not handling overloading by then */
7120			SV *rv;
7121			TRACEME(("fixing for old formats -- pre 0.6"));
7122	0	0	if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
		0
		0
7123			TRACEME(("ended do_retrieve() with an object -- pre 0.6"));
7124	0		return sv;
7125			}
7126			}
7127
7128			/*
7129			* If reference is overloaded, restore behaviour.
7130			*
7131			* NB: minor glitch here: normally, overloaded refs are stored specially
7132			* so that we can croak when behaviour cannot be re-installed, and also
7133			* avoid testing for overloading magic at each reference retrieval.
7134			*
7135			* Unfortunately, the root reference is implicitly stored, so we must
7136			* check for possible overloading now. Furthermore, if we don't restore
7137			* overloading, we cannot croak as if the original ref was, because we
7138			* have no way to determine whether it was an overloaded ref or not in
7139			* the first place.
7140			*
7141			* It's a pity that overloading magic is attached to the rv, and not to
7142			* the underlying sv as blessing is.
7143			*/
7144
7145	521	100	if (SvOBJECT(sv)) {
7146	81		HV stash = (HV ) SvSTASH(sv);
7147	81		SV *rv = newRV_noinc(sv);
7148	81	50	if (stash && Gv_AMG(stash)) {
		50
		50
		50
		0
		50
		50
		50
		100
		100
7149	2		SvAMAGIC_on(rv);
7150			TRACEME(("restored overloading on root reference"));
7151			}
7152			TRACEME(("ended do_retrieve() with an object"));
7153	81		return rv;
7154			}
7155
7156			TRACEME(("regular do_retrieve() end"));
7157
7158	440		return newRV_noinc(sv);
7159			}
7160
7161			/*
7162			* pretrieve
7163			*
7164			* Retrieve data held in file and return the root object, undef on error.
7165			*/
7166	195		static SV pretrieve(pTHX_ PerlIO f, IV flag)
7167			{
7168			TRACEME(("pretrieve"));
7169	195		return do_retrieve(aTHX_ f, Nullsv, 0, (int)flag);
7170			}
7171
7172			/*
7173			* mretrieve
7174			*
7175			* Retrieve data held in scalar and return the root object, undef on error.
7176			*/
7177	358		static SV mretrieve(pTHX_ SV sv, IV flag)
7178			{
7179			TRACEME(("mretrieve"));
7180	358		return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0, (int)flag);
7181			}
7182
7183			/***
7184			*** Deep cloning
7185			***/
7186
7187			/*
7188			* dclone
7189			*
7190			* Deep clone: returns a fresh copy of the original referenced SV tree.
7191			*
7192			* This is achieved by storing the object in memory and restoring from
7193			* there. Not that efficient, but it should be faster than doing it from
7194			* pure perl anyway.
7195			*/
7196	162		static SV dclone(pTHX_ SV sv)
7197			{
7198	162		dSTCXT;
7199			STRLEN size;
7200			stcxt_t *real_context;
7201			SV *out;
7202
7203			TRACEME(("dclone"));
7204
7205			/*
7206			* Workaround for CROAK leak: if they enter with a "dirty" context,
7207			* free up memory for them now.
7208			*/
7209
7210			assert(cxt);
7211	162	100	if (cxt->s_dirty)
7212	2		clean_context(aTHX_ cxt);
7213
7214			/*
7215			* Tied elements seem to need special handling.
7216			*/
7217
7218	162	100	if ((SvTYPE(sv) == SVt_PVLV
7219			#if PERL_VERSION < 8
7220			\|\| SvTYPE(sv) == SVt_PVMG
7221			#endif
7222	2	50	) && (SvFLAGS(sv) & (SVs_GMG\|SVs_SMG\|SVs_RMG)) ==
7223	2	50	(SVs_GMG\|SVs_SMG\|SVs_RMG) &&
7224	2		mg_find(sv, 'p')) {
7225	2		mg_get(sv);
7226			}
7227
7228			/*
7229			* do_store() optimizes for dclone by not freeing its context, should
7230			* we need to allocate one because we're deep cloning from a hook.
7231			*/
7232
7233	162	50	if (!do_store(aTHX_ (PerlIO) 0, sv, ST_CLONE, FALSE, (SV*) 0))
7234	0		return &PL_sv_undef; /* Error during store */
7235
7236			/*
7237			* Because of the above optimization, we have to refresh the context,
7238			* since a new one could have been allocated and stacked by do_store().
7239			*/
7240
7241	160		{ dSTCXT; real_context = cxt; } /* Sub-block needed for macro */
7242	160		cxt = real_context; /* And we need this temporary... */
7243
7244			/*
7245			* Now, 'cxt' may refer to a new context.
7246			*/
7247
7248			assert(cxt);
7249			ASSERT(!cxt->s_dirty, ("clean context"));
7250			ASSERT(!cxt->entry, ("entry will not cause new context allocation"));
7251
7252	160		size = MBUF_SIZE();
7253			TRACEME(("dclone stored %ld bytes", (long)size));
7254	160	50	MBUF_INIT(size);
		50
7255
7256			/*
7257			* Since we're passing do_retrieve() both a NULL file and sv, we need
7258			* to pre-compute the taintedness of the input by setting cxt->tainted
7259			* to whatever state our own input string was. -- RAM, 15/09/2000
7260			*
7261			* do_retrieve() will free non-root context.
7262			*/
7263
7264	160	100	cxt->s_tainted = SvTAINTED(sv);
		50
7265	160		out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE, FLAG_BLESS_OK \| FLAG_TIE_OK);
7266
7267			TRACEME(("dclone returns 0x%" UVxf, PTR2UV(out)));
7268
7269	160		return out;
7270			}
7271
7272			/***
7273			*** Glue with perl.
7274			***/
7275
7276			/*
7277			* The Perl IO GV object distinguishes between input and output for sockets
7278			* but not for plain files. To allow Storable to transparently work on
7279			* plain files and sockets transparently, we have to ask xsubpp to fetch the
7280			* right object for us. Hence the OutputStream and InputStream declarations.
7281			*
7282			* Before perl 5.004_05, those entries in the standard typemap are not
7283			* defined in perl include files, so we do that here.
7284			*/
7285
7286			#ifndef OutputStream
7287			#define OutputStream PerlIO *
7288			#define InputStream PerlIO *
7289			#endif /* !OutputStream */
7290
7291			static int
7292	79		storable_free(pTHX_ SV sv, MAGIC mg) {
7293	79		stcxt_t cxt = (stcxt_t )SvPVX(sv);
7294
7295			PERL_UNUSED_ARG(mg);
7296	79	100	if (kbuf)
7297	40		Safefree(kbuf);
7298	79	50	if (!cxt->membuf_ro && mbase)
		100
7299	40		Safefree(mbase);
7300	79	50	if (cxt->membuf_ro && (cxt->msaved).arena)
		0
7301	0		Safefree((cxt->msaved).arena);
7302	79		return 0;
7303			}
7304
7305			MODULE = Storable PACKAGE = Storable
7306
7307			PROTOTYPES: ENABLE
7308
7309			BOOT:
7310			{
7311	31		HV *stash = gv_stashpvn("Storable", 8, GV_ADD);
7312	31		newCONSTSUB(stash, "BIN_MAJOR", newSViv(STORABLE_BIN_MAJOR));
7313	31		newCONSTSUB(stash, "BIN_MINOR", newSViv(STORABLE_BIN_MINOR));
7314	31		newCONSTSUB(stash, "BIN_WRITE_MINOR", newSViv(STORABLE_BIN_WRITE_MINOR));
7315
7316	31		init_perinterp(aTHX);
7317	31		gv_fetchpv("Storable::drop_utf8", GV_ADDMULTI, SVt_PV);
7318			#ifdef DEBUGME
7319			/* Only disable the used only once warning if we are in debugging mode. */
7320			gv_fetchpv("Storable::DEBUGME", GV_ADDMULTI, SVt_PV);
7321			#endif
7322			#ifdef USE_56_INTERWORK_KLUDGE
7323			gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV);
7324			#endif
7325			}
7326
7327			void
7328			init_perinterp()
7329			CODE:
7330	0		init_perinterp(aTHX);
7331
7332			# pstore
7333			#
7334			# Store the transitive data closure of given object to disk.
7335			# Returns undef on error, a true value otherwise.
7336
7337			# net_pstore
7338			#
7339			# Same as pstore(), but network order is used for integers and doubles are
7340			# emitted as strings.
7341
7342			SV *
7343			pstore(f,obj)
7344			OutputStream f
7345			SV* obj
7346			ALIAS:
7347			net_pstore = 1
7348			PPCODE:
7349	99	50	RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef;
7350			/* do_store() can reallocate the stack, so need a sequence point to ensure
7351			that ST(0) knows about it. Hence using two statements. */
7352	98		ST(0) = RETVAL;
7353	98		XSRETURN(1);
7354
7355			# mstore
7356			#
7357			# Store the transitive data closure of given object to memory.
7358			# Returns undef on error, a scalar value containing the data otherwise.
7359
7360			# net_mstore
7361			#
7362			# Same as mstore(), but network order is used for integers and doubles are
7363			# emitted as strings.
7364
7365			SV *
7366			mstore(obj)
7367			SV* obj
7368			ALIAS:
7369			net_mstore = 1
7370			CODE:
7371	258		RETVAL = &PL_sv_undef;
7372	258	50	if (!do_store(aTHX_ (PerlIO*) 0, obj, 0, ix, &RETVAL))
7373	0		RETVAL = &PL_sv_undef;
7374			OUTPUT:
7375			RETVAL
7376
7377			SV *
7378			pretrieve(f, flag = 6)
7379			InputStream f
7380			IV flag
7381			CODE:
7382	195		RETVAL = pretrieve(aTHX_ f, flag);
7383			OUTPUT:
7384			RETVAL
7385
7386			SV *
7387			mretrieve(sv, flag = 6)
7388			SV* sv
7389			IV flag
7390			CODE:
7391	358		RETVAL = mretrieve(aTHX_ sv, flag);
7392			OUTPUT:
7393			RETVAL
7394
7395			SV *
7396			dclone(sv)
7397			SV* sv
7398			CODE:
7399	162		RETVAL = dclone(aTHX_ sv);
7400			OUTPUT:
7401			RETVAL
7402
7403			void
7404			last_op_in_netorder()
7405			ALIAS:
7406			is_storing = ST_STORE
7407			is_retrieving = ST_RETRIEVE
7408			PREINIT:
7409			bool result;
7410			CODE:
7411	9	100	if (ix) {
7412	4		dSTCXT;
7413			assert(cxt);
7414	4	100	result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE;
		50
7415			} else {
7416	5		result = !!last_op_in_netorder(aTHX);
7417			}
7418	9	100	ST(0) = boolSV(result);
7419
7420			# so far readonly. we rather probe at install to be safe.
7421
7422			IV
7423			stack_depth()
7424			CODE:
7425	2		RETVAL = MAX_DEPTH;
7426			OUTPUT:
7427			RETVAL
7428
7429			IV
7430			stack_depth_hash()
7431			CODE:
7432	2		RETVAL = MAX_DEPTH_HASH;
7433			OUTPUT:
7434			RETVAL