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