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