File Coverage

Storable.xs

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