File Coverage

Storable.xs

Criterion	Covered	Total	%
statement	1361	1657	82.1
branch	1509	3754	40.2
condition			n/a
subroutine			n/a
pod			n/a
total	2870	5411	53.0

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