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