File Coverage

dist/Storable/Storable.xs
Criterion Covered Total %
statement 1140 1306 87.3
branch n/a
condition n/a
subroutine n/a
total 1140 1306 87.3


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