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