This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to CPAN 1.61.
[perl5.git] / ext / Storable / Storable.xs
CommitLineData
7a6a85bf
RG
1/*
2 * Store and retrieve mechanism.
3 */
4
5/*
6e0ac6f5 6 * $Id: Storable.xs,v 1.0.1.10 2001/08/28 21:52:14 ram Exp $
7a6a85bf
RG
7 *
8 * Copyright (c) 1995-2000, Raphael Manfredi
9 *
9e21b3d0
JH
10 * You may redistribute only under the same terms as Perl 5, as specified
11 * in the README file that comes with the distribution.
7a6a85bf
RG
12 *
13 * $Log: Storable.xs,v $
6e0ac6f5
JH
14 * Revision 1.0.1.10 2001/08/28 21:52:14 ram
15 * patch13: removed spurious debugging messages
16 *
e993d95c
JH
17 * Revision 1.0.1.9 2001/07/01 11:25:02 ram
18 * patch12: fixed memory corruption on croaks during thaw()
19 * patch12: made code compile cleanly with -Wall (Jarkko Hietaniemi)
20 * patch12: changed tagnum and classnum from I32 to IV in context
21 *
8be2b38b
JH
22 * Revision 1.0.1.8 2001/03/15 00:20:55 ram
23 * patch11: last version was wrongly compiling with assertions on
24 *
b12202d0
JH
25 * Revision 1.0.1.7 2001/02/17 12:25:26 ram
26 * patch8: now bless objects ASAP at retrieve time
27 * patch8: added support for blessed ref to tied structures
28 *
862382c7
JH
29 * Revision 1.0.1.6 2001/01/03 09:40:40 ram
30 * patch7: prototype and casting cleanup
31 * patch7: trace offending package when overloading cannot be restored
32 * patch7: made context cleanup safer to avoid dup freeing
33 *
90826881
JH
34 * Revision 1.0.1.5 2000/11/05 17:21:24 ram
35 * patch6: fixed severe "object lost" bug for STORABLE_freeze returns
36 *
212e9bde
JH
37 * Revision 1.0.1.4 2000/10/26 17:11:04 ram
38 * patch5: auto requires module of blessed ref when STORABLE_thaw misses
39 *
40 * Revision 1.0.1.3 2000/09/29 19:49:57 ram
41 * patch3: avoid using "tainted" and "dirty" since Perl remaps them via cpp
42 *
8be2b38b
JH
43 * Revision 1.0.1.2 2000/09/28 21:43:10 ram
44 * patch2: perls before 5.004_04 lack newSVpvn
45 *
46 * Revision 1.0.1.1 2000/09/17 16:47:49 ram
47 * patch1: now only taint retrieved data when source was tainted
48 * patch1: added support for UTF-8 strings
49 * patch1: fixed store hook bug: was allocating class id too soon
50 *
9e21b3d0
JH
51 * Revision 1.0 2000/09/01 19:40:41 ram
52 * Baseline for first official release.
7a6a85bf
RG
53 *
54 */
55
56#include <EXTERN.h>
57#include <perl.h>
e993d95c 58#include <patchlevel.h> /* Perl's one, needed since 5.6 */
7a6a85bf
RG
59#include <XSUB.h>
60
5dff01bc 61#ifndef NETWARE
e8189732 62#if 0
9e21b3d0
JH
63#define DEBUGME /* Debug mode, turns assertions on as well */
64#define DASSERT /* Assertion mode */
65#endif
5dff01bc
JH
66#else /* NETWARE */
67#if 0 /* On NetWare USE_PERLIO is not used */
68#define DEBUGME /* Debug mode, turns assertions on as well */
69#define DASSERT /* Assertion mode */
70#endif
71#endif
7a6a85bf
RG
72
73/*
74 * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined
75 * Provide them with the necessary defines so they can build with pre-5.004.
76 */
77#ifndef USE_PERLIO
78#ifndef PERLIO_IS_STDIO
79#define PerlIO FILE
80#define PerlIO_getc(x) getc(x)
81#define PerlIO_putc(f,x) putc(x,f)
82#define PerlIO_read(x,y,z) fread(y,1,z,x)
83#define PerlIO_write(x,y,z) fwrite(y,1,z,x)
84#define PerlIO_stdoutf printf
85#endif /* PERLIO_IS_STDIO */
86#endif /* USE_PERLIO */
87
88/*
89 * Earlier versions of perl might be used, we can't assume they have the latest!
90 */
f0ffaed8
JH
91
92#ifndef PERL_VERSION /* For perls < 5.6 */
e993d95c 93#define PERL_VERSION PATCHLEVEL
7a6a85bf
RG
94#ifndef newRV_noinc
95#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
96#endif
e993d95c 97#if (PATCHLEVEL <= 4) /* Older perls (<= 5.004) lack PL_ namespace */
7a6a85bf
RG
98#define PL_sv_yes sv_yes
99#define PL_sv_no sv_no
100#define PL_sv_undef sv_undef
e993d95c 101#if (SUBVERSION <= 4) /* 5.004_04 has been reported to lack newSVpvn */
dd19458b 102#define newSVpvn newSVpv
7a6a85bf 103#endif
e993d95c 104#endif /* PATCHLEVEL <= 4 */
7a6a85bf
RG
105#ifndef HvSHAREKEYS_off
106#define HvSHAREKEYS_off(hv) /* Ignore */
107#endif
f0ffaed8
JH
108#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
109#define AvFILLp AvFILL
110#endif
111typedef double NV; /* Older perls lack the NV type */
cc964657
JH
112#define IVdf "ld" /* Various printf formats for Perl types */
113#define UVuf "lu"
114#define UVof "lo"
115#define UVxf "lx"
116#define INT2PTR(t,v) (t)(IV)(v)
117#define PTR2UV(v) (unsigned long)(v)
f0ffaed8 118#endif /* PERL_VERSION -- perls < 5.6 */
7a6a85bf 119
cc964657 120#ifndef NVef /* The following were not part of perl 5.6 */
9e21b3d0
JH
121#if defined(USE_LONG_DOUBLE) && \
122 defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
123#define NVef PERL_PRIeldbl
124#define NVff PERL_PRIfldbl
125#define NVgf PERL_PRIgldbl
126#else
cc964657
JH
127#define NVef "e"
128#define NVff "f"
129#define NVgf "g"
130#endif
131#endif
132
7a6a85bf 133#ifdef DEBUGME
8be2b38b
JH
134
135#ifndef DASSERT
136#define DASSERT
137#endif
138
90826881
JH
139/*
140 * TRACEME() will only output things when the $Storable::DEBUGME is true.
141 */
142
143#define TRACEME(x) do { \
144 if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE))) \
145 { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
146} while (0)
7a6a85bf
RG
147#else
148#define TRACEME(x)
8be2b38b 149#endif /* DEBUGME */
7a6a85bf
RG
150
151#ifdef DASSERT
152#define ASSERT(x,y) do { \
153 if (!(x)) { \
154 PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \
155 __FILE__, __LINE__); \
156 PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \
157 } \
158} while (0)
159#else
160#define ASSERT(x,y)
161#endif
162
163/*
164 * Type markers.
165 */
166
167#define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */
168
169#define SX_OBJECT C(0) /* Already stored object */
dd19458b 170#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */
7a6a85bf
RG
171#define SX_ARRAY C(2) /* Array forthcominng (size, item list) */
172#define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */
173#define SX_REF C(4) /* Reference to object forthcoming */
174#define SX_UNDEF C(5) /* Undefined scalar */
175#define SX_INTEGER C(6) /* Integer forthcoming */
176#define SX_DOUBLE C(7) /* Double forthcoming */
177#define SX_BYTE C(8) /* (signed) byte forthcoming */
178#define SX_NETINT C(9) /* Integer in network order forthcoming */
dd19458b 179#define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */
7a6a85bf
RG
180#define SX_TIED_ARRAY C(11) /* Tied array forthcoming */
181#define SX_TIED_HASH C(12) /* Tied hash forthcoming */
182#define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */
183#define SX_SV_UNDEF C(14) /* Perl's immortal PL_sv_undef */
184#define SX_SV_YES C(15) /* Perl's immortal PL_sv_yes */
185#define SX_SV_NO C(16) /* Perl's immortal PL_sv_no */
186#define SX_BLESS C(17) /* Object is blessed */
187#define SX_IX_BLESS C(18) /* Object is blessed, classname given by index */
188#define SX_HOOK C(19) /* Stored via hook, user-defined */
189#define SX_OVERLOAD C(20) /* Overloaded reference */
190#define SX_TIED_KEY C(21) /* Tied magic key forthcoming */
191#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */
dd19458b
JH
192#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */
193#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */
e16e2ff8
NC
194#define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
195#define SX_ERROR C(26) /* Error */
7a6a85bf
RG
196
197/*
198 * Those are only used to retrieve "old" pre-0.6 binary images.
199 */
200#define SX_ITEM 'i' /* An array item introducer */
201#define SX_IT_UNDEF 'I' /* Undefined array item */
d1be9408
JF
202#define SX_KEY 'k' /* A hash key introducer */
203#define SX_VALUE 'v' /* A hash value introducer */
7a6a85bf
RG
204#define SX_VL_UNDEF 'V' /* Undefined hash value */
205
206/*
207 * Those are only used to retrieve "old" pre-0.7 binary images
208 */
209
210#define SX_CLASS 'b' /* Object is blessed, class name length <255 */
211#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */
212#define SX_STORED 'X' /* End of object */
213
214/*
215 * Limits between short/long length representation.
216 */
217
218#define LG_SCALAR 255 /* Large scalar length limit */
219#define LG_BLESS 127 /* Large classname bless limit */
220
221/*
222 * Operation types
223 */
224
225#define ST_STORE 0x1 /* Store operation */
226#define ST_RETRIEVE 0x2 /* Retrieval operation */
227#define ST_CLONE 0x4 /* Deep cloning operation */
228
229/*
230 * The following structure is used for hash table key retrieval. Since, when
231 * retrieving objects, we'll be facing blessed hash references, it's best
232 * to pre-allocate that buffer once and resize it as the need arises, never
233 * freeing it (keys will be saved away someplace else anyway, so even large
234 * keys are not enough a motivation to reclaim that space).
235 *
236 * This structure is also used for memory store/retrieve operations which
237 * happen in a fixed place before being malloc'ed elsewhere if persistency
238 * is required. Hence the aptr pointer.
239 */
240struct extendable {
241 char *arena; /* Will hold hash key strings, resized as needed */
242 STRLEN asiz; /* Size of aforementionned buffer */
243 char *aptr; /* Arena pointer, for in-place read/write ops */
244 char *aend; /* First invalid address */
245};
246
247/*
248 * At store time:
d1be9408 249 * A hash table records the objects which have already been stored.
7a6a85bf
RG
250 * Those are referred to as SX_OBJECT in the file, and their "tag" (i.e.
251 * an arbitrary sequence number) is used to identify them.
252 *
253 * At retrieve time:
254 * An array table records the objects which have already been retrieved,
255 * as seen by the tag determind by counting the objects themselves. The
256 * reference to that retrieved object is kept in the table, and is returned
257 * when an SX_OBJECT is found bearing that same tag.
258 *
259 * The same processing is used to record "classname" for blessed objects:
260 * indexing by a hash at store time, and via an array at retrieve time.
261 */
262
263typedef unsigned long stag_t; /* Used by pre-0.6 binary format */
264
265/*
266 * The following "thread-safe" related defines were contributed by
267 * Murray Nesbitt <murray@activestate.com> and integrated by RAM, who
268 * only renamed things a little bit to ensure consistency with surrounding
269 * code. -- RAM, 14/09/1999
270 *
271 * The original patch suffered from the fact that the stcxt_t structure
272 * was global. Murray tried to minimize the impact on the code as much as
273 * possible.
274 *
275 * Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks
276 * on objects. Therefore, the notion of context needs to be generalized,
277 * threading or not.
278 */
279
280#define MY_VERSION "Storable(" XS_VERSION ")"
281
530b72ba
NC
282
283/*
284 * Conditional UTF8 support.
285 *
286 */
287#ifdef SvUTF8_on
288#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
289#define HAS_UTF8_SCALARS
290#ifdef HeKUTF8
291#define HAS_UTF8_HASHES
292#define HAS_UTF8_ALL
293#else
294/* 5.6 perl has utf8 scalars but not hashes */
295#endif
296#else
297#define SvUTF8(sv) 0
298#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
299#endif
300#ifndef HAS_UTF8_ALL
301#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
302#endif
303
304#ifdef HvPLACEHOLDERS
305#define HAS_RESTRICTED_HASHES
306#else
307#define HVhek_PLACEHOLD 0x200
308#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash"))
309#endif
310
311#ifdef HvHASKFLAGS
312#define HAS_HASH_KEY_FLAGS
313#endif
314
dd19458b
JH
315/*
316 * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
317 * files remap tainted and dirty when threading is enabled. That's bad for
318 * perl to remap such common words. -- RAM, 29/09/00
319 */
320
7a6a85bf
RG
321typedef struct stcxt {
322 int entry; /* flags recursion */
323 int optype; /* type of traversal operation */
e993d95c
JH
324 HV *hseen; /* which objects have been seen, store time */
325 AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */
326 AV *aseen; /* which objects have been seen, retrieve time */
327 HV *hclass; /* which classnames have been seen, store time */
328 AV *aclass; /* which classnames have been seen, retrieve time */
329 HV *hook; /* cache for hook methods per class name */
330 IV tagnum; /* incremented at store time for each seen object */
331 IV classnum; /* incremented at store time for each seen classname */
332 int netorder; /* true if network order used */
333 int s_tainted; /* true if input source is tainted, at retrieve time */
334 int forgive_me; /* whether to be forgiving... */
335 int canonical; /* whether to store hashes sorted by key */
530b72ba
NC
336#ifndef HAS_RESTRICTED_HASHES
337 int derestrict; /* whether to downgrade restrcted hashes */
338#endif
339#ifndef HAS_UTF8_ALL
340 int use_bytes; /* whether to bytes-ify utf8 */
341#endif
e8189732 342 int accept_future_minor; /* croak immediately on future minor versions? */
dd19458b 343 int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
e993d95c
JH
344 int membuf_ro; /* true means membuf is read-only and msaved is rw */
345 struct extendable keybuf; /* for hash key retrieval */
346 struct extendable membuf; /* for memory store/retrieve operations */
347 struct extendable msaved; /* where potentially valid mbuf is saved */
7a6a85bf
RG
348 PerlIO *fio; /* where I/O are performed, NULL for memory */
349 int ver_major; /* major of version for retrieved object */
350 int ver_minor; /* minor of version for retrieved object */
351 SV *(**retrieve_vtbl)(); /* retrieve dispatch table */
352 struct stcxt *prev; /* contexts chained backwards in real recursion */
353} stcxt_t;
354
355#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
356
e993d95c 357#if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
7a6a85bf
RG
358#define dSTCXT_SV \
359 SV *perinterp_sv = perl_get_sv(MY_VERSION, FALSE)
360#else /* >= perl5.004_68 */
361#define dSTCXT_SV \
362 SV *perinterp_sv = *hv_fetch(PL_modglobal, \
363 MY_VERSION, sizeof(MY_VERSION)-1, TRUE)
364#endif /* < perl5.004_68 */
365
366#define dSTCXT_PTR(T,name) \
e16e2ff8
NC
367 T name = ((perinterp_sv && SvIOK(perinterp_sv) \
368 ? INT2PTR(T, SvIVX(perinterp_sv)) : (T) 0))
7a6a85bf
RG
369#define dSTCXT \
370 dSTCXT_SV; \
371 dSTCXT_PTR(stcxt_t *, cxt)
372
373#define INIT_STCXT \
374 dSTCXT; \
375 Newz(0, cxt, 1, stcxt_t); \
43d061fe 376 sv_setiv(perinterp_sv, PTR2IV(cxt))
7a6a85bf
RG
377
378#define SET_STCXT(x) do { \
379 dSTCXT_SV; \
43d061fe 380 sv_setiv(perinterp_sv, PTR2IV(x)); \
7a6a85bf
RG
381} while (0)
382
383#else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
384
385static stcxt_t Context;
386static stcxt_t *Context_ptr = &Context;
387#define dSTCXT stcxt_t *cxt = Context_ptr
388#define INIT_STCXT dSTCXT
389#define SET_STCXT(x) Context_ptr = x
390
391#endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */
392
393/*
394 * KNOWN BUG:
395 * Croaking implies a memory leak, since we don't use setjmp/longjmp
396 * to catch the exit and free memory used during store or retrieve
397 * operations. This is not too difficult to fix, but I need to understand
398 * how Perl does it, and croaking is exceptional anyway, so I lack the
399 * motivation to do it.
400 *
401 * The current workaround is to mark the context as dirty when croaking,
402 * so that data structures can be freed whenever we renter Storable code
403 * (but only *then*: it's a workaround, not a fix).
404 *
405 * This is also imperfect, because we don't really know how far they trapped
406 * the croak(), and when we were recursing, we won't be able to clean anything
407 * but the topmost context stacked.
408 */
409
dd19458b 410#define CROAK(x) do { cxt->s_dirty = 1; croak x; } while (0)
7a6a85bf
RG
411
412/*
413 * End of "thread-safe" related definitions.
414 */
415
416/*
9e21b3d0
JH
417 * LOW_32BITS
418 *
419 * Keep only the low 32 bits of a pointer (used for tags, which are not
420 * really pointers).
421 */
422
423#if PTRSIZE <= 4
424#define LOW_32BITS(x) ((I32) (x))
425#else
426#define LOW_32BITS(x) ((I32) ((unsigned long) (x) & 0xffffffffUL))
427#endif
428
429/*
430 * oI, oS, oC
431 *
432 * Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
433 * Used in the WLEN and RLEN macros.
434 */
435
436#if INTSIZE > 4
437#define oI(x) ((I32 *) ((char *) (x) + 4))
438#define oS(x) ((x) - 4)
439#define oC(x) (x = 0)
440#define CRAY_HACK
441#else
442#define oI(x) (x)
443#define oS(x) (x)
444#define oC(x)
445#endif
446
447/*
7a6a85bf
RG
448 * key buffer handling
449 */
450#define kbuf (cxt->keybuf).arena
451#define ksiz (cxt->keybuf).asiz
452#define KBUFINIT() do { \
453 if (!kbuf) { \
454 TRACEME(("** allocating kbuf of 128 bytes")); \
455 New(10003, kbuf, 128, char); \
456 ksiz = 128; \
457 } \
458} while (0)
459#define KBUFCHK(x) do { \
460 if (x >= ksiz) { \
e993d95c 461 TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \
7a6a85bf
RG
462 Renew(kbuf, x+1, char); \
463 ksiz = x+1; \
464 } \
465} while (0)
466
467/*
468 * memory buffer handling
469 */
470#define mbase (cxt->membuf).arena
471#define msiz (cxt->membuf).asiz
472#define mptr (cxt->membuf).aptr
473#define mend (cxt->membuf).aend
474
475#define MGROW (1 << 13)
476#define MMASK (MGROW - 1)
477
478#define round_mgrow(x) \
479 ((unsigned long) (((unsigned long) (x) + MMASK) & ~MMASK))
480#define trunc_int(x) \
481 ((unsigned long) ((unsigned long) (x) & ~(sizeof(int)-1)))
482#define int_aligned(x) \
483 ((unsigned long) (x) == trunc_int(x))
484
485#define MBUF_INIT(x) do { \
486 if (!mbase) { \
487 TRACEME(("** allocating mbase of %d bytes", MGROW)); \
488 New(10003, mbase, MGROW, char); \
489 msiz = MGROW; \
490 } \
491 mptr = mbase; \
492 if (x) \
493 mend = mbase + x; \
494 else \
495 mend = mbase + msiz; \
496} while (0)
497
498#define MBUF_TRUNC(x) mptr = mbase + x
499#define MBUF_SIZE() (mptr - mbase)
500
501/*
e993d95c
JH
502 * MBUF_SAVE_AND_LOAD
503 * MBUF_RESTORE
504 *
505 * Those macros are used in do_retrieve() to save the current memory
506 * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
507 * data from a string.
508 */
509#define MBUF_SAVE_AND_LOAD(in) do { \
510 ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \
511 cxt->membuf_ro = 1; \
512 TRACEME(("saving mbuf")); \
513 StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \
514 MBUF_LOAD(in); \
515} while (0)
516
517#define MBUF_RESTORE() do { \
518 ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
519 cxt->membuf_ro = 0; \
520 TRACEME(("restoring mbuf")); \
521 StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
522} while (0)
523
524/*
7a6a85bf
RG
525 * Use SvPOKp(), because SvPOK() fails on tainted scalars.
526 * See store_scalar() for other usage of this workaround.
527 */
528#define MBUF_LOAD(v) do { \
e993d95c 529 ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
7a6a85bf
RG
530 if (!SvPOKp(v)) \
531 CROAK(("Not a scalar string")); \
532 mptr = mbase = SvPV(v, msiz); \
533 mend = mbase + msiz; \
534} while (0)
535
536#define MBUF_XTEND(x) do { \
537 int nsz = (int) round_mgrow((x)+msiz); \
538 int offset = mptr - mbase; \
e993d95c
JH
539 ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
540 TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \
541 msiz, nsz, (x))); \
7a6a85bf
RG
542 Renew(mbase, nsz, char); \
543 msiz = nsz; \
544 mptr = mbase + offset; \
545 mend = mbase + nsz; \
546} while (0)
547
548#define MBUF_CHK(x) do { \
549 if ((mptr + (x)) > mend) \
550 MBUF_XTEND(x); \
551} while (0)
552
553#define MBUF_GETC(x) do { \
554 if (mptr < mend) \
555 x = (int) (unsigned char) *mptr++; \
556 else \
557 return (SV *) 0; \
558} while (0)
559
9e21b3d0
JH
560#ifdef CRAY_HACK
561#define MBUF_GETINT(x) do { \
562 oC(x); \
563 if ((mptr + 4) <= mend) { \
564 memcpy(oI(&x), mptr, 4); \
565 mptr += 4; \
566 } else \
567 return (SV *) 0; \
568} while (0)
569#else
7a6a85bf
RG
570#define MBUF_GETINT(x) do { \
571 if ((mptr + sizeof(int)) <= mend) { \
572 if (int_aligned(mptr)) \
573 x = *(int *) mptr; \
574 else \
575 memcpy(&x, mptr, sizeof(int)); \
576 mptr += sizeof(int); \
577 } else \
578 return (SV *) 0; \
579} while (0)
9e21b3d0 580#endif
7a6a85bf
RG
581
582#define MBUF_READ(x,s) do { \
583 if ((mptr + (s)) <= mend) { \
584 memcpy(x, mptr, s); \
585 mptr += s; \
586 } else \
587 return (SV *) 0; \
588} while (0)
589
590#define MBUF_SAFEREAD(x,s,z) do { \
591 if ((mptr + (s)) <= mend) { \
592 memcpy(x, mptr, s); \
593 mptr += s; \
594 } else { \
595 sv_free(z); \
596 return (SV *) 0; \
597 } \
598} while (0)
599
600#define MBUF_PUTC(c) do { \
601 if (mptr < mend) \
602 *mptr++ = (char) c; \
603 else { \
604 MBUF_XTEND(1); \
605 *mptr++ = (char) c; \
606 } \
607} while (0)
608
9e21b3d0
JH
609#ifdef CRAY_HACK
610#define MBUF_PUTINT(i) do { \
611 MBUF_CHK(4); \
612 memcpy(mptr, oI(&i), 4); \
613 mptr += 4; \
614} while (0)
615#else
7a6a85bf
RG
616#define MBUF_PUTINT(i) do { \
617 MBUF_CHK(sizeof(int)); \
618 if (int_aligned(mptr)) \
619 *(int *) mptr = i; \
620 else \
621 memcpy(mptr, &i, sizeof(int)); \
622 mptr += sizeof(int); \
623} while (0)
9e21b3d0 624#endif
7a6a85bf
RG
625
626#define MBUF_WRITE(x,s) do { \
627 MBUF_CHK(s); \
628 memcpy(mptr, x, s); \
629 mptr += s; \
630} while (0)
631
632/*
7a6a85bf
RG
633 * Possible return values for sv_type().
634 */
635
636#define svis_REF 0
637#define svis_SCALAR 1
638#define svis_ARRAY 2
639#define svis_HASH 3
640#define svis_TIED 4
641#define svis_TIED_ITEM 5
642#define svis_OTHER 6
643
644/*
645 * Flags for SX_HOOK.
646 */
647
648#define SHF_TYPE_MASK 0x03
649#define SHF_LARGE_CLASSLEN 0x04
650#define SHF_LARGE_STRLEN 0x08
651#define SHF_LARGE_LISTLEN 0x10
652#define SHF_IDX_CLASSNAME 0x20
653#define SHF_NEED_RECURSE 0x40
654#define SHF_HAS_LIST 0x80
655
656/*
b12202d0 657 * Types for SX_HOOK (last 2 bits in flags).
7a6a85bf
RG
658 */
659
660#define SHT_SCALAR 0
661#define SHT_ARRAY 1
662#define SHT_HASH 2
b12202d0
JH
663#define SHT_EXTRA 3 /* Read extra byte for type */
664
665/*
666 * The following are held in the "extra byte"...
667 */
668
669#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */
670#define SHT_TARRAY 5 /* 4 + 1 -- tied array */
671#define SHT_THASH 6 /* 4 + 2 -- tied hash */
7a6a85bf
RG
672
673/*
e16e2ff8
NC
674 * per hash flags for flagged hashes
675 */
676
677#define SHV_RESTRICTED 0x01
678
679/*
680 * per key flags for flagged hashes
681 */
682
683#define SHV_K_UTF8 0x01
684#define SHV_K_WASUTF8 0x02
685#define SHV_K_LOCKED 0x04
686#define SHV_K_ISSV 0x08
687#define SHV_K_PLACEHOLDER 0x10
688
689/*
7a6a85bf
RG
690 * Before 0.6, the magic string was "perl-store" (binary version number 0).
691 *
692 * Since 0.6 introduced many binary incompatibilities, the magic string has
693 * been changed to "pst0" to allow an old image to be properly retrieved by
694 * a newer Storable, but ensure a newer image cannot be retrieved with an
695 * older version.
696 *
697 * At 0.7, objects are given the ability to serialize themselves, and the
698 * set of markers is extended, backward compatibility is not jeopardized,
699 * so the binary version number could have remained unchanged. To correctly
700 * spot errors if a file making use of 0.7-specific extensions is given to
701 * 0.6 for retrieval, the binary version was moved to "2". And I'm introducing
702 * a "minor" version, to better track this kind of evolution from now on.
703 *
704 */
705static char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */
706static char magicstr[] = "pst0"; /* Used as a magic number */
707
530b72ba 708
e16e2ff8 709#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
530b72ba
NC
710#define STORABLE_BIN_MINOR 5 /* Binary minor "version" */
711
712/* If we aren't 5.7.3 or later, we won't be writing out files that use the
713 * new flagged hash introdued in 2.5, so put 2.4 in the binary header to
714 * maximise ease of interoperation with older Storables.
715 * Could we write 2.3s if we're on 5.005_03? NWC
716 */
e16e2ff8 717#if (PATCHLEVEL <= 6)
530b72ba 718#define STORABLE_BIN_WRITE_MINOR 4
e16e2ff8
NC
719#else
720/*
721 * As of perl 5.7.3, utf8 hash key is introduced.
722 * So this must change -- dankogai
723*/
530b72ba 724#define STORABLE_BIN_WRITE_MINOR 5
e16e2ff8 725#endif /* (PATCHLEVEL <= 6) */
7a6a85bf
RG
726
727/*
728 * Useful store shortcuts...
729 */
730
731#define PUTMARK(x) do { \
732 if (!cxt->fio) \
733 MBUF_PUTC(x); \
734 else if (PerlIO_putc(cxt->fio, x) == EOF) \
735 return -1; \
736} while (0)
737
9e21b3d0
JH
738#define WRITE_I32(x) do { \
739 ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \
740 if (!cxt->fio) \
741 MBUF_PUTINT(x); \
742 else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
743 return -1; \
744 } while (0)
745
7a6a85bf
RG
746#ifdef HAS_HTONL
747#define WLEN(x) do { \
748 if (cxt->netorder) { \
749 int y = (int) htonl(x); \
750 if (!cxt->fio) \
751 MBUF_PUTINT(y); \
9e21b3d0 752 else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \
7a6a85bf
RG
753 return -1; \
754 } else { \
755 if (!cxt->fio) \
756 MBUF_PUTINT(x); \
9e21b3d0 757 else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \
7a6a85bf
RG
758 return -1; \
759 } \
760} while (0)
761#else
9e21b3d0 762#define WLEN(x) WRITE_I32(x)
7a6a85bf
RG
763#endif
764
765#define WRITE(x,y) do { \
766 if (!cxt->fio) \
767 MBUF_WRITE(x,y); \
768 else if (PerlIO_write(cxt->fio, x, y) != y) \
769 return -1; \
770 } while (0)
771
dd19458b 772#define STORE_PV_LEN(pv, len, small, large) do { \
7a6a85bf
RG
773 if (len <= LG_SCALAR) { \
774 unsigned char clen = (unsigned char) len; \
dd19458b 775 PUTMARK(small); \
7a6a85bf
RG
776 PUTMARK(clen); \
777 if (len) \
778 WRITE(pv, len); \
779 } else { \
dd19458b 780 PUTMARK(large); \
7a6a85bf
RG
781 WLEN(len); \
782 WRITE(pv, len); \
783 } \
784} while (0)
785
dd19458b
JH
786#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
787
788/*
7a6a85bf
RG
789 * Store undef in arrays and hashes without recursing through store().
790 */
791#define STORE_UNDEF() do { \
792 cxt->tagnum++; \
793 PUTMARK(SX_UNDEF); \
794} while (0)
795
796/*
797 * Useful retrieve shortcuts...
798 */
799
800#define GETCHAR() \
801 (cxt->fio ? PerlIO_getc(cxt->fio) : (mptr >= mend ? EOF : (int) *mptr++))
802
803#define GETMARK(x) do { \
804 if (!cxt->fio) \
805 MBUF_GETC(x); \
76df4757 806 else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \
7a6a85bf
RG
807 return (SV *) 0; \
808} while (0)
809
9e21b3d0
JH
810#define READ_I32(x) do { \
811 ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \
812 oC(x); \
7a6a85bf
RG
813 if (!cxt->fio) \
814 MBUF_GETINT(x); \
9e21b3d0 815 else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
7a6a85bf 816 return (SV *) 0; \
7a6a85bf 817} while (0)
9e21b3d0
JH
818
819#ifdef HAS_NTOHL
7a6a85bf 820#define RLEN(x) do { \
9e21b3d0 821 oC(x); \
7a6a85bf
RG
822 if (!cxt->fio) \
823 MBUF_GETINT(x); \
9e21b3d0 824 else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \
7a6a85bf 825 return (SV *) 0; \
9e21b3d0
JH
826 if (cxt->netorder) \
827 x = (int) ntohl(x); \
7a6a85bf 828} while (0)
9e21b3d0
JH
829#else
830#define RLEN(x) READ_I32(x)
7a6a85bf
RG
831#endif
832
833#define READ(x,y) do { \
834 if (!cxt->fio) \
835 MBUF_READ(x, y); \
836 else if (PerlIO_read(cxt->fio, x, y) != y) \
837 return (SV *) 0; \
838} while (0)
839
840#define SAFEREAD(x,y,z) do { \
841 if (!cxt->fio) \
842 MBUF_SAFEREAD(x,y,z); \
843 else if (PerlIO_read(cxt->fio, x, y) != y) { \
844 sv_free(z); \
845 return (SV *) 0; \
846 } \
847} while (0)
848
849/*
850 * This macro is used at retrieve time, to remember where object 'y', bearing a
851 * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
852 * we'll therefore know where it has been retrieved and will be able to
853 * share the same reference, as in the original stored memory image.
b12202d0
JH
854 *
855 * We also need to bless objects ASAP for hooks (which may compute "ref $x"
856 * on the objects given to STORABLE_thaw and expect that to be defined), and
857 * also for overloaded objects (for which we might not find the stash if the
858 * object is not blessed yet--this might occur for overloaded objects that
859 * refer to themselves indirectly: if we blessed upon return from a sub
860 * retrieve(), the SX_OBJECT marker we'd found could not have overloading
861 * restored on it because the underlying object would not be blessed yet!).
862 *
863 * To achieve that, the class name of the last retrieved object is passed down
864 * recursively, and the first SEEN() call for which the class name is not NULL
865 * will bless the object.
7a6a85bf 866 */
b12202d0 867#define SEEN(y,c) do { \
7a6a85bf
RG
868 if (!y) \
869 return (SV *) 0; \
870 if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \
871 return (SV *) 0; \
43d061fe 872 TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \
b12202d0
JH
873 PTR2UV(y), SvREFCNT(y)-1)); \
874 if (c) \
875 BLESS((SV *) (y), c); \
7a6a85bf
RG
876} while (0)
877
878/*
879 * Bless `s' in `p', via a temporary reference, required by sv_bless().
880 */
881#define BLESS(s,p) do { \
882 SV *ref; \
883 HV *stash; \
43d061fe 884 TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (p))); \
7a6a85bf
RG
885 stash = gv_stashpv((p), TRUE); \
886 ref = newRV_noinc(s); \
887 (void) sv_bless(ref, stash); \
888 SvRV(ref) = 0; \
889 SvREFCNT_dec(ref); \
890} while (0)
891
892static int store();
b12202d0 893static SV *retrieve(stcxt_t *cxt, char *cname);
7a6a85bf
RG
894
895/*
896 * Dynamic dispatching table for SV store.
897 */
898
899static int store_ref(stcxt_t *cxt, SV *sv);
900static int store_scalar(stcxt_t *cxt, SV *sv);
901static int store_array(stcxt_t *cxt, AV *av);
902static int store_hash(stcxt_t *cxt, HV *hv);
903static int store_tied(stcxt_t *cxt, SV *sv);
904static int store_tied_item(stcxt_t *cxt, SV *sv);
905static int store_other(stcxt_t *cxt, SV *sv);
f0ffaed8 906static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
7a6a85bf 907
862382c7
JH
908static int (*sv_store[])(stcxt_t *cxt, SV *sv) = {
909 store_ref, /* svis_REF */
910 store_scalar, /* svis_SCALAR */
911 (int (*)(stcxt_t *cxt, SV *sv)) store_array, /* svis_ARRAY */
912 (int (*)(stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */
913 store_tied, /* svis_TIED */
914 store_tied_item, /* svis_TIED_ITEM */
915 store_other, /* svis_OTHER */
7a6a85bf
RG
916};
917
918#define SV_STORE(x) (*sv_store[x])
919
920/*
921 * Dynamic dispatching tables for SV retrieval.
922 */
923
b12202d0
JH
924static SV *retrieve_lscalar(stcxt_t *cxt, char *cname);
925static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname);
926static SV *old_retrieve_array(stcxt_t *cxt, char *cname);
927static SV *old_retrieve_hash(stcxt_t *cxt, char *cname);
928static SV *retrieve_ref(stcxt_t *cxt, char *cname);
929static SV *retrieve_undef(stcxt_t *cxt, char *cname);
930static SV *retrieve_integer(stcxt_t *cxt, char *cname);
931static SV *retrieve_double(stcxt_t *cxt, char *cname);
932static SV *retrieve_byte(stcxt_t *cxt, char *cname);
933static SV *retrieve_netint(stcxt_t *cxt, char *cname);
934static SV *retrieve_scalar(stcxt_t *cxt, char *cname);
935static SV *retrieve_utf8str(stcxt_t *cxt, char *cname);
936static SV *retrieve_tied_array(stcxt_t *cxt, char *cname);
937static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname);
938static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname);
939static SV *retrieve_other(stcxt_t *cxt, char *cname);
940
941static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = {
7a6a85bf
RG
942 0, /* SX_OBJECT -- entry unused dynamically */
943 retrieve_lscalar, /* SX_LSCALAR */
944 old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */
945 old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */
946 retrieve_ref, /* SX_REF */
947 retrieve_undef, /* SX_UNDEF */
948 retrieve_integer, /* SX_INTEGER */
949 retrieve_double, /* SX_DOUBLE */
950 retrieve_byte, /* SX_BYTE */
951 retrieve_netint, /* SX_NETINT */
952 retrieve_scalar, /* SX_SCALAR */
953 retrieve_tied_array, /* SX_ARRAY */
954 retrieve_tied_hash, /* SX_HASH */
955 retrieve_tied_scalar, /* SX_SCALAR */
956 retrieve_other, /* SX_SV_UNDEF not supported */
957 retrieve_other, /* SX_SV_YES not supported */
958 retrieve_other, /* SX_SV_NO not supported */
959 retrieve_other, /* SX_BLESS not supported */
960 retrieve_other, /* SX_IX_BLESS not supported */
961 retrieve_other, /* SX_HOOK not supported */
962 retrieve_other, /* SX_OVERLOADED not supported */
963 retrieve_other, /* SX_TIED_KEY not supported */
964 retrieve_other, /* SX_TIED_IDX not supported */
dd19458b
JH
965 retrieve_other, /* SX_UTF8STR not supported */
966 retrieve_other, /* SX_LUTF8STR not supported */
e16e2ff8 967 retrieve_other, /* SX_FLAG_HASH not supported */
7a6a85bf
RG
968 retrieve_other, /* SX_ERROR */
969};
970
b12202d0
JH
971static SV *retrieve_array(stcxt_t *cxt, char *cname);
972static SV *retrieve_hash(stcxt_t *cxt, char *cname);
973static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname);
974static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname);
975static SV *retrieve_sv_no(stcxt_t *cxt, char *cname);
976static SV *retrieve_blessed(stcxt_t *cxt, char *cname);
977static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname);
978static SV *retrieve_hook(stcxt_t *cxt, char *cname);
979static SV *retrieve_overloaded(stcxt_t *cxt, char *cname);
980static SV *retrieve_tied_key(stcxt_t *cxt, char *cname);
981static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname);
e16e2ff8 982static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname);
b12202d0
JH
983
984static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
7a6a85bf
RG
985 0, /* SX_OBJECT -- entry unused dynamically */
986 retrieve_lscalar, /* SX_LSCALAR */
987 retrieve_array, /* SX_ARRAY */
988 retrieve_hash, /* SX_HASH */
989 retrieve_ref, /* SX_REF */
990 retrieve_undef, /* SX_UNDEF */
991 retrieve_integer, /* SX_INTEGER */
992 retrieve_double, /* SX_DOUBLE */
993 retrieve_byte, /* SX_BYTE */
994 retrieve_netint, /* SX_NETINT */
995 retrieve_scalar, /* SX_SCALAR */
996 retrieve_tied_array, /* SX_ARRAY */
997 retrieve_tied_hash, /* SX_HASH */
998 retrieve_tied_scalar, /* SX_SCALAR */
999 retrieve_sv_undef, /* SX_SV_UNDEF */
1000 retrieve_sv_yes, /* SX_SV_YES */
1001 retrieve_sv_no, /* SX_SV_NO */
1002 retrieve_blessed, /* SX_BLESS */
1003 retrieve_idx_blessed, /* SX_IX_BLESS */
1004 retrieve_hook, /* SX_HOOK */
1005 retrieve_overloaded, /* SX_OVERLOAD */
1006 retrieve_tied_key, /* SX_TIED_KEY */
1007 retrieve_tied_idx, /* SX_TIED_IDX */
dd19458b
JH
1008 retrieve_utf8str, /* SX_UTF8STR */
1009 retrieve_lutf8str, /* SX_LUTF8STR */
e16e2ff8 1010 retrieve_flag_hash, /* SX_HASH */
7a6a85bf
RG
1011 retrieve_other, /* SX_ERROR */
1012};
1013
1014#define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)])
1015
f0ffaed8 1016static SV *mbuf2sv(void);
7a6a85bf
RG
1017
1018/***
1019 *** Context management.
1020 ***/
1021
1022/*
1023 * init_perinterp
1024 *
1025 * Called once per "thread" (interpreter) to initialize some global context.
1026 */
f0ffaed8
JH
1027static void init_perinterp(void)
1028{
7a6a85bf
RG
1029 INIT_STCXT;
1030
1031 cxt->netorder = 0; /* true if network order used */
1032 cxt->forgive_me = -1; /* whether to be forgiving... */
1033}
1034
1035/*
e993d95c
JH
1036 * reset_context
1037 *
1038 * Called at the end of every context cleaning, to perform common reset
1039 * operations.
1040 */
1041static void reset_context(stcxt_t *cxt)
1042{
1043 cxt->entry = 0;
1044 cxt->s_dirty = 0;
1045 cxt->optype &= ~(ST_STORE|ST_RETRIEVE); /* Leave ST_CLONE alone */
1046}
1047
1048/*
7a6a85bf
RG
1049 * init_store_context
1050 *
1051 * Initialize a new store context for real recursion.
1052 */
f0ffaed8
JH
1053static void init_store_context(
1054 stcxt_t *cxt,
1055 PerlIO *f,
1056 int optype,
1057 int network_order)
7a6a85bf
RG
1058{
1059 TRACEME(("init_store_context"));
1060
1061 cxt->netorder = network_order;
1062 cxt->forgive_me = -1; /* Fetched from perl if needed */
1063 cxt->canonical = -1; /* Idem */
1064 cxt->tagnum = -1; /* Reset tag numbers */
1065 cxt->classnum = -1; /* Reset class numbers */
1066 cxt->fio = f; /* Where I/O are performed */
1067 cxt->optype = optype; /* A store, or a deep clone */
1068 cxt->entry = 1; /* No recursion yet */
1069
1070 /*
1071 * The `hseen' table is used to keep track of each SV stored and their
1072 * associated tag numbers is special. It is "abused" because the
1073 * values stored are not real SV, just integers cast to (SV *),
1074 * which explains the freeing below.
1075 *
1076 * It is also one possible bottlneck to achieve good storing speed,
1077 * so the "shared keys" optimization is turned off (unlikely to be
1078 * of any use here), and the hash table is "pre-extended". Together,
1079 * those optimizations increase the throughput by 12%.
1080 */
1081
1082 cxt->hseen = newHV(); /* Table where seen objects are stored */
1083 HvSHAREKEYS_off(cxt->hseen);
1084
1085 /*
1086 * The following does not work well with perl5.004_04, and causes
1087 * a core dump later on, in a completely unrelated spot, which
1088 * makes me think there is a memory corruption going on.
1089 *
1090 * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking
1091 * it below does not make any difference. It seems to work fine
1092 * with perl5.004_68 but given the probable nature of the bug,
1093 * that does not prove anything.
1094 *
1095 * It's a shame because increasing the amount of buckets raises
1096 * store() throughput by 5%, but until I figure this out, I can't
1097 * allow for this to go into production.
1098 *
1099 * It is reported fixed in 5.005, hence the #if.
1100 */
f0ffaed8 1101#if PERL_VERSION >= 5
7a6a85bf
RG
1102#define HBUCKETS 4096 /* Buckets for %hseen */
1103 HvMAX(cxt->hseen) = HBUCKETS - 1; /* keys %hseen = $HBUCKETS; */
1104#endif
1105
1106 /*
1107 * The `hclass' hash uses the same settings as `hseen' above, but it is
1108 * used to assign sequential tags (numbers) to class names for blessed
1109 * objects.
1110 *
1111 * We turn the shared key optimization on.
1112 */
1113
1114 cxt->hclass = newHV(); /* Where seen classnames are stored */
1115
f0ffaed8 1116#if PERL_VERSION >= 5
7a6a85bf
RG
1117 HvMAX(cxt->hclass) = HBUCKETS - 1; /* keys %hclass = $HBUCKETS; */
1118#endif
1119
1120 /*
1121 * The `hook' hash table is used to keep track of the references on
1122 * the STORABLE_freeze hook routines, when found in some class name.
1123 *
1124 * It is assumed that the inheritance tree will not be changed during
1125 * storing, and that no new method will be dynamically created by the
1126 * hooks.
1127 */
1128
1129 cxt->hook = newHV(); /* Table where hooks are cached */
90826881
JH
1130
1131 /*
1132 * The `hook_seen' array keeps track of all the SVs returned by
1133 * STORABLE_freeze hooks for us to serialize, so that they are not
1134 * reclaimed until the end of the serialization process. Each SV is
1135 * only stored once, the first time it is seen.
1136 */
1137
1138 cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */
7a6a85bf
RG
1139}
1140
1141/*
1142 * clean_store_context
1143 *
1144 * Clean store context by
1145 */
f0ffaed8 1146static void clean_store_context(stcxt_t *cxt)
7a6a85bf
RG
1147{
1148 HE *he;
1149
1150 TRACEME(("clean_store_context"));
1151
1152 ASSERT(cxt->optype & ST_STORE, ("was performing a store()"));
1153
1154 /*
1155 * Insert real values into hashes where we stored faked pointers.
1156 */
1157
e993d95c
JH
1158 if (cxt->hseen) {
1159 hv_iterinit(cxt->hseen);
1160 while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall, grr.. */
1161 HeVAL(he) = &PL_sv_undef;
1162 }
7a6a85bf 1163
e993d95c
JH
1164 if (cxt->hclass) {
1165 hv_iterinit(cxt->hclass);
1166 while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall, grr.. */
1167 HeVAL(he) = &PL_sv_undef;
1168 }
7a6a85bf
RG
1169
1170 /*
1171 * And now dispose of them...
862382c7
JH
1172 *
1173 * The surrounding if() protection has been added because there might be
1174 * some cases where this routine is called more than once, during
1175 * exceptionnal events. This was reported by Marc Lehmann when Storable
1176 * is executed from mod_perl, and the fix was suggested by him.
1177 * -- RAM, 20/12/2000
1178 */
1179
1180 if (cxt->hseen) {
1181 HV *hseen = cxt->hseen;
1182 cxt->hseen = 0;
1183 hv_undef(hseen);
1184 sv_free((SV *) hseen);
1185 }
7a6a85bf 1186
862382c7
JH
1187 if (cxt->hclass) {
1188 HV *hclass = cxt->hclass;
1189 cxt->hclass = 0;
1190 hv_undef(hclass);
1191 sv_free((SV *) hclass);
1192 }
7a6a85bf 1193
862382c7
JH
1194 if (cxt->hook) {
1195 HV *hook = cxt->hook;
1196 cxt->hook = 0;
1197 hv_undef(hook);
1198 sv_free((SV *) hook);
1199 }
7a6a85bf 1200
862382c7
JH
1201 if (cxt->hook_seen) {
1202 AV *hook_seen = cxt->hook_seen;
1203 cxt->hook_seen = 0;
1204 av_undef(hook_seen);
1205 sv_free((SV *) hook_seen);
1206 }
90826881 1207
e8189732
NC
1208 cxt->forgive_me = -1; /* Fetched from perl if needed */
1209 cxt->canonical = -1; /* Idem */
1210
e993d95c 1211 reset_context(cxt);
7a6a85bf
RG
1212}
1213
1214/*
1215 * init_retrieve_context
1216 *
1217 * Initialize a new retrieve context for real recursion.
1218 */
dd19458b 1219static void init_retrieve_context(stcxt_t *cxt, int optype, int is_tainted)
7a6a85bf
RG
1220{
1221 TRACEME(("init_retrieve_context"));
1222
1223 /*
1224 * The hook hash table is used to keep track of the references on
1225 * the STORABLE_thaw hook routines, when found in some class name.
1226 *
1227 * It is assumed that the inheritance tree will not be changed during
1228 * storing, and that no new method will be dynamically created by the
1229 * hooks.
1230 */
1231
1232 cxt->hook = newHV(); /* Caches STORABLE_thaw */
1233
1234 /*
1235 * If retrieving an old binary version, the cxt->retrieve_vtbl variable
1236 * was set to sv_old_retrieve. We'll need a hash table to keep track of
1237 * the correspondance between the tags and the tag number used by the
1238 * new retrieve routines.
1239 */
1240
e16e2ff8 1241 cxt->hseen = ((cxt->retrieve_vtbl == sv_old_retrieve) ? newHV() : 0);
7a6a85bf
RG
1242
1243 cxt->aseen = newAV(); /* Where retrieved objects are kept */
1244 cxt->aclass = newAV(); /* Where seen classnames are kept */
1245 cxt->tagnum = 0; /* Have to count objects... */
1246 cxt->classnum = 0; /* ...and class names as well */
1247 cxt->optype = optype;
dd19458b 1248 cxt->s_tainted = is_tainted;
7a6a85bf 1249 cxt->entry = 1; /* No recursion yet */
530b72ba
NC
1250#ifndef HAS_RESTRICTED_HASHES
1251 cxt->derestrict = -1; /* Fetched from perl if needed */
1252#endif
1253#ifndef HAS_UTF8_ALL
1254 cxt->use_bytes = -1; /* Fetched from perl if needed */
1255#endif
e8189732 1256 cxt->accept_future_minor = -1; /* Fetched from perl if needed */
7a6a85bf
RG
1257}
1258
1259/*
1260 * clean_retrieve_context
1261 *
1262 * Clean retrieve context by
1263 */
dd19458b 1264static void clean_retrieve_context(stcxt_t *cxt)
7a6a85bf
RG
1265{
1266 TRACEME(("clean_retrieve_context"));
1267
1268 ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
1269
862382c7
JH
1270 if (cxt->aseen) {
1271 AV *aseen = cxt->aseen;
1272 cxt->aseen = 0;
1273 av_undef(aseen);
1274 sv_free((SV *) aseen);
1275 }
7a6a85bf 1276
862382c7
JH
1277 if (cxt->aclass) {
1278 AV *aclass = cxt->aclass;
1279 cxt->aclass = 0;
1280 av_undef(aclass);
1281 sv_free((SV *) aclass);
1282 }
7a6a85bf 1283
862382c7
JH
1284 if (cxt->hook) {
1285 HV *hook = cxt->hook;
1286 cxt->hook = 0;
1287 hv_undef(hook);
1288 sv_free((SV *) hook);
1289 }
7a6a85bf 1290
862382c7
JH
1291 if (cxt->hseen) {
1292 HV *hseen = cxt->hseen;
1293 cxt->hseen = 0;
1294 hv_undef(hseen);
1295 sv_free((SV *) hseen); /* optional HV, for backward compat. */
1296 }
7a6a85bf 1297
e8189732
NC
1298#ifndef HAS_RESTRICTED_HASHES
1299 cxt->derestrict = -1; /* Fetched from perl if needed */
1300#endif
1301#ifndef HAS_UTF8_ALL
1302 cxt->use_bytes = -1; /* Fetched from perl if needed */
1303#endif
1304 cxt->accept_future_minor = -1; /* Fetched from perl if needed */
1305
e993d95c 1306 reset_context(cxt);
7a6a85bf
RG
1307}
1308
1309/*
1310 * clean_context
1311 *
1312 * A workaround for the CROAK bug: cleanup the last context.
1313 */
e993d95c 1314static void clean_context(stcxt_t *cxt)
7a6a85bf
RG
1315{
1316 TRACEME(("clean_context"));
1317
dd19458b 1318 ASSERT(cxt->s_dirty, ("dirty context"));
7a6a85bf 1319
e993d95c
JH
1320 if (cxt->membuf_ro)
1321 MBUF_RESTORE();
1322
1323 ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
1324
7a6a85bf
RG
1325 if (cxt->optype & ST_RETRIEVE)
1326 clean_retrieve_context(cxt);
e993d95c 1327 else if (cxt->optype & ST_STORE)
7a6a85bf 1328 clean_store_context(cxt);
e993d95c
JH
1329 else
1330 reset_context(cxt);
862382c7
JH
1331
1332 ASSERT(!cxt->s_dirty, ("context is clean"));
e993d95c 1333 ASSERT(cxt->entry == 0, ("context is reset"));
7a6a85bf
RG
1334}
1335
1336/*
1337 * allocate_context
1338 *
1339 * Allocate a new context and push it on top of the parent one.
1340 * This new context is made globally visible via SET_STCXT().
1341 */
1342static stcxt_t *allocate_context(parent_cxt)
1343stcxt_t *parent_cxt;
1344{
1345 stcxt_t *cxt;
1346
1347 TRACEME(("allocate_context"));
1348
dd19458b 1349 ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
7a6a85bf
RG
1350
1351 Newz(0, cxt, 1, stcxt_t);
1352 cxt->prev = parent_cxt;
1353 SET_STCXT(cxt);
1354
e993d95c
JH
1355 ASSERT(!cxt->s_dirty, ("clean context"));
1356
7a6a85bf
RG
1357 return cxt;
1358}
1359
1360/*
1361 * free_context
1362 *
1363 * Free current context, which cannot be the "root" one.
1364 * Make the context underneath globally visible via SET_STCXT().
1365 */
1366static void free_context(cxt)
1367stcxt_t *cxt;
1368{
1369 stcxt_t *prev = cxt->prev;
1370
1371 TRACEME(("free_context"));
1372
dd19458b 1373 ASSERT(!cxt->s_dirty, ("clean context"));
7a6a85bf
RG
1374 ASSERT(prev, ("not freeing root context"));
1375
1376 if (kbuf)
1377 Safefree(kbuf);
1378 if (mbase)
1379 Safefree(mbase);
1380
1381 Safefree(cxt);
1382 SET_STCXT(prev);
e993d95c
JH
1383
1384 ASSERT(cxt, ("context not void"));
7a6a85bf
RG
1385}
1386
1387/***
1388 *** Predicates.
1389 ***/
1390
1391/*
1392 * is_storing
1393 *
1394 * Tells whether we're in the middle of a store operation.
1395 */
f0ffaed8 1396int is_storing(void)
7a6a85bf
RG
1397{
1398 dSTCXT;
1399
1400 return cxt->entry && (cxt->optype & ST_STORE);
1401}
1402
1403/*
1404 * is_retrieving
1405 *
1406 * Tells whether we're in the middle of a retrieve operation.
1407 */
f0ffaed8 1408int is_retrieving(void)
7a6a85bf
RG
1409{
1410 dSTCXT;
1411
1412 return cxt->entry && (cxt->optype & ST_RETRIEVE);
1413}
1414
1415/*
1416 * last_op_in_netorder
1417 *
1418 * Returns whether last operation was made using network order.
1419 *
1420 * This is typically out-of-band information that might prove useful
1421 * to people wishing to convert native to network order data when used.
1422 */
f0ffaed8 1423int last_op_in_netorder(void)
7a6a85bf
RG
1424{
1425 dSTCXT;
1426
1427 return cxt->netorder;
1428}
1429
1430/***
1431 *** Hook lookup and calling routines.
1432 ***/
1433
1434/*
1435 * pkg_fetchmeth
1436 *
1437 * A wrapper on gv_fetchmethod_autoload() which caches results.
1438 *
1439 * Returns the routine reference as an SV*, or null if neither the package
1440 * nor its ancestors know about the method.
1441 */
f0ffaed8
JH
1442static SV *pkg_fetchmeth(
1443 HV *cache,
1444 HV *pkg,
1445 char *method)
7a6a85bf
RG
1446{
1447 GV *gv;
1448 SV *sv;
7a6a85bf
RG
1449
1450 /*
1451 * The following code is the same as the one performed by UNIVERSAL::can
1452 * in the Perl core.
1453 */
1454
1455 gv = gv_fetchmethod_autoload(pkg, method, FALSE);
1456 if (gv && isGV(gv)) {
1457 sv = newRV((SV*) GvCV(gv));
9e21b3d0 1458 TRACEME(("%s->%s: 0x%"UVxf, HvNAME(pkg), method, PTR2UV(sv)));
7a6a85bf
RG
1459 } else {
1460 sv = newSVsv(&PL_sv_undef);
1461 TRACEME(("%s->%s: not found", HvNAME(pkg), method));
1462 }
1463
1464 /*
1465 * Cache the result, ignoring failure: if we can't store the value,
1466 * it just won't be cached.
1467 */
1468
1469 (void) hv_store(cache, HvNAME(pkg), strlen(HvNAME(pkg)), sv, 0);
1470
1471 return SvOK(sv) ? sv : (SV *) 0;
1472}
1473
1474/*
1475 * pkg_hide
1476 *
1477 * Force cached value to be undef: hook ignored even if present.
1478 */
f0ffaed8
JH
1479static void pkg_hide(
1480 HV *cache,
1481 HV *pkg,
1482 char *method)
7a6a85bf
RG
1483{
1484 (void) hv_store(cache,
1485 HvNAME(pkg), strlen(HvNAME(pkg)), newSVsv(&PL_sv_undef), 0);
1486}
1487
1488/*
212e9bde
JH
1489 * pkg_uncache
1490 *
1491 * Discard cached value: a whole fetch loop will be retried at next lookup.
1492 */
1493static void pkg_uncache(
1494 HV *cache,
1495 HV *pkg,
1496 char *method)
1497{
1498 (void) hv_delete(cache, HvNAME(pkg), strlen(HvNAME(pkg)), G_DISCARD);
1499}
1500
1501/*
7a6a85bf
RG
1502 * pkg_can
1503 *
1504 * Our own "UNIVERSAL::can", which caches results.
1505 *
1506 * Returns the routine reference as an SV*, or null if the object does not
1507 * know about the method.
1508 */
f0ffaed8
JH
1509static SV *pkg_can(
1510 HV *cache,
1511 HV *pkg,
1512 char *method)
7a6a85bf
RG
1513{
1514 SV **svh;
1515 SV *sv;
1516
1517 TRACEME(("pkg_can for %s->%s", HvNAME(pkg), method));
1518
1519 /*
1520 * Look into the cache to see whether we already have determined
1521 * where the routine was, if any.
1522 *
1523 * NOTA BENE: we don't use `method' at all in our lookup, since we know
1524 * that only one hook (i.e. always the same) is cached in a given cache.
1525 */
1526
1527 svh = hv_fetch(cache, HvNAME(pkg), strlen(HvNAME(pkg)), FALSE);
1528 if (svh) {
1529 sv = *svh;
1530 if (!SvOK(sv)) {
1531 TRACEME(("cached %s->%s: not found", HvNAME(pkg), method));
1532 return (SV *) 0;
1533 } else {
43d061fe 1534 TRACEME(("cached %s->%s: 0x%"UVxf,
9e21b3d0 1535 HvNAME(pkg), method, PTR2UV(sv)));
7a6a85bf
RG
1536 return sv;
1537 }
1538 }
1539
1540 TRACEME(("not cached yet"));
1541 return pkg_fetchmeth(cache, pkg, method); /* Fetch and cache */
1542}
1543
1544/*
1545 * scalar_call
1546 *
1547 * Call routine as obj->hook(av) in scalar context.
1548 * Propagates the single returned value if not called in void context.
1549 */
f0ffaed8
JH
1550static SV *scalar_call(
1551 SV *obj,
1552 SV *hook,
1553 int cloning,
1554 AV *av,
1555 I32 flags)
7a6a85bf
RG
1556{
1557 dSP;
1558 int count;
1559 SV *sv = 0;
1560
1561 TRACEME(("scalar_call (cloning=%d)", cloning));
1562
1563 ENTER;
1564 SAVETMPS;
1565
1566 PUSHMARK(sp);
1567 XPUSHs(obj);
1568 XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */
1569 if (av) {
1570 SV **ary = AvARRAY(av);
1571 int cnt = AvFILLp(av) + 1;
1572 int i;
1573 XPUSHs(ary[0]); /* Frozen string */
1574 for (i = 1; i < cnt; i++) {
43d061fe
JH
1575 TRACEME(("pushing arg #%d (0x%"UVxf")...",
1576 i, PTR2UV(ary[i])));
7a6a85bf
RG
1577 XPUSHs(sv_2mortal(newRV(ary[i])));
1578 }
1579 }
1580 PUTBACK;
1581
1582 TRACEME(("calling..."));
1583 count = perl_call_sv(hook, flags); /* Go back to Perl code */
1584 TRACEME(("count = %d", count));
1585
1586 SPAGAIN;
1587
1588 if (count) {
1589 sv = POPs;
1590 SvREFCNT_inc(sv); /* We're returning it, must stay alive! */
1591 }
1592
1593 PUTBACK;
1594 FREETMPS;
1595 LEAVE;
1596
1597 return sv;
1598}
1599
1600/*
1601 * array_call
1602 *
f9a1036d 1603 * Call routine obj->hook(cloning) in list context.
7a6a85bf
RG
1604 * Returns the list of returned values in an array.
1605 */
f0ffaed8
JH
1606static AV *array_call(
1607 SV *obj,
1608 SV *hook,
1609 int cloning)
7a6a85bf
RG
1610{
1611 dSP;
1612 int count;
1613 AV *av;
1614 int i;
1615
f0ffaed8 1616 TRACEME(("array_call (cloning=%d)", cloning));
7a6a85bf
RG
1617
1618 ENTER;
1619 SAVETMPS;
1620
1621 PUSHMARK(sp);
1622 XPUSHs(obj); /* Target object */
1623 XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */
1624 PUTBACK;
1625
1626 count = perl_call_sv(hook, G_ARRAY); /* Go back to Perl code */
1627
1628 SPAGAIN;
1629
1630 av = newAV();
1631 for (i = count - 1; i >= 0; i--) {
1632 SV *sv = POPs;
1633 av_store(av, i, SvREFCNT_inc(sv));
1634 }
1635
1636 PUTBACK;
1637 FREETMPS;
1638 LEAVE;
1639
1640 return av;
1641}
1642
1643/*
1644 * known_class
1645 *
1646 * Lookup the class name in the `hclass' table and either assign it a new ID
1647 * or return the existing one, by filling in `classnum'.
1648 *
1649 * Return true if the class was known, false if the ID was just generated.
1650 */
f0ffaed8
JH
1651static int known_class(
1652 stcxt_t *cxt,
1653 char *name, /* Class name */
1654 int len, /* Name length */
1655 I32 *classnum)
7a6a85bf
RG
1656{
1657 SV **svh;
1658 HV *hclass = cxt->hclass;
1659
1660 TRACEME(("known_class (%s)", name));
1661
1662 /*
1663 * Recall that we don't store pointers in this hash table, but tags.
1664 * Therefore, we need LOW_32BITS() to extract the relevant parts.
1665 */
1666
1667 svh = hv_fetch(hclass, name, len, FALSE);
1668 if (svh) {
1669 *classnum = LOW_32BITS(*svh);
1670 return TRUE;
1671 }
1672
1673 /*
1674 * Unknown classname, we need to record it.
7a6a85bf
RG
1675 */
1676
1677 cxt->classnum++;
3341c981 1678 if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0))
7a6a85bf
RG
1679 CROAK(("Unable to record new classname"));
1680
1681 *classnum = cxt->classnum;
1682 return FALSE;
1683}
1684
1685/***
1686 *** Sepcific store routines.
1687 ***/
1688
1689/*
1690 * store_ref
1691 *
1692 * Store a reference.
1693 * Layout is SX_REF <object> or SX_OVERLOAD <object>.
1694 */
f0ffaed8 1695static int store_ref(stcxt_t *cxt, SV *sv)
7a6a85bf 1696{
43d061fe 1697 TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv)));
7a6a85bf
RG
1698
1699 /*
1700 * Follow reference, and check if target is overloaded.
1701 */
1702
1703 sv = SvRV(sv);
1704
1705 if (SvOBJECT(sv)) {
1706 HV *stash = (HV *) SvSTASH(sv);
1707 if (stash && Gv_AMG(stash)) {
9e21b3d0 1708 TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv)));
7a6a85bf
RG
1709 PUTMARK(SX_OVERLOAD);
1710 } else
1711 PUTMARK(SX_REF);
1712 } else
1713 PUTMARK(SX_REF);
1714
1715 return store(cxt, sv);
1716}
1717
1718/*
1719 * store_scalar
1720 *
1721 * Store a scalar.
1722 *
e16e2ff8 1723 * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
7a6a85bf
RG
1724 * The <data> section is omitted if <length> is 0.
1725 *
1726 * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
1727 * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
1728 */
f0ffaed8 1729static int store_scalar(stcxt_t *cxt, SV *sv)
7a6a85bf
RG
1730{
1731 IV iv;
1732 char *pv;
1733 STRLEN len;
1734 U32 flags = SvFLAGS(sv); /* "cc -O" may put it in register */
1735
43d061fe 1736 TRACEME(("store_scalar (0x%"UVxf")", PTR2UV(sv)));
7a6a85bf
RG
1737
1738 /*
1739 * For efficiency, break the SV encapsulation by peaking at the flags
1740 * directly without using the Perl macros to avoid dereferencing
1741 * sv->sv_flags each time we wish to check the flags.
1742 */
1743
1744 if (!(flags & SVf_OK)) { /* !SvOK(sv) */
1745 if (sv == &PL_sv_undef) {
1746 TRACEME(("immortal undef"));
1747 PUTMARK(SX_SV_UNDEF);
1748 } else {
86bbd6dc 1749 TRACEME(("undef at 0x%"UVxf, PTR2UV(sv)));
7a6a85bf
RG
1750 PUTMARK(SX_UNDEF);
1751 }
1752 return 0;
1753 }
1754
1755 /*
1756 * Always store the string representation of a scalar if it exists.
1757 * Gisle Aas provided me with this test case, better than a long speach:
1758 *
1759 * perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)'
1760 * SV = PVNV(0x80c8520)
1761 * REFCNT = 1
1762 * FLAGS = (NOK,POK,pNOK,pPOK)
1763 * IV = 0
1764 * NV = 0
1765 * PV = 0x80c83d0 "abc"\0
1766 * CUR = 3
1767 * LEN = 4
1768 *
1769 * Write SX_SCALAR, length, followed by the actual data.
1770 *
1771 * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as
1772 * appropriate, followed by the actual (binary) data. A double
1773 * is written as a string if network order, for portability.
1774 *
1775 * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv).
1776 * The reason is that when the scalar value is tainted, the SvNOK(sv)
1777 * value is false.
1778 *
1779 * The test for a read-only scalar with both POK and NOK set is meant
1780 * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the
1781 * address comparison for each scalar we store.
1782 */
1783
1784#define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK)
1785
1786 if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) {
1787 if (sv == &PL_sv_yes) {
1788 TRACEME(("immortal yes"));
1789 PUTMARK(SX_SV_YES);
1790 } else if (sv == &PL_sv_no) {
1791 TRACEME(("immortal no"));
1792 PUTMARK(SX_SV_NO);
1793 } else {
1794 pv = SvPV(sv, len); /* We know it's SvPOK */
1795 goto string; /* Share code below */
1796 }
1797 } else if (flags & SVp_POK) { /* SvPOKp(sv) => string */
cc964657 1798 I32 wlen; /* For 64-bit machines */
7a6a85bf
RG
1799 pv = SvPV(sv, len);
1800
1801 /*
1802 * Will come here from below with pv and len set if double & netorder,
1803 * or from above if it was readonly, POK and NOK but neither &PL_sv_yes
1804 * nor &PL_sv_no.
1805 */
1806 string:
1807
9e21b3d0 1808 wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */
dd19458b
JH
1809 if (SvUTF8 (sv))
1810 STORE_UTF8STR(pv, wlen);
1811 else
1812 STORE_SCALAR(pv, wlen);
d67b2c17 1813 TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")",
5f56cddd 1814 PTR2UV(sv), SvPVX(sv), (IV)len));
7a6a85bf
RG
1815
1816 } else if (flags & SVp_NOK) { /* SvNOKp(sv) => double */
f27e1f0a 1817 NV nv = SvNV(sv);
7a6a85bf
RG
1818
1819 /*
1820 * Watch for number being an integer in disguise.
1821 */
f27e1f0a 1822 if (nv == (NV) (iv = I_V(nv))) {
9e21b3d0 1823 TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv));
7a6a85bf
RG
1824 goto integer; /* Share code below */
1825 }
1826
1827 if (cxt->netorder) {
43d061fe 1828 TRACEME(("double %"NVff" stored as string", nv));
7a6a85bf
RG
1829 pv = SvPV(sv, len);
1830 goto string; /* Share code above */
1831 }
1832
1833 PUTMARK(SX_DOUBLE);
1834 WRITE(&nv, sizeof(nv));
1835
9e21b3d0 1836 TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv));
7a6a85bf
RG
1837
1838 } else if (flags & SVp_IOK) { /* SvIOKp(sv) => integer */
1839 iv = SvIV(sv);
1840
1841 /*
1842 * Will come here from above with iv set if double is an integer.
1843 */
1844 integer:
1845
1846 /*
1847 * Optimize small integers into a single byte, otherwise store as
1848 * a real integer (converted into network order if they asked).
1849 */
1850
1851 if (iv >= -128 && iv <= 127) {
1852 unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
1853 PUTMARK(SX_BYTE);
1854 PUTMARK(siv);
1855 TRACEME(("small integer stored as %d", siv));
1856 } else if (cxt->netorder) {
9e21b3d0 1857 I32 niv;
7a6a85bf 1858#ifdef HAS_HTONL
9e21b3d0 1859 niv = (I32) htonl(iv);
7a6a85bf
RG
1860 TRACEME(("using network order"));
1861#else
9e21b3d0 1862 niv = (I32) iv;
7a6a85bf
RG
1863 TRACEME(("as-is for network order"));
1864#endif
1865 PUTMARK(SX_NETINT);
9e21b3d0 1866 WRITE_I32(niv);
7a6a85bf
RG
1867 } else {
1868 PUTMARK(SX_INTEGER);
1869 WRITE(&iv, sizeof(iv));
1870 }
1871
9e21b3d0 1872 TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv));
7a6a85bf
RG
1873
1874 } else
43d061fe
JH
1875 CROAK(("Can't determine type of %s(0x%"UVxf")",
1876 sv_reftype(sv, FALSE),
1877 PTR2UV(sv)));
7a6a85bf
RG
1878
1879 return 0; /* Ok, no recursion on scalars */
1880}
1881
1882/*
1883 * store_array
1884 *
1885 * Store an array.
1886 *
1887 * Layout is SX_ARRAY <size> followed by each item, in increading index order.
1888 * Each item is stored as <object>.
1889 */
f0ffaed8 1890static int store_array(stcxt_t *cxt, AV *av)
7a6a85bf
RG
1891{
1892 SV **sav;
1893 I32 len = av_len(av) + 1;
1894 I32 i;
1895 int ret;
1896
43d061fe 1897 TRACEME(("store_array (0x%"UVxf")", PTR2UV(av)));
7a6a85bf
RG
1898
1899 /*
1900 * Signal array by emitting SX_ARRAY, followed by the array length.
1901 */
1902
1903 PUTMARK(SX_ARRAY);
1904 WLEN(len);
1905 TRACEME(("size = %d", len));
1906
1907 /*
1908 * Now store each item recursively.
1909 */
1910
1911 for (i = 0; i < len; i++) {
1912 sav = av_fetch(av, i, 0);
1913 if (!sav) {
1914 TRACEME(("(#%d) undef item", i));
1915 STORE_UNDEF();
1916 continue;
1917 }
1918 TRACEME(("(#%d) item", i));
e993d95c 1919 if ((ret = store(cxt, *sav))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
1920 return ret;
1921 }
1922
1923 TRACEME(("ok (array)"));
1924
1925 return 0;
1926}
1927
1928/*
1929 * sortcmp
1930 *
1931 * Sort two SVs
1932 * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
1933 */
1934static int
f0ffaed8 1935sortcmp(const void *a, const void *b)
7a6a85bf
RG
1936{
1937 return sv_cmp(*(SV * const *) a, *(SV * const *) b);
1938}
1939
1940
1941/*
1942 * store_hash
1943 *
d1be9408 1944 * Store a hash table.
7a6a85bf 1945 *
e16e2ff8
NC
1946 * For a "normal" hash (not restricted, no utf8 keys):
1947 *
7a6a85bf
RG
1948 * Layout is SX_HASH <size> followed by each key/value pair, in random order.
1949 * Values are stored as <object>.
1950 * Keys are stored as <length> <data>, the <data> section being omitted
1951 * if length is 0.
c194a0a3
TB
1952 *
1953 * For a "fancy" hash (restricted or utf8 keys):
1954 *
1955 * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair,
e16e2ff8
NC
1956 * in random order.
1957 * Values are stored as <object>.
1958 * Keys are stored as <flags> <length> <data>, the <data> section being omitted
1959 * if length is 0.
1960 * Currently the only hash flag is "restriced"
1961 * Key flags are as for hv.h
7a6a85bf 1962 */
f0ffaed8 1963static int store_hash(stcxt_t *cxt, HV *hv)
7a6a85bf 1964{
530b72ba
NC
1965 I32 len =
1966#ifdef HAS_RESTRICTED_HASHES
1967 HvTOTALKEYS(hv);
1968#else
1969 HvKEYS(hv);
1970#endif
7a6a85bf
RG
1971 I32 i;
1972 int ret = 0;
1973 I32 riter;
1974 HE *eiter;
530b72ba
NC
1975 int flagged_hash = ((SvREADONLY(hv)
1976#ifdef HAS_HASH_KEY_FLAGS
1977 || HvHASKFLAGS(hv)
1978#endif
1979 ) ? 1 : 0);
e16e2ff8 1980 unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
7a6a85bf 1981
e16e2ff8
NC
1982 if (flagged_hash) {
1983 /* needs int cast for C++ compilers, doesn't it? */
1984 TRACEME(("store_hash (0x%"UVxf") (flags %x)", PTR2UV(hv),
1985 (int) hash_flags));
1986 } else {
1987 TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv)));
1988 }
7a6a85bf
RG
1989
1990 /*
1991 * Signal hash by emitting SX_HASH, followed by the table length.
1992 */
1993
e16e2ff8
NC
1994 if (flagged_hash) {
1995 PUTMARK(SX_FLAG_HASH);
1996 PUTMARK(hash_flags);
1997 } else {
1998 PUTMARK(SX_HASH);
1999 }
7a6a85bf
RG
2000 WLEN(len);
2001 TRACEME(("size = %d", len));
2002
2003 /*
2004 * Save possible iteration state via each() on that table.
2005 */
2006
2007 riter = HvRITER(hv);
2008 eiter = HvEITER(hv);
2009 hv_iterinit(hv);
2010
2011 /*
2012 * Now store each item recursively.
2013 *
2014 * If canonical is defined to some true value then store each
2015 * key/value pair in sorted order otherwise the order is random.
2016 * Canonical order is irrelevant when a deep clone operation is performed.
2017 *
2018 * Fetch the value from perl only once per store() operation, and only
2019 * when needed.
2020 */
2021
2022 if (
2023 !(cxt->optype & ST_CLONE) && (cxt->canonical == 1 ||
2024 (cxt->canonical < 0 && (cxt->canonical =
e16e2ff8 2025 (SvTRUE(perl_get_sv("Storable::canonical", TRUE)) ? 1 : 0))))
7a6a85bf
RG
2026 ) {
2027 /*
2028 * Storing in order, sorted by key.
2029 * Run through the hash, building up an array of keys in a
2030 * mortal array, sort the array and then run through the
2031 * array.
2032 */
2033
2034 AV *av = newAV();
2035
e16e2ff8
NC
2036 /*av_extend (av, len);*/
2037
7a6a85bf
RG
2038 TRACEME(("using canonical order"));
2039
2040 for (i = 0; i < len; i++) {
530b72ba 2041#ifdef HAS_RESTRICTED_HASHES
e16e2ff8 2042 HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
530b72ba
NC
2043#else
2044 HE *he = hv_iternext(hv);
2045#endif
7a6a85bf
RG
2046 SV *key = hv_iterkeysv(he);
2047 av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
2048 }
2049
2050 qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
2051
2052 for (i = 0; i < len; i++) {
e16e2ff8 2053 unsigned char flags;
7a6a85bf 2054 char *keyval;
e16e2ff8
NC
2055 STRLEN keylen_tmp;
2056 I32 keylen;
7a6a85bf
RG
2057 SV *key = av_shift(av);
2058 HE *he = hv_fetch_ent(hv, key, 0, 0);
2059 SV *val = HeVAL(he);
2060 if (val == 0)
2061 return 1; /* Internal error, not I/O error */
2062
2063 /*
2064 * Store value first.
2065 */
2066
9e21b3d0 2067 TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
7a6a85bf 2068
e993d95c 2069 if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
2070 goto out;
2071
2072 /*
2073 * Write key string.
2074 * Keys are written after values to make sure retrieval
2075 * can be optimal in terms of memory usage, where keys are
2076 * read into a fixed unique buffer called kbuf.
2077 * See retrieve_hash() for details.
2078 */
2079
e16e2ff8
NC
2080 /* Implementation of restricted hashes isn't nicely
2081 abstracted: */
2082 flags
2083 = (((hash_flags & SHV_RESTRICTED)
2084 && SvREADONLY(val))
2085 ? SHV_K_LOCKED : 0);
2086 if (val == &PL_sv_undef)
2087 flags |= SHV_K_PLACEHOLDER;
2088
2089 keyval = SvPV(key, keylen_tmp);
2090 keylen = keylen_tmp;
530b72ba
NC
2091#ifdef HAS_UTF8_HASHES
2092 /* If you build without optimisation on pre 5.6
2093 then nothing spots that SvUTF8(key) is always 0,
2094 so the block isn't optimised away, at which point
2095 the linker dislikes the reference to
2096 bytes_from_utf8. */
e16e2ff8
NC
2097 if (SvUTF8(key)) {
2098 const char *keysave = keyval;
2099 bool is_utf8 = TRUE;
2100
2101 /* Just casting the &klen to (STRLEN) won't work
2102 well if STRLEN and I32 are of different widths.
2103 --jhi */
2104 keyval = (char*)bytes_from_utf8((U8*)keyval,
2105 &keylen_tmp,
2106 &is_utf8);
2107
2108 /* If we were able to downgrade here, then than
2109 means that we have a key which only had chars
2110 0-255, but was utf8 encoded. */
2111
2112 if (keyval != keysave) {
2113 keylen = keylen_tmp;
2114 flags |= SHV_K_WASUTF8;
2115 } else {
2116 /* keylen_tmp can't have changed, so no need
2117 to assign back to keylen. */
2118 flags |= SHV_K_UTF8;
2119 }
2120 }
530b72ba 2121#endif
e16e2ff8
NC
2122
2123 if (flagged_hash) {
2124 PUTMARK(flags);
2125 TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval));
2126 } else {
2127 assert (flags == 0);
2128 TRACEME(("(#%d) key '%s'", i, keyval));
2129 }
7a6a85bf
RG
2130 WLEN(keylen);
2131 if (keylen)
2132 WRITE(keyval, keylen);
e16e2ff8
NC
2133 if (flags & SHV_K_WASUTF8)
2134 Safefree (keyval);
7a6a85bf
RG
2135 }
2136
2137 /*
2138 * Free up the temporary array
2139 */
2140
2141 av_undef(av);
2142 sv_free((SV *) av);
2143
2144 } else {
2145
2146 /*
2147 * Storing in "random" order (in the order the keys are stored
2148 * within the the hash). This is the default and will be faster!
2149 */
2150
2151 for (i = 0; i < len; i++) {
2152 char *key;
2153 I32 len;
e16e2ff8 2154 unsigned char flags;
530b72ba 2155#ifdef HV_ITERNEXT_WANTPLACEHOLDERS
e16e2ff8 2156 HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
530b72ba
NC
2157#else
2158 HE *he = hv_iternext(hv);
2159#endif
e16e2ff8
NC
2160 SV *val = (he ? hv_iterval(hv, he) : 0);
2161 SV *key_sv = NULL;
2162 HEK *hek;
7a6a85bf
RG
2163
2164 if (val == 0)
2165 return 1; /* Internal error, not I/O error */
2166
2167 /*
2168 * Store value first.
2169 */
2170
9e21b3d0 2171 TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val)));
7a6a85bf 2172
e993d95c 2173 if ((ret = store(cxt, val))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
2174 goto out;
2175
e16e2ff8
NC
2176 /* Implementation of restricted hashes isn't nicely
2177 abstracted: */
2178 flags
2179 = (((hash_flags & SHV_RESTRICTED)
2180 && SvREADONLY(val))
2181 ? SHV_K_LOCKED : 0);
2182 if (val == &PL_sv_undef)
2183 flags |= SHV_K_PLACEHOLDER;
2184
2185 hek = HeKEY_hek(he);
2186 len = HEK_LEN(hek);
2187 if (len == HEf_SVKEY) {
2188 /* This is somewhat sick, but the internal APIs are
2189 * such that XS code could put one of these in in
2190 * a regular hash.
2191 * Maybe we should be capable of storing one if
2192 * found.
2193 */
2194 key_sv = HeKEY_sv(he);
2195 flags |= SHV_K_ISSV;
2196 } else {
2197 /* Regular string key. */
530b72ba 2198#ifdef HAS_HASH_KEY_FLAGS
e16e2ff8
NC
2199 if (HEK_UTF8(hek))
2200 flags |= SHV_K_UTF8;
2201 if (HEK_WASUTF8(hek))
2202 flags |= SHV_K_WASUTF8;
530b72ba 2203#endif
e16e2ff8
NC
2204 key = HEK_KEY(hek);
2205 }
7a6a85bf
RG
2206 /*
2207 * Write key string.
2208 * Keys are written after values to make sure retrieval
2209 * can be optimal in terms of memory usage, where keys are
2210 * read into a fixed unique buffer called kbuf.
2211 * See retrieve_hash() for details.
2212 */
2213
e16e2ff8
NC
2214 if (flagged_hash) {
2215 PUTMARK(flags);
2216 TRACEME(("(#%d) key '%s' flags %x", i, key, flags));
2217 } else {
2218 assert (flags == 0);
2219 TRACEME(("(#%d) key '%s'", i, key));
2220 }
2221 if (flags & SHV_K_ISSV) {
2222 store(cxt, key_sv);
2223 } else {
2224 WLEN(len);
2225 if (len)
7a6a85bf 2226 WRITE(key, len);
e16e2ff8 2227 }
7a6a85bf
RG
2228 }
2229 }
2230
43d061fe 2231 TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv)));
7a6a85bf
RG
2232
2233out:
2234 HvRITER(hv) = riter; /* Restore hash iterator state */
2235 HvEITER(hv) = eiter;
2236
2237 return ret;
2238}
2239
2240/*
2241 * store_tied
2242 *
2243 * When storing a tied object (be it a tied scalar, array or hash), we lay out
2244 * a special mark, followed by the underlying tied object. For instance, when
2245 * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
2246 * <hash object> stands for the serialization of the tied hash.
2247 */
f0ffaed8 2248static int store_tied(stcxt_t *cxt, SV *sv)
7a6a85bf
RG
2249{
2250 MAGIC *mg;
2251 int ret = 0;
2252 int svt = SvTYPE(sv);
2253 char mtype = 'P';
2254
43d061fe 2255 TRACEME(("store_tied (0x%"UVxf")", PTR2UV(sv)));
7a6a85bf
RG
2256
2257 /*
2258 * We have a small run-time penalty here because we chose to factorise
2259 * all tieds objects into the same routine, and not have a store_tied_hash,
2260 * a store_tied_array, etc...
2261 *
2262 * Don't use a switch() statement, as most compilers don't optimize that
2263 * well for 2/3 values. An if() else if() cascade is just fine. We put
2264 * tied hashes first, as they are the most likely beasts.
2265 */
2266
2267 if (svt == SVt_PVHV) {
2268 TRACEME(("tied hash"));
2269 PUTMARK(SX_TIED_HASH); /* Introduces tied hash */
2270 } else if (svt == SVt_PVAV) {
2271 TRACEME(("tied array"));
2272 PUTMARK(SX_TIED_ARRAY); /* Introduces tied array */
2273 } else {
2274 TRACEME(("tied scalar"));
2275 PUTMARK(SX_TIED_SCALAR); /* Introduces tied scalar */
2276 mtype = 'q';
2277 }
2278
2279 if (!(mg = mg_find(sv, mtype)))
2280 CROAK(("No magic '%c' found while storing tied %s", mtype,
2281 (svt == SVt_PVHV) ? "hash" :
2282 (svt == SVt_PVAV) ? "array" : "scalar"));
2283
2284 /*
2285 * The mg->mg_obj found by mg_find() above actually points to the
2286 * underlying tied Perl object implementation. For instance, if the
2287 * original SV was that of a tied array, then mg->mg_obj is an AV.
2288 *
2289 * Note that we store the Perl object as-is. We don't call its FETCH
2290 * method along the way. At retrieval time, we won't call its STORE
2291 * method either, but the tieing magic will be re-installed. In itself,
2292 * that ensures that the tieing semantics are preserved since futher
2293 * accesses on the retrieved object will indeed call the magic methods...
2294 */
2295
e993d95c 2296 if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
2297 return ret;
2298
2299 TRACEME(("ok (tied)"));
2300
2301 return 0;
2302}
2303
2304/*
2305 * store_tied_item
2306 *
2307 * Stores a reference to an item within a tied structure:
2308 *
2309 * . \$h{key}, stores both the (tied %h) object and 'key'.
2310 * . \$a[idx], stores both the (tied @a) object and 'idx'.
2311 *
2312 * Layout is therefore either:
2313 * SX_TIED_KEY <object> <key>
2314 * SX_TIED_IDX <object> <index>
2315 */
f0ffaed8 2316static int store_tied_item(stcxt_t *cxt, SV *sv)
7a6a85bf
RG
2317{
2318 MAGIC *mg;
2319 int ret;
2320
43d061fe 2321 TRACEME(("store_tied_item (0x%"UVxf")", PTR2UV(sv)));
7a6a85bf
RG
2322
2323 if (!(mg = mg_find(sv, 'p')))
2324 CROAK(("No magic 'p' found while storing reference to tied item"));
2325
2326 /*
2327 * We discriminate between \$h{key} and \$a[idx] via mg_ptr.
2328 */
2329
2330 if (mg->mg_ptr) {
2331 TRACEME(("store_tied_item: storing a ref to a tied hash item"));
2332 PUTMARK(SX_TIED_KEY);
9e21b3d0 2333 TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
7a6a85bf 2334
e993d95c 2335 if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
7a6a85bf
RG
2336 return ret;
2337
9e21b3d0 2338 TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr)));
7a6a85bf 2339
e993d95c 2340 if ((ret = store(cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
7a6a85bf
RG
2341 return ret;
2342 } else {
2343 I32 idx = mg->mg_len;
2344
2345 TRACEME(("store_tied_item: storing a ref to a tied array item "));
2346 PUTMARK(SX_TIED_IDX);
9e21b3d0 2347 TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj)));
7a6a85bf 2348
e993d95c 2349 if ((ret = store(cxt, mg->mg_obj))) /* Idem, for -Wall */
7a6a85bf
RG
2350 return ret;
2351
2352 TRACEME(("store_tied_item: storing IDX %d", idx));
2353
2354 WLEN(idx);
2355 }
2356
2357 TRACEME(("ok (tied item)"));
2358
2359 return 0;
2360}
2361
2362/*
2363 * store_hook -- dispatched manually, not via sv_store[]
2364 *
2365 * The blessed SV is serialized by a hook.
2366 *
2367 * Simple Layout is:
2368 *
2369 * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
2370 *
2371 * where <flags> indicates how long <len>, <len2> and <len3> are, whether
2372 * the trailing part [] is present, the type of object (scalar, array or hash).
2373 * There is also a bit which says how the classname is stored between:
2374 *
2375 * <len> <classname>
2376 * <index>
2377 *
2378 * and when the <index> form is used (classname already seen), the "large
2379 * classname" bit in <flags> indicates how large the <index> is.
2380 *
2381 * The serialized string returned by the hook is of length <len2> and comes
2382 * next. It is an opaque string for us.
2383 *
2384 * Those <len3> object IDs which are listed last represent the extra references
2385 * not directly serialized by the hook, but which are linked to the object.
2386 *
2387 * When recursion is mandated to resolve object-IDs not yet seen, we have
2388 * instead, with <header> being flags with bits set to indicate the object type
2389 * and that recursion was indeed needed:
2390 *
2391 * SX_HOOK <header> <object> <header> <object> <flags>
2392 *
2393 * that same header being repeated between serialized objects obtained through
2394 * recursion, until we reach flags indicating no recursion, at which point
2395 * we know we've resynchronized with a single layout, after <flags>.
b12202d0
JH
2396 *
2397 * When storing a blessed ref to a tied variable, the following format is
2398 * used:
2399 *
2400 * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
2401 *
2402 * The first <flags> indication carries an object of type SHT_EXTRA, and the
2403 * real object type is held in the <extra> flag. At the very end of the
2404 * serialization stream, the underlying magic object is serialized, just like
2405 * any other tied variable.
7a6a85bf 2406 */
f0ffaed8
JH
2407static int store_hook(
2408 stcxt_t *cxt,
2409 SV *sv,
2410 int type,
2411 HV *pkg,
2412 SV *hook)
7a6a85bf
RG
2413{
2414 I32 len;
2415 char *class;
2416 STRLEN len2;
2417 SV *ref;
2418 AV *av;
2419 SV **ary;
2420 int count; /* really len3 + 1 */
2421 unsigned char flags;
2422 char *pv;
2423 int i;
2424 int recursed = 0; /* counts recursion */
2425 int obj_type; /* object type, on 2 bits */
2426 I32 classnum;
2427 int ret;
2428 int clone = cxt->optype & ST_CLONE;
e993d95c
JH
2429 char mtype = '\0'; /* for blessed ref to tied structures */
2430 unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */
7a6a85bf
RG
2431
2432 TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum));
2433
2434 /*
2435 * Determine object type on 2 bits.
2436 */
2437
2438 switch (type) {
2439 case svis_SCALAR:
2440 obj_type = SHT_SCALAR;
2441 break;
2442 case svis_ARRAY:
2443 obj_type = SHT_ARRAY;
2444 break;
2445 case svis_HASH:
2446 obj_type = SHT_HASH;
2447 break;
b12202d0
JH
2448 case svis_TIED:
2449 /*
2450 * Produced by a blessed ref to a tied data structure, $o in the
2451 * following Perl code.
2452 *
2453 * my %h;
2454 * tie %h, 'FOO';
2455 * my $o = bless \%h, 'BAR';
2456 *
2457 * Signal the tie-ing magic by setting the object type as SHT_EXTRA
2458 * (since we have only 2 bits in <flags> to store the type), and an
2459 * <extra> byte flag will be emitted after the FIRST <flags> in the
2460 * stream, carrying what we put in `eflags'.
2461 */
2462 obj_type = SHT_EXTRA;
2463 switch (SvTYPE(sv)) {
2464 case SVt_PVHV:
2465 eflags = (unsigned char) SHT_THASH;
2466 mtype = 'P';
2467 break;
2468 case SVt_PVAV:
2469 eflags = (unsigned char) SHT_TARRAY;
2470 mtype = 'P';
2471 break;
2472 default:
2473 eflags = (unsigned char) SHT_TSCALAR;
2474 mtype = 'q';
2475 break;
2476 }
2477 break;
7a6a85bf
RG
2478 default:
2479 CROAK(("Unexpected object type (%d) in store_hook()", type));
2480 }
2481 flags = SHF_NEED_RECURSE | obj_type;
2482
2483 class = HvNAME(pkg);
2484 len = strlen(class);
2485
2486 /*
2487 * To call the hook, we need to fake a call like:
2488 *
2489 * $object->STORABLE_freeze($cloning);
2490 *
2491 * but we don't have the $object here. For instance, if $object is
2492 * a blessed array, what we have in `sv' is the array, and we can't
2493 * call a method on those.
2494 *
2495 * Therefore, we need to create a temporary reference to the object and
2496 * make the call on that reference.
2497 */
2498
2499 TRACEME(("about to call STORABLE_freeze on class %s", class));
2500
2501 ref = newRV_noinc(sv); /* Temporary reference */
2502 av = array_call(ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
2503 SvRV(ref) = 0;
2504 SvREFCNT_dec(ref); /* Reclaim temporary reference */
2505
2506 count = AvFILLp(av) + 1;
2507 TRACEME(("store_hook, array holds %d items", count));
2508
2509 /*
2510 * If they return an empty list, it means they wish to ignore the
2511 * hook for this class (and not just this instance -- that's for them
2512 * to handle if they so wish).
2513 *
2514 * Simply disable the cached entry for the hook (it won't be recomputed
2515 * since it's present in the cache) and recurse to store_blessed().
2516 */
2517
2518 if (!count) {
2519 /*
2520 * They must not change their mind in the middle of a serialization.
2521 */
2522
2523 if (hv_fetch(cxt->hclass, class, len, FALSE))
2524 CROAK(("Too late to ignore hooks for %s class \"%s\"",
2525 (cxt->optype & ST_CLONE) ? "cloning" : "storing", class));
2526
2527 pkg_hide(cxt->hook, pkg, "STORABLE_freeze");
2528
2529 ASSERT(!pkg_can(cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible"));
cc964657 2530 TRACEME(("ignoring STORABLE_freeze in class \"%s\"", class));
7a6a85bf
RG
2531
2532 return store_blessed(cxt, sv, type, pkg);
2533 }
2534
2535 /*
2536 * Get frozen string.
2537 */
2538
2539 ary = AvARRAY(av);
2540 pv = SvPV(ary[0], len2);
2541
2542 /*
7a6a85bf
RG
2543 * If they returned more than one item, we need to serialize some
2544 * extra references if not already done.
2545 *
2546 * Loop over the array, starting at postion #1, and for each item,
2547 * ensure it is a reference, serialize it if not already done, and
2548 * replace the entry with the tag ID of the corresponding serialized
2549 * object.
2550 *
2551 * We CHEAT by not calling av_fetch() and read directly within the
2552 * array, for speed.
2553 */
2554
2555 for (i = 1; i < count; i++) {
2556 SV **svh;
90826881
JH
2557 SV *rsv = ary[i];
2558 SV *xsv;
2559 AV *av_hook = cxt->hook_seen;
7a6a85bf 2560
90826881
JH
2561 if (!SvROK(rsv))
2562 CROAK(("Item #%d returned by STORABLE_freeze "
2563 "for %s is not a reference", i, class));
2564 xsv = SvRV(rsv); /* Follow ref to know what to look for */
7a6a85bf
RG
2565
2566 /*
2567 * Look in hseen and see if we have a tag already.
2568 * Serialize entry if not done already, and get its tag.
2569 */
2570
13689cfe 2571 if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
7a6a85bf
RG
2572 goto sv_seen; /* Avoid moving code too far to the right */
2573
9e21b3d0 2574 TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv)));
7a6a85bf
RG
2575
2576 /*
2577 * We need to recurse to store that object and get it to be known
2578 * so that we can resolve the list of object-IDs at retrieve time.
2579 *
2580 * The first time we do this, we need to emit the proper header
2581 * indicating that we recursed, and what the type of object is (the
2582 * object we're storing via a user-hook). Indeed, during retrieval,
2583 * we'll have to create the object before recursing to retrieve the
2584 * others, in case those would point back at that object.
2585 */
2586
b12202d0
JH
2587 /* [SX_HOOK] <flags> [<extra>] <object>*/
2588 if (!recursed++) {
7a6a85bf 2589 PUTMARK(SX_HOOK);
b12202d0
JH
2590 PUTMARK(flags);
2591 if (obj_type == SHT_EXTRA)
2592 PUTMARK(eflags);
2593 } else
2594 PUTMARK(flags);
7a6a85bf 2595
e993d95c 2596 if ((ret = store(cxt, xsv))) /* Given by hook for us to store */
7a6a85bf
RG
2597 return ret;
2598
2599 svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
2600 if (!svh)
2601 CROAK(("Could not serialize item #%d from hook in %s", i, class));
2602
2603 /*
90826881
JH
2604 * It was the first time we serialized `xsv'.
2605 *
2606 * Keep this SV alive until the end of the serialization: if we
2607 * disposed of it right now by decrementing its refcount, and it was
2608 * a temporary value, some next temporary value allocated during
2609 * another STORABLE_freeze might take its place, and we'd wrongly
2610 * assume that new SV was already serialized, based on its presence
2611 * in cxt->hseen.
2612 *
2613 * Therefore, push it away in cxt->hook_seen.
7a6a85bf
RG
2614 */
2615
90826881
JH
2616 av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv));
2617
7a6a85bf 2618 sv_seen:
90826881
JH
2619 /*
2620 * Dispose of the REF they returned. If we saved the `xsv' away
2621 * in the array of returned SVs, that will not cause the underlying
2622 * referenced SV to be reclaimed.
2623 */
2624
2625 ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF"));
2626 SvREFCNT_dec(rsv); /* Dispose of reference */
2627
2628 /*
2629 * Replace entry with its tag (not a real SV, so no refcnt increment)
2630 */
2631
7a6a85bf 2632 ary[i] = *svh;
76edffbb 2633 TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf,
d67b2c17 2634 i-1, PTR2UV(xsv), PTR2UV(*svh)));
7a6a85bf
RG
2635 }
2636
2637 /*
dd19458b
JH
2638 * Allocate a class ID if not already done.
2639 *
2640 * This needs to be done after the recursion above, since at retrieval
2641 * time, we'll see the inner objects first. Many thanks to
2642 * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and
2643 * proposed the right fix. -- RAM, 15/09/2000
2644 */
2645
2646 if (!known_class(cxt, class, len, &classnum)) {
2647 TRACEME(("first time we see class %s, ID = %d", class, classnum));
2648 classnum = -1; /* Mark: we must store classname */
2649 } else {
2650 TRACEME(("already seen class %s, ID = %d", class, classnum));
2651 }
2652
2653 /*
7a6a85bf
RG
2654 * Compute leading flags.
2655 */
2656
2657 flags = obj_type;
2658 if (((classnum == -1) ? len : classnum) > LG_SCALAR)
2659 flags |= SHF_LARGE_CLASSLEN;
2660 if (classnum != -1)
2661 flags |= SHF_IDX_CLASSNAME;
2662 if (len2 > LG_SCALAR)
2663 flags |= SHF_LARGE_STRLEN;
2664 if (count > 1)
2665 flags |= SHF_HAS_LIST;
2666 if (count > (LG_SCALAR + 1))
2667 flags |= SHF_LARGE_LISTLEN;
2668
2669 /*
2670 * We're ready to emit either serialized form:
2671 *
2672 * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
2673 * SX_HOOK <flags> <index> <len2> <str> [<len3> <object-IDs>]
2674 *
2675 * If we recursed, the SX_HOOK has already been emitted.
2676 */
2677
9e21b3d0
JH
2678 TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
2679 "class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d",
d67b2c17 2680 recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
7a6a85bf 2681
b12202d0
JH
2682 /* SX_HOOK <flags> [<extra>] */
2683 if (!recursed) {
7a6a85bf 2684 PUTMARK(SX_HOOK);
b12202d0
JH
2685 PUTMARK(flags);
2686 if (obj_type == SHT_EXTRA)
2687 PUTMARK(eflags);
2688 } else
2689 PUTMARK(flags);
7a6a85bf
RG
2690
2691 /* <len> <classname> or <index> */
2692 if (flags & SHF_IDX_CLASSNAME) {
2693 if (flags & SHF_LARGE_CLASSLEN)
2694 WLEN(classnum);
2695 else {
2696 unsigned char cnum = (unsigned char) classnum;
2697 PUTMARK(cnum);
2698 }
2699 } else {
2700 if (flags & SHF_LARGE_CLASSLEN)
2701 WLEN(len);
2702 else {
2703 unsigned char clen = (unsigned char) len;
2704 PUTMARK(clen);
2705 }
2706 WRITE(class, len); /* Final \0 is omitted */
2707 }
2708
2709 /* <len2> <frozen-str> */
cc964657
JH
2710 if (flags & SHF_LARGE_STRLEN) {
2711 I32 wlen2 = len2; /* STRLEN might be 8 bytes */
2712 WLEN(wlen2); /* Must write an I32 for 64-bit machines */
2713 } else {
7a6a85bf
RG
2714 unsigned char clen = (unsigned char) len2;
2715 PUTMARK(clen);
2716 }
2717 if (len2)
7c436af3 2718 WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */
7a6a85bf
RG
2719
2720 /* [<len3> <object-IDs>] */
2721 if (flags & SHF_HAS_LIST) {
2722 int len3 = count - 1;
2723 if (flags & SHF_LARGE_LISTLEN)
2724 WLEN(len3);
2725 else {
2726 unsigned char clen = (unsigned char) len3;
2727 PUTMARK(clen);
2728 }
2729
2730 /*
2731 * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a
2732 * real pointer, rather a tag number, well under the 32-bit limit.
2733 */
2734
2735 for (i = 1; i < count; i++) {
2736 I32 tagval = htonl(LOW_32BITS(ary[i]));
9e21b3d0 2737 WRITE_I32(tagval);
7a6a85bf
RG
2738 TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
2739 }
2740 }
2741
2742 /*
2743 * Free the array. We need extra care for indices after 0, since they
2744 * don't hold real SVs but integers cast.
2745 */
2746
2747 if (count > 1)
2748 AvFILLp(av) = 0; /* Cheat, nothing after 0 interests us */
2749 av_undef(av);
2750 sv_free((SV *) av);
2751
b12202d0
JH
2752 /*
2753 * If object was tied, need to insert serialization of the magic object.
2754 */
2755
2756 if (obj_type == SHT_EXTRA) {
2757 MAGIC *mg;
2758
2759 if (!(mg = mg_find(sv, mtype))) {
2760 int svt = SvTYPE(sv);
2761 CROAK(("No magic '%c' found while storing ref to tied %s with hook",
2762 mtype, (svt == SVt_PVHV) ? "hash" :
2763 (svt == SVt_PVAV) ? "array" : "scalar"));
2764 }
2765
2766 TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf,
2767 PTR2UV(mg->mg_obj), PTR2UV(sv)));
2768
2769 /*
2770 * [<magic object>]
2771 */
2772
e993d95c 2773 if ((ret = store(cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
b12202d0
JH
2774 return ret;
2775 }
2776
7a6a85bf
RG
2777 return 0;
2778}
2779
2780/*
2781 * store_blessed -- dispatched manually, not via sv_store[]
2782 *
2783 * Check whether there is a STORABLE_xxx hook defined in the class or in one
2784 * of its ancestors. If there is, then redispatch to store_hook();
2785 *
2786 * Otherwise, the blessed SV is stored using the following layout:
2787 *
2788 * SX_BLESS <flag> <len> <classname> <object>
2789 *
2790 * where <flag> indicates whether <len> is stored on 0 or 4 bytes, depending
2791 * on the high-order bit in flag: if 1, then length follows on 4 bytes.
2792 * Otherwise, the low order bits give the length, thereby giving a compact
2793 * representation for class names less than 127 chars long.
2794 *
2795 * Each <classname> seen is remembered and indexed, so that the next time
2796 * an object in the blessed in the same <classname> is stored, the following
2797 * will be emitted:
2798 *
2799 * SX_IX_BLESS <flag> <index> <object>
2800 *
2801 * where <index> is the classname index, stored on 0 or 4 bytes depending
2802 * on the high-order bit in flag (same encoding as above for <len>).
2803 */
f0ffaed8
JH
2804static int store_blessed(
2805 stcxt_t *cxt,
2806 SV *sv,
2807 int type,
2808 HV *pkg)
7a6a85bf
RG
2809{
2810 SV *hook;
2811 I32 len;
2812 char *class;
2813 I32 classnum;
2814
2815 TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME(pkg)));
2816
2817 /*
2818 * Look for a hook for this blessed SV and redirect to store_hook()
2819 * if needed.
2820 */
2821
2822 hook = pkg_can(cxt->hook, pkg, "STORABLE_freeze");
2823 if (hook)
2824 return store_hook(cxt, sv, type, pkg, hook);
2825
2826 /*
2827 * This is a blessed SV without any serialization hook.
2828 */
2829
2830 class = HvNAME(pkg);
2831 len = strlen(class);
2832
43d061fe
JH
2833 TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d",
2834 PTR2UV(sv), class, cxt->tagnum));
7a6a85bf
RG
2835
2836 /*
2837 * Determine whether it is the first time we see that class name (in which
2838 * case it will be stored in the SX_BLESS form), or whether we already
2839 * saw that class name before (in which case the SX_IX_BLESS form will be
2840 * used).
2841 */
2842
2843 if (known_class(cxt, class, len, &classnum)) {
2844 TRACEME(("already seen class %s, ID = %d", class, classnum));
2845 PUTMARK(SX_IX_BLESS);
2846 if (classnum <= LG_BLESS) {
2847 unsigned char cnum = (unsigned char) classnum;
2848 PUTMARK(cnum);
2849 } else {
2850 unsigned char flag = (unsigned char) 0x80;
2851 PUTMARK(flag);
2852 WLEN(classnum);
2853 }
2854 } else {
2855 TRACEME(("first time we see class %s, ID = %d", class, classnum));
2856 PUTMARK(SX_BLESS);
2857 if (len <= LG_BLESS) {
2858 unsigned char clen = (unsigned char) len;
2859 PUTMARK(clen);
2860 } else {
2861 unsigned char flag = (unsigned char) 0x80;
2862 PUTMARK(flag);
2863 WLEN(len); /* Don't BER-encode, this should be rare */
2864 }
2865 WRITE(class, len); /* Final \0 is omitted */
2866 }
2867
2868 /*
2869 * Now emit the <object> part.
2870 */
2871
2872 return SV_STORE(type)(cxt, sv);
2873}
2874
2875/*
2876 * store_other
2877 *
2878 * We don't know how to store the item we reached, so return an error condition.
2879 * (it's probably a GLOB, some CODE reference, etc...)
2880 *
2881 * If they defined the `forgive_me' variable at the Perl level to some
2882 * true value, then don't croak, just warn, and store a placeholder string
2883 * instead.
2884 */
f0ffaed8 2885static int store_other(stcxt_t *cxt, SV *sv)
7a6a85bf 2886{
cc964657 2887 I32 len;
7a6a85bf
RG
2888 static char buf[80];
2889
2890 TRACEME(("store_other"));
2891
2892 /*
2893 * Fetch the value from perl only once per store() operation.
2894 */
2895
2896 if (
2897 cxt->forgive_me == 0 ||
2898 (cxt->forgive_me < 0 && !(cxt->forgive_me =
2899 SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0))
2900 )
2901 CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
2902
43d061fe
JH
2903 warn("Can't store item %s(0x%"UVxf")",
2904 sv_reftype(sv, FALSE), PTR2UV(sv));
7a6a85bf
RG
2905
2906 /*
2907 * Store placeholder string as a scalar instead...
2908 */
2909
13689cfe 2910 (void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE),
e993d95c 2911 PTR2UV(sv), (char) 0);
7a6a85bf
RG
2912
2913 len = strlen(buf);
2914 STORE_SCALAR(buf, len);
86bbd6dc 2915 TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, len));
7a6a85bf
RG
2916
2917 return 0;
2918}
2919
2920/***
2921 *** Store driving routines
2922 ***/
2923
2924/*
2925 * sv_type
2926 *
2927 * WARNING: partially duplicates Perl's sv_reftype for speed.
2928 *
2929 * Returns the type of the SV, identified by an integer. That integer
2930 * may then be used to index the dynamic routine dispatch table.
2931 */
f0ffaed8 2932static int sv_type(SV *sv)
7a6a85bf
RG
2933{
2934 switch (SvTYPE(sv)) {
2935 case SVt_NULL:
2936 case SVt_IV:
2937 case SVt_NV:
2938 /*
2939 * No need to check for ROK, that can't be set here since there
2940 * is no field capable of hodling the xrv_rv reference.
2941 */
2942 return svis_SCALAR;
2943 case SVt_PV:
2944 case SVt_RV:
2945 case SVt_PVIV:
2946 case SVt_PVNV:
2947 /*
2948 * Starting from SVt_PV, it is possible to have the ROK flag
2949 * set, the pointer to the other SV being either stored in
2950 * the xrv_rv (in the case of a pure SVt_RV), or as the
2951 * xpv_pv field of an SVt_PV and its heirs.
2952 *
2953 * However, those SV cannot be magical or they would be an
2954 * SVt_PVMG at least.
2955 */
2956 return SvROK(sv) ? svis_REF : svis_SCALAR;
2957 case SVt_PVMG:
2958 case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */
2959 if (SvRMAGICAL(sv) && (mg_find(sv, 'p')))
2960 return svis_TIED_ITEM;
2961 /* FALL THROUGH */
2962 case SVt_PVBM:
2963 if (SvRMAGICAL(sv) && (mg_find(sv, 'q')))
2964 return svis_TIED;
2965 return SvROK(sv) ? svis_REF : svis_SCALAR;
2966 case SVt_PVAV:
2967 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
2968 return svis_TIED;
2969 return svis_ARRAY;
2970 case SVt_PVHV:
2971 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
2972 return svis_TIED;
2973 return svis_HASH;
2974 default:
2975 break;
2976 }
2977
2978 return svis_OTHER;
2979}
2980
2981/*
2982 * store
2983 *
2984 * Recursively store objects pointed to by the sv to the specified file.
2985 *
2986 * Layout is <content> or SX_OBJECT <tagnum> if we reach an already stored
2987 * object (one for which storage has started -- it may not be over if we have
2988 * a self-referenced structure). This data set forms a stored <object>.
2989 */
f0ffaed8 2990static int store(stcxt_t *cxt, SV *sv)
7a6a85bf
RG
2991{
2992 SV **svh;
2993 int ret;
7a6a85bf 2994 int type;
43d061fe 2995 HV *hseen = cxt->hseen;
7a6a85bf 2996
43d061fe 2997 TRACEME(("store (0x%"UVxf")", PTR2UV(sv)));
7a6a85bf
RG
2998
2999 /*
3000 * If object has already been stored, do not duplicate data.
3001 * Simply emit the SX_OBJECT marker followed by its tag data.
3002 * The tag is always written in network order.
3003 *
3004 * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a
3005 * real pointer, rather a tag number (watch the insertion code below).
3006 * That means it pobably safe to assume it is well under the 32-bit limit,
3007 * and makes the truncation safe.
3008 * -- RAM, 14/09/1999
3009 */
3010
3011 svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
3012 if (svh) {
3013 I32 tagval = htonl(LOW_32BITS(*svh));
3014
9e21b3d0 3015 TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval)));
7a6a85bf
RG
3016
3017 PUTMARK(SX_OBJECT);
9e21b3d0 3018 WRITE_I32(tagval);
7a6a85bf
RG
3019 return 0;
3020 }
3021
3022 /*
3023 * Allocate a new tag and associate it with the address of the sv being
3024 * stored, before recursing...
3025 *
3026 * In order to avoid creating new SvIVs to hold the tagnum we just
d1be9408 3027 * cast the tagnum to an SV pointer and store that in the hash. This
7a6a85bf
RG
3028 * means that we must clean up the hash manually afterwards, but gives
3029 * us a 15% throughput increase.
3030 *
7a6a85bf
RG
3031 */
3032
3033 cxt->tagnum++;
3034 if (!hv_store(hseen,
3341c981 3035 (char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0))
7a6a85bf
RG
3036 return -1;
3037
3038 /*
3039 * Store `sv' and everything beneath it, using appropriate routine.
3040 * Abort immediately if we get a non-zero status back.
3041 */
3042
3043 type = sv_type(sv);
3044
43d061fe
JH
3045 TRACEME(("storing 0x%"UVxf" tag #%d, type %d...",
3046 PTR2UV(sv), cxt->tagnum, type));
7a6a85bf
RG
3047
3048 if (SvOBJECT(sv)) {
3049 HV *pkg = SvSTASH(sv);
3050 ret = store_blessed(cxt, sv, type, pkg);
3051 } else
3052 ret = SV_STORE(type)(cxt, sv);
3053
43d061fe
JH
3054 TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)",
3055 ret ? "FAILED" : "ok", PTR2UV(sv),
7a6a85bf
RG
3056 SvREFCNT(sv), sv_reftype(sv, FALSE)));
3057
3058 return ret;
3059}
3060
3061/*
3062 * magic_write
3063 *
3064 * Write magic number and system information into the file.
3065 * Layout is <magic> <network> [<len> <byteorder> <sizeof int> <sizeof long>
3066 * <sizeof ptr>] where <len> is the length of the byteorder hexa string.
3067 * All size and lenghts are written as single characters here.
3068 *
3069 * Note that no byte ordering info is emitted when <network> is true, since
3070 * integers will be emitted in network order in that case.
3071 */
f0ffaed8 3072static int magic_write(stcxt_t *cxt)
7a6a85bf
RG
3073{
3074 char buf[256]; /* Enough room for 256 hexa digits */
3075 unsigned char c;
3076 int use_network_order = cxt->netorder;
3077
e16e2ff8
NC
3078 TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio)
3079 : -1));
7a6a85bf
RG
3080
3081 if (cxt->fio)
7c436af3 3082 WRITE(magicstr, (SSize_t)strlen(magicstr)); /* Don't write final \0 */
7a6a85bf
RG
3083
3084 /*
3085 * Starting with 0.6, the "use_network_order" byte flag is also used to
3086 * indicate the version number of the binary image, encoded in the upper
3087 * bits. The bit 0 is always used to indicate network order.
3088 */
3089
3090 c = (unsigned char)
3091 ((use_network_order ? 0x1 : 0x0) | (STORABLE_BIN_MAJOR << 1));
3092 PUTMARK(c);
3093
3094 /*
3095 * Starting with 0.7, a full byte is dedicated to the minor version of
3096 * the binary format, which is incremented only when new markers are
3097 * introduced, for instance, but when backward compatibility is preserved.
3098 */
3099
530b72ba 3100 PUTMARK((unsigned char) STORABLE_BIN_WRITE_MINOR);
7a6a85bf
RG
3101
3102 if (use_network_order)
3103 return 0; /* Don't bother with byte ordering */
3104
3105 sprintf(buf, "%lx", (unsigned long) BYTEORDER);
3106 c = (unsigned char) strlen(buf);
3107 PUTMARK(c);
7c436af3 3108 WRITE(buf, (SSize_t)c); /* Don't write final \0 */
7a6a85bf
RG
3109 PUTMARK((unsigned char) sizeof(int));
3110 PUTMARK((unsigned char) sizeof(long));
3111 PUTMARK((unsigned char) sizeof(char *));
9e21b3d0 3112 PUTMARK((unsigned char) sizeof(NV));
7a6a85bf 3113
9e21b3d0 3114 TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
43d061fe 3115 (unsigned long) BYTEORDER, (int) c,
9e21b3d0
JH
3116 (int) sizeof(int), (int) sizeof(long),
3117 (int) sizeof(char *), (int) sizeof(NV)));
7a6a85bf
RG
3118
3119 return 0;
3120}
3121
3122/*
3123 * do_store
3124 *
3125 * Common code for store operations.
3126 *
3127 * When memory store is requested (f = NULL) and a non null SV* is given in
3128 * `res', it is filled with a new SV created out of the memory buffer.
3129 *
3130 * It is required to provide a non-null `res' when the operation type is not
3131 * dclone() and store() is performed to memory.
3132 */
f0ffaed8
JH
3133static int do_store(
3134 PerlIO *f,
3135 SV *sv,
3136 int optype,
3137 int network_order,
3138 SV **res)
7a6a85bf
RG
3139{
3140 dSTCXT;
3141 int status;
3142
3143 ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res,
3144 ("must supply result SV pointer for real recursion to memory"));
3145
3146 TRACEME(("do_store (optype=%d, netorder=%d)",
3147 optype, network_order));
3148
3149 optype |= ST_STORE;
3150
3151 /*
3152 * Workaround for CROAK leak: if they enter with a "dirty" context,
3153 * free up memory for them now.
3154 */
3155
dd19458b 3156 if (cxt->s_dirty)
7a6a85bf
RG
3157 clean_context(cxt);
3158
3159 /*
3160 * Now that STORABLE_xxx hooks exist, it is possible that they try to
3161 * re-enter store() via the hooks. We need to stack contexts.
3162 */
3163
3164 if (cxt->entry)
3165 cxt = allocate_context(cxt);
3166
3167 cxt->entry++;
3168
3169 ASSERT(cxt->entry == 1, ("starting new recursion"));
dd19458b 3170 ASSERT(!cxt->s_dirty, ("clean context"));
7a6a85bf
RG
3171
3172 /*
3173 * Ensure sv is actually a reference. From perl, we called something
3174 * like:
3175 * pstore(FILE, \@array);
3176 * so we must get the scalar value behing that reference.
3177 */
3178
3179 if (!SvROK(sv))
3180 CROAK(("Not a reference"));
3181 sv = SvRV(sv); /* So follow it to know what to store */
3182
3183 /*
3184 * If we're going to store to memory, reset the buffer.
3185 */
3186
3187 if (!f)
3188 MBUF_INIT(0);
3189
3190 /*
3191 * Prepare context and emit headers.
3192 */
3193
3194 init_store_context(cxt, f, optype, network_order);
3195
3196 if (-1 == magic_write(cxt)) /* Emit magic and ILP info */
3197 return 0; /* Error */
3198
3199 /*
3200 * Recursively store object...
3201 */
3202
3203 ASSERT(is_storing(), ("within store operation"));
3204
3205 status = store(cxt, sv); /* Just do it! */
3206
3207 /*
3208 * If they asked for a memory store and they provided an SV pointer,
3209 * make an SV string out of the buffer and fill their pointer.
3210 *
3211 * When asking for ST_REAL, it's MANDATORY for the caller to provide
3212 * an SV, since context cleanup might free the buffer if we did recurse.
3213 * (unless caller is dclone(), which is aware of that).
3214 */
3215
3216 if (!cxt->fio && res)
3217 *res = mbuf2sv();
3218
3219 /*
3220 * Final cleanup.
3221 *
3222 * The "root" context is never freed, since it is meant to be always
3223 * handy for the common case where no recursion occurs at all (i.e.
3224 * we enter store() outside of any Storable code and leave it, period).
3225 * We know it's the "root" context because there's nothing stacked
3226 * underneath it.
3227 *
3228 * OPTIMIZATION:
3229 *
3230 * When deep cloning, we don't free the context: doing so would force
3231 * us to copy the data in the memory buffer. Sicne we know we're
3232 * about to enter do_retrieve...
3233 */
3234
3235 clean_store_context(cxt);
3236 if (cxt->prev && !(cxt->optype & ST_CLONE))
3237 free_context(cxt);
3238
3239 TRACEME(("do_store returns %d", status));
3240
3241 return status == 0;
3242}
3243
3244/*
3245 * pstore
3246 *
3247 * Store the transitive data closure of given object to disk.
3248 * Returns 0 on error, a true value otherwise.
3249 */
f0ffaed8 3250int pstore(PerlIO *f, SV *sv)
7a6a85bf
RG
3251{
3252 TRACEME(("pstore"));
f0ffaed8 3253 return do_store(f, sv, 0, FALSE, (SV**) 0);
7a6a85bf
RG
3254
3255}
3256
3257/*
3258 * net_pstore
3259 *
3260 * Same as pstore(), but network order is used for integers and doubles are
3261 * emitted as strings.
3262 */
f0ffaed8 3263int net_pstore(PerlIO *f, SV *sv)
7a6a85bf
RG
3264{
3265 TRACEME(("net_pstore"));
f0ffaed8 3266 return do_store(f, sv, 0, TRUE, (SV**) 0);
7a6a85bf
RG
3267}
3268
3269/***
3270 *** Memory stores.
3271 ***/
3272
3273/*
3274 * mbuf2sv
3275 *
3276 * Build a new SV out of the content of the internal memory buffer.
3277 */
f0ffaed8 3278static SV *mbuf2sv(void)
7a6a85bf
RG
3279{
3280 dSTCXT;
3281
3282 return newSVpv(mbase, MBUF_SIZE());
3283}
3284
3285/*
3286 * mstore
3287 *
3288 * Store the transitive data closure of given object to memory.
3289 * Returns undef on error, a scalar value containing the data otherwise.
3290 */
f0ffaed8 3291SV *mstore(SV *sv)
7a6a85bf 3292{
7a6a85bf
RG
3293 SV *out;
3294
3295 TRACEME(("mstore"));
3296
f0ffaed8 3297 if (!do_store((PerlIO*) 0, sv, 0, FALSE, &out))
7a6a85bf
RG
3298 return &PL_sv_undef;
3299
3300 return out;
3301}
3302
3303/*
3304 * net_mstore
3305 *
3306 * Same as mstore(), but network order is used for integers and doubles are
3307 * emitted as strings.
3308 */
f0ffaed8 3309SV *net_mstore(SV *sv)
7a6a85bf 3310{
7a6a85bf
RG
3311 SV *out;
3312
3313 TRACEME(("net_mstore"));
3314
f0ffaed8 3315 if (!do_store((PerlIO*) 0, sv, 0, TRUE, &out))
7a6a85bf
RG
3316 return &PL_sv_undef;
3317
3318 return out;
3319}
3320
3321/***
3322 *** Specific retrieve callbacks.
3323 ***/
3324
3325/*
3326 * retrieve_other
3327 *
3328 * Return an error via croak, since it is not possible that we get here
3329 * under normal conditions, when facing a file produced via pstore().
3330 */
b12202d0 3331static SV *retrieve_other(stcxt_t *cxt, char *cname)
7a6a85bf
RG
3332{
3333 if (
3334 cxt->ver_major != STORABLE_BIN_MAJOR &&
3335 cxt->ver_minor != STORABLE_BIN_MINOR
3336 ) {
3337 CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d",
3338 cxt->fio ? "file" : "string",
3339 cxt->ver_major, cxt->ver_minor,
3340 STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
3341 } else {
3342 CROAK(("Corrupted storable %s (binary v%d.%d)",
3343 cxt->fio ? "file" : "string",
3344 cxt->ver_major, cxt->ver_minor));
3345 }
3346
3347 return (SV *) 0; /* Just in case */
3348}
3349
3350/*
3351 * retrieve_idx_blessed
3352 *
3353 * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
3354 * <index> can be coded on either 1 or 5 bytes.
3355 */
b12202d0 3356static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname)
7a6a85bf
RG
3357{
3358 I32 idx;
3359 char *class;
3360 SV **sva;
3361 SV *sv;
3362
3363 TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum));
b12202d0 3364 ASSERT(!cname, ("no bless-into class given here, got %s", cname));
7a6a85bf
RG
3365
3366 GETMARK(idx); /* Index coded on a single char? */
3367 if (idx & 0x80)
3368 RLEN(idx);
3369
3370 /*
3371 * Fetch classname in `aclass'
3372 */
3373
3374 sva = av_fetch(cxt->aclass, idx, FALSE);
3375 if (!sva)
e993d95c 3376 CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx));
7a6a85bf
RG
3377
3378 class = SvPVX(*sva); /* We know it's a PV, by construction */
3379
3380 TRACEME(("class ID %d => %s", idx, class));
3381
3382 /*
3383 * Retrieve object and bless it.
3384 */
3385
b12202d0 3386 sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */
7a6a85bf
RG
3387
3388 return sv;
3389}
3390
3391/*
3392 * retrieve_blessed
3393 *
3394 * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
3395 * <len> can be coded on either 1 or 5 bytes.
3396 */
b12202d0 3397static SV *retrieve_blessed(stcxt_t *cxt, char *cname)
7a6a85bf
RG
3398{
3399 I32 len;
3400 SV *sv;
3401 char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
3402 char *class = buf;
3403
3404 TRACEME(("retrieve_blessed (#%d)", cxt->tagnum));
b12202d0 3405 ASSERT(!cname, ("no bless-into class given here, got %s", cname));
7a6a85bf
RG
3406
3407 /*
3408 * Decode class name length and read that name.
3409 *
3410 * Short classnames have two advantages: their length is stored on one
3411 * single byte, and the string can be read on the stack.
3412 */
3413
3414 GETMARK(len); /* Length coded on a single char? */
3415 if (len & 0x80) {
3416 RLEN(len);
3417 TRACEME(("** allocating %d bytes for class name", len+1));
3418 New(10003, class, len+1, char);
3419 }
3420 READ(class, len);
3421 class[len] = '\0'; /* Mark string end */
3422
3423 /*
3424 * It's a new classname, otherwise it would have been an SX_IX_BLESS.
3425 */
3426
b12202d0
JH
3427 TRACEME(("new class name \"%s\" will bear ID = %d", class, cxt->classnum));
3428
7a6a85bf
RG
3429 if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
3430 return (SV *) 0;
3431
3432 /*
3433 * Retrieve object and bless it.
3434 */
3435
b12202d0
JH
3436 sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */
3437 if (class != buf)
3438 Safefree(class);
7a6a85bf
RG
3439
3440 return sv;
3441}
3442
3443/*
3444 * retrieve_hook
3445 *
3446 * Layout: SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
3447 * with leading mark already read, as usual.
3448 *
3449 * When recursion was involved during serialization of the object, there
3450 * is an unknown amount of serialized objects after the SX_HOOK mark. Until
3451 * we reach a <flags> marker with the recursion bit cleared.
b12202d0
JH
3452 *
3453 * If the first <flags> byte contains a type of SHT_EXTRA, then the real type
3454 * is held in the <extra> byte, and if the object is tied, the serialized
3455 * magic object comes at the very end:
3456 *
3457 * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
3458 *
3459 * This means the STORABLE_thaw hook will NOT get a tied variable during its
3460 * processing (since we won't have seen the magic object by the time the hook
3461 * is called). See comments below for why it was done that way.
7a6a85bf 3462 */
b12202d0 3463static SV *retrieve_hook(stcxt_t *cxt, char *cname)
7a6a85bf
RG
3464{
3465 I32 len;
3466 char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
3467 char *class = buf;
3468 unsigned int flags;
3469 I32 len2;
3470 SV *frozen;
3471 I32 len3 = 0;
3472 AV *av = 0;
3473 SV *hook;
3474 SV *sv;
3475 SV *rv;
3476 int obj_type;
7a6a85bf 3477 int clone = cxt->optype & ST_CLONE;
b12202d0
JH
3478 char mtype = '\0';
3479 unsigned int extra_type = 0;
7a6a85bf
RG
3480
3481 TRACEME(("retrieve_hook (#%d)", cxt->tagnum));
b12202d0 3482 ASSERT(!cname, ("no bless-into class given here, got %s", cname));
7a6a85bf
RG
3483
3484 /*
3485 * Read flags, which tell us about the type, and whether we need to recurse.
3486 */
3487
3488 GETMARK(flags);
3489
3490 /*
3491 * Create the (empty) object, and mark it as seen.
3492 *
3493 * This must be done now, because tags are incremented, and during
3494 * serialization, the object tag was affected before recursion could
3495 * take place.
3496 */
3497
3498 obj_type = flags & SHF_TYPE_MASK;
3499 switch (obj_type) {
3500 case SHT_SCALAR:
3501 sv = newSV(0);
3502 break;
3503 case SHT_ARRAY:
3504 sv = (SV *) newAV();
3505 break;
3506 case SHT_HASH:
3507 sv = (SV *) newHV();
3508 break;
b12202d0
JH
3509 case SHT_EXTRA:
3510 /*
3511 * Read <extra> flag to know the type of the object.
3512 * Record associated magic type for later.
3513 */
3514 GETMARK(extra_type);
3515 switch (extra_type) {
3516 case SHT_TSCALAR:
3517 sv = newSV(0);
3518 mtype = 'q';
3519 break;
3520 case SHT_TARRAY:
3521 sv = (SV *) newAV();
3522 mtype = 'P';
3523 break;
3524 case SHT_THASH:
3525 sv = (SV *) newHV();
3526 mtype = 'P';
3527 break;
3528 default:
3529 return retrieve_other(cxt, 0); /* Let it croak */
3530 }
3531 break;
7a6a85bf 3532 default:
b12202d0 3533 return retrieve_other(cxt, 0); /* Let it croak */
7a6a85bf 3534 }
b12202d0 3535 SEEN(sv, 0); /* Don't bless yet */
7a6a85bf
RG
3536
3537 /*
3538 * Whilst flags tell us to recurse, do so.
3539 *
3540 * We don't need to remember the addresses returned by retrieval, because
3541 * all the references will be obtained through indirection via the object
3542 * tags in the object-ID list.
3543 */
3544
3545 while (flags & SHF_NEED_RECURSE) {
3546 TRACEME(("retrieve_hook recursing..."));
b12202d0 3547 rv = retrieve(cxt, 0);
7a6a85bf
RG
3548 if (!rv)
3549 return (SV *) 0;
43d061fe
JH
3550 TRACEME(("retrieve_hook back with rv=0x%"UVxf,
3551 PTR2UV(rv)));
7a6a85bf
RG
3552 GETMARK(flags);
3553 }
3554
3555 if (flags & SHF_IDX_CLASSNAME) {
3556 SV **sva;
3557 I32 idx;
3558
3559 /*
3560 * Fetch index from `aclass'
3561 */
3562
3563 if (flags & SHF_LARGE_CLASSLEN)
3564 RLEN(idx);
3565 else
3566 GETMARK(idx);
3567
3568 sva = av_fetch(cxt->aclass, idx, FALSE);
3569 if (!sva)
e993d95c
JH
3570 CROAK(("Class name #%"IVdf" should have been seen already",
3571 (IV) idx));
7a6a85bf
RG
3572
3573 class = SvPVX(*sva); /* We know it's a PV, by construction */
3574 TRACEME(("class ID %d => %s", idx, class));
3575
3576 } else {
3577 /*
3578 * Decode class name length and read that name.
3579 *
3580 * NOTA BENE: even if the length is stored on one byte, we don't read
3581 * on the stack. Just like retrieve_blessed(), we limit the name to
3582 * LG_BLESS bytes. This is an arbitrary decision.
3583 */
3584
3585 if (flags & SHF_LARGE_CLASSLEN)
3586 RLEN(len);
3587 else
3588 GETMARK(len);
3589
3590 if (len > LG_BLESS) {
3591 TRACEME(("** allocating %d bytes for class name", len+1));
3592 New(10003, class, len+1, char);
3593 }
3594
3595 READ(class, len);
3596 class[len] = '\0'; /* Mark string end */
3597
3598 /*
3599 * Record new classname.
3600 */
3601
3602 if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len)))
3603 return (SV *) 0;
3604 }
3605
3606 TRACEME(("class name: %s", class));
3607
3608 /*
d1be9408 3609 * Decode user-frozen string length and read it in an SV.
7a6a85bf
RG
3610 *
3611 * For efficiency reasons, we read data directly into the SV buffer.
3612 * To understand that code, read retrieve_scalar()
3613 */
3614
3615 if (flags & SHF_LARGE_STRLEN)
3616 RLEN(len2);
3617 else
3618 GETMARK(len2);
3619
3620 frozen = NEWSV(10002, len2);
3621 if (len2) {
3622 SAFEREAD(SvPVX(frozen), len2, frozen);
3623 SvCUR_set(frozen, len2);
3624 *SvEND(frozen) = '\0';
3625 }
3626 (void) SvPOK_only(frozen); /* Validates string pointer */
dd19458b
JH
3627 if (cxt->s_tainted) /* Is input source tainted? */
3628 SvTAINT(frozen);
7a6a85bf
RG
3629
3630 TRACEME(("frozen string: %d bytes", len2));
3631
3632 /*
3633 * Decode object-ID list length, if present.
3634 */
3635
3636 if (flags & SHF_HAS_LIST) {
3637 if (flags & SHF_LARGE_LISTLEN)
3638 RLEN(len3);
3639 else
3640 GETMARK(len3);
3641 if (len3) {
3642 av = newAV();
3643 av_extend(av, len3 + 1); /* Leave room for [0] */
3644 AvFILLp(av) = len3; /* About to be filled anyway */
3645 }
3646 }
3647
3648 TRACEME(("has %d object IDs to link", len3));
3649
3650 /*
3651 * Read object-ID list into array.
3652 * Because we pre-extended it, we can cheat and fill it manually.
3653 *
3654 * We read object tags and we can convert them into SV* on the fly
3655 * because we know all the references listed in there (as tags)
3656 * have been already serialized, hence we have a valid correspondance
3657 * between each of those tags and the recreated SV.
3658 */
3659
3660 if (av) {
3661 SV **ary = AvARRAY(av);
3662 int i;
3663 for (i = 1; i <= len3; i++) { /* We leave [0] alone */
3664 I32 tag;
3665 SV **svh;
3666 SV *xsv;
3667
9e21b3d0 3668 READ_I32(tag);
7a6a85bf
RG
3669 tag = ntohl(tag);
3670 svh = av_fetch(cxt->aseen, tag, FALSE);
3671 if (!svh)
e993d95c
JH
3672 CROAK(("Object #%"IVdf" should have been retrieved already",
3673 (IV) tag));
7a6a85bf
RG
3674 xsv = *svh;
3675 ary[i] = SvREFCNT_inc(xsv);
3676 }
3677 }
3678
3679 /*
3680 * Bless the object and look up the STORABLE_thaw hook.
3681 */
3682
3683 BLESS(sv, class);
3684 hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
212e9bde
JH
3685 if (!hook) {
3686 /*
3687 * Hook not found. Maybe they did not require the module where this
3688 * hook is defined yet?
3689 *
3690 * If the require below succeeds, we'll be able to find the hook.
3691 * Still, it only works reliably when each class is defined in a
3692 * file of its own.
3693 */
3694
3695 SV *psv = newSVpvn("require ", 8);
3696 sv_catpv(psv, class);
3697
3698 TRACEME(("No STORABLE_thaw defined for objects of class %s", class));
3699 TRACEME(("Going to require module '%s' with '%s'", class, SvPVX(psv)));
3700
3701 perl_eval_sv(psv, G_DISCARD);
3702 sv_free(psv);
3703
3704 /*
3705 * We cache results of pkg_can, so we need to uncache before attempting
3706 * the lookup again.
3707 */
3708
3709 pkg_uncache(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
3710 hook = pkg_can(cxt->hook, SvSTASH(sv), "STORABLE_thaw");
3711
3712 if (!hook)
3713 CROAK(("No STORABLE_thaw defined for objects of class %s "
3714 "(even after a \"require %s;\")", class, class));
3715 }
7a6a85bf
RG
3716
3717 /*
3718 * If we don't have an `av' yet, prepare one.
3719 * Then insert the frozen string as item [0].
3720 */
3721
3722 if (!av) {
3723 av = newAV();
3724 av_extend(av, 1);
3725 AvFILLp(av) = 0;
3726 }
3727 AvARRAY(av)[0] = SvREFCNT_inc(frozen);
3728
3729 /*
3730 * Call the hook as:
3731 *
3732 * $object->STORABLE_thaw($cloning, $frozen, @refs);
3733 *
3734 * where $object is our blessed (empty) object, $cloning is a boolean
3735 * telling whether we're running a deep clone, $frozen is the frozen
3736 * string the user gave us in his serializing hook, and @refs, which may
3737 * be empty, is the list of extra references he returned along for us
3738 * to serialize.
3739 *
3740 * In effect, the hook is an alternate creation routine for the class,
3741 * the object itself being already created by the runtime.
3742 */
3743
86bbd6dc 3744 TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)",
43d061fe 3745 class, PTR2UV(sv), AvFILLp(av) + 1));
7a6a85bf
RG
3746
3747 rv = newRV(sv);
3748 (void) scalar_call(rv, hook, clone, av, G_SCALAR|G_DISCARD);
3749 SvREFCNT_dec(rv);
3750
3751 /*
3752 * Final cleanup.
3753 */
3754
3755 SvREFCNT_dec(frozen);
3756 av_undef(av);
3757 sv_free((SV *) av);
3758 if (!(flags & SHF_IDX_CLASSNAME) && class != buf)
3759 Safefree(class);
3760
b12202d0
JH
3761 /*
3762 * If we had an <extra> type, then the object was not as simple, and
3763 * we need to restore extra magic now.
3764 */
3765
3766 if (!extra_type)
3767 return sv;
3768
3769 TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv)));
3770
3771 rv = retrieve(cxt, 0); /* Retrieve <magic object> */
3772
3773 TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf,
3774 PTR2UV(rv), PTR2UV(sv)));
3775
3776 switch (extra_type) {
3777 case SHT_TSCALAR:
3778 sv_upgrade(sv, SVt_PVMG);
3779 break;
3780 case SHT_TARRAY:
3781 sv_upgrade(sv, SVt_PVAV);
3782 AvREAL_off((AV *)sv);
3783 break;
3784 case SHT_THASH:
3785 sv_upgrade(sv, SVt_PVHV);
3786 break;
3787 default:
3788 CROAK(("Forgot to deal with extra type %d", extra_type));
3789 break;
3790 }
3791
3792 /*
3793 * Adding the magic only now, well after the STORABLE_thaw hook was called
3794 * means the hook cannot know it deals with an object whose variable is
3795 * tied. But this is happening when retrieving $o in the following case:
3796 *
3797 * my %h;
3798 * tie %h, 'FOO';
3799 * my $o = bless \%h, 'BAR';
3800 *
3801 * The 'BAR' class is NOT the one where %h is tied into. Therefore, as
3802 * far as the 'BAR' class is concerned, the fact that %h is not a REAL
3803 * hash but a tied one should not matter at all, and remain transparent.
3804 * This means the magic must be restored by Storable AFTER the hook is
3805 * called.
3806 *
3807 * That looks very reasonable to me, but then I've come up with this
3808 * after a bug report from David Nesting, who was trying to store such
3809 * an object and caused Storable to fail. And unfortunately, it was
3810 * also the easiest way to retrofit support for blessed ref to tied objects
3811 * into the existing design. -- RAM, 17/02/2001
3812 */
3813
3814 sv_magic(sv, rv, mtype, Nullch, 0);
3815 SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */
3816
7a6a85bf
RG
3817 return sv;
3818}
3819
3820/*
3821 * retrieve_ref
3822 *
3823 * Retrieve reference to some other scalar.
3824 * Layout is SX_REF <object>, with SX_REF already read.
3825 */
b12202d0 3826static SV *retrieve_ref(stcxt_t *cxt, char *cname)
7a6a85bf
RG
3827{
3828 SV *rv;
3829 SV *sv;
3830
3831 TRACEME(("retrieve_ref (#%d)", cxt->tagnum));
3832
3833 /*
3834 * We need to create the SV that holds the reference to the yet-to-retrieve
3835 * object now, so that we may record the address in the seen table.
3836 * Otherwise, if the object to retrieve references us, we won't be able
3837 * to resolve the SX_OBJECT we'll see at that point! Hence we cannot
3838 * do the retrieve first and use rv = newRV(sv) since it will be too late
3839 * for SEEN() recording.
3840 */
3841
3842 rv = NEWSV(10002, 0);
b12202d0
JH
3843 SEEN(rv, cname); /* Will return if rv is null */
3844 sv = retrieve(cxt, 0); /* Retrieve <object> */
7a6a85bf
RG
3845 if (!sv)
3846 return (SV *) 0; /* Failed */
3847
3848 /*
3849 * WARNING: breaks RV encapsulation.
3850 *
3851 * Now for the tricky part. We have to upgrade our existing SV, so that
3852 * it is now an RV on sv... Again, we cheat by duplicating the code
3853 * held in newSVrv(), since we already got our SV from retrieve().
3854 *
3855 * We don't say:
3856 *
3857 * SvRV(rv) = SvREFCNT_inc(sv);
3858 *
3859 * here because the reference count we got from retrieve() above is
3860 * already correct: if the object was retrieved from the file, then
3861 * its reference count is one. Otherwise, if it was retrieved via
3862 * an SX_OBJECT indication, a ref count increment was done.
3863 */
3864
3865 sv_upgrade(rv, SVt_RV);
3866 SvRV(rv) = sv; /* $rv = \$sv */
3867 SvROK_on(rv);
3868
43d061fe 3869 TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv)));
7a6a85bf
RG
3870
3871 return rv;
3872}
3873
3874/*
3875 * retrieve_overloaded