1 /* -*- c-basic-offset: 4 -*-
2 *
3 * Fast store and retrieve mechanism.
4 *
5 * Copyright (c) 1995-2000, Raphael Manfredi
6 * Copyright (c) 2016, 2017 cPanel Inc
7 * Copyright (c) 2017 Reini Urban
8 *
9 * You may redistribute only under the same terms as Perl 5, as specified
10 * in the README file that comes with the distribution.
11 *
12 */
13
14 #define PERL_NO_GET_CONTEXT /* we want efficiency */
15 #include <EXTERN.h>
16 #include <perl.h>
17 #include <XSUB.h>
18
19 #ifndef PATCHLEVEL
20 #include <patchlevel.h> /* Perl's one, needed since 5.6 */
21 #endif
22
23 #if !defined(PERL_VERSION) || PERL_VERSION < 10 || (PERL_VERSION == 10 && PERL_SUBVERSION < 1)
24 #define NEED_PL_parser
25 #define NEED_sv_2pv_flags
26 #define NEED_load_module
27 #define NEED_vload_module
28 #define NEED_newCONSTSUB
29 #define NEED_newSVpvn_flags
30 #define NEED_newRV_noinc
31 #include "ppport.h" /* handle old perls */
32 #endif
33
34 #ifdef DEBUGGING
35 #define DEBUGME /* Debug mode, turns assertions on as well */
36 #define DASSERT /* Assertion mode */
37 #endif
38
39 /*
40 * Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined
41 * Provide them with the necessary defines so they can build with pre-5.004.
42 */
43 #ifndef USE_PERLIO
44 #ifndef PERLIO_IS_STDIO
45 #define PerlIO FILE
46 #define PerlIO_getc(x) getc(x)
47 #define PerlIO_putc(f,x) putc(x,f)
48 #define PerlIO_read(x,y,z) fread(y,1,z,x)
49 #define PerlIO_write(x,y,z) fwrite(y,1,z,x)
50 #define PerlIO_stdoutf printf
51 #endif /* PERLIO_IS_STDIO */
52 #endif /* USE_PERLIO */
53
54 /*
55 * Earlier versions of perl might be used, we can't assume they have the latest!
56 */
57
58 #ifndef HvSHAREKEYS_off
59 #define HvSHAREKEYS_off(hv) /* Ignore */
60 #endif
61
62 /* perl <= 5.8.2 needs this */
63 #ifndef SvIsCOW
64 # define SvIsCOW(sv) 0
65 #endif
66
67 #ifndef HvRITER_set
68 # define HvRITER_set(hv,r) (HvRITER(hv) = r)
69 #endif
70 #ifndef HvEITER_set
71 # define HvEITER_set(hv,r) (HvEITER(hv) = r)
72 #endif
73
74 #ifndef HvRITER_get
75 # define HvRITER_get HvRITER
76 #endif
77 #ifndef HvEITER_get
78 # define HvEITER_get HvEITER
79 #endif
80
81 #ifndef HvPLACEHOLDERS_get
82 # define HvPLACEHOLDERS_get HvPLACEHOLDERS
83 #endif
84
85 #ifndef HvTOTALKEYS
86 # define HvTOTALKEYS(hv) HvKEYS(hv)
87 #endif
88 /* 5.6 */
89 #ifndef HvUSEDKEYS
90 # define HvUSEDKEYS(hv) HvKEYS(hv)
91 #endif
92
93 #ifdef SVf_IsCOW
94 # define SvTRULYREADONLY(sv) SvREADONLY(sv)
95 #else
96 # define SvTRULYREADONLY(sv) (SvREADONLY(sv) && !SvIsCOW(sv))
97 #endif
98
99 #ifndef SvPVCLEAR
100 # define SvPVCLEAR(sv) sv_setpvs(sv, "")
101 #endif
102
103 #ifndef strEQc
104 # define strEQc(s,c) memEQ(s, ("" c ""), sizeof(c))
105 #endif
106
107 #ifdef DEBUGME
108
109 #ifndef DASSERT
110 #define DASSERT
111 #endif
112
113 /*
114 * TRACEME() will only output things when the $Storable::DEBUGME is true,
115 * using the value traceme cached in the context.
116 *
117 *
118 * TRACEMED() directly looks at the variable, for use before traceme has been
119 * updated.
120 */
121
122 #define TRACEME(x) \
123 STMT_START { \
124 if (cxt->traceme) \
125 { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
126 } STMT_END
127
128 #define TRACEMED(x) \
129 STMT_START { \
130 if (SvTRUE(get_sv("Storable::DEBUGME", GV_ADD))) \
131 { PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
132 } STMT_END
133
134 #define INIT_TRACEME \
135 STMT_START { \
136 cxt->traceme = SvTRUE(get_sv("Storable::DEBUGME", GV_ADD)); \
137 } STMT_END
138
139 #else
140 #define TRACEME(x)
141 #define TRACEMED(x)
142 #define INIT_TRACEME
143 #endif /* DEBUGME */
144
145 #ifdef DASSERT
146 #define ASSERT(x,y) \
147 STMT_START { \
148 if (!(x)) { \
149 PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \
150 __FILE__, (int)__LINE__); \
151 PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \
152 } \
153 } STMT_END
154 #else
155 #define ASSERT(x,y)
156 #endif
157
158 /*
159 * Type markers.
160 */
161
162 #define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */
163
164 #define SX_OBJECT C(0) /* Already stored object */
165 #define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */
166 #define SX_ARRAY C(2) /* Array forthcoming (size, item list) */
167 #define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */
168 #define SX_REF C(4) /* Reference to object forthcoming */
169 #define SX_UNDEF C(5) /* Undefined scalar */
170 #define SX_INTEGER C(6) /* Integer forthcoming */
171 #define SX_DOUBLE C(7) /* Double forthcoming */
172 #define SX_BYTE C(8) /* (signed) byte forthcoming */
173 #define SX_NETINT C(9) /* Integer in network order forthcoming */
174 #define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */
175 #define SX_TIED_ARRAY C(11) /* Tied array forthcoming */
176 #define SX_TIED_HASH C(12) /* Tied hash forthcoming */
177 #define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */
178 #define SX_SV_UNDEF C(14) /* Perl's immortal PL_sv_undef */
179 #define SX_SV_YES C(15) /* Perl's immortal PL_sv_yes */
180 #define SX_SV_NO C(16) /* Perl's immortal PL_sv_no */
181 #define SX_BLESS C(17) /* Object is blessed */
182 #define SX_IX_BLESS C(18) /* Object is blessed, classname given by index */
183 #define SX_HOOK C(19) /* Stored via hook, user-defined */
184 #define SX_OVERLOAD C(20) /* Overloaded reference */
185 #define SX_TIED_KEY C(21) /* Tied magic key forthcoming */
186 #define SX_TIED_IDX C(22) /* Tied magic index forthcoming */
187 #define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */
188 #define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */
189 #define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
190 #define SX_CODE C(26) /* Code references as perl source code */
191 #define SX_WEAKREF C(27) /* Weak reference to object forthcoming */
192 #define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */
193 #define SX_VSTRING C(29) /* vstring forthcoming (small) */
194 #define SX_LVSTRING C(30) /* vstring forthcoming (large) */
195 #define SX_SVUNDEF_ELEM C(31) /* array element set to &PL_sv_undef */
196 #define SX_REGEXP C(32) /* Regexp */
197 #define SX_LOBJECT C(33) /* Large object: string, array or hash (size >2G) */
198 #define SX_LAST C(34) /* invalid. marker only */
199
200 /*
201 * Those are only used to retrieve "old" pre-0.6 binary images.
202 */
203 #define SX_ITEM 'i' /* An array item introducer */
204 #define SX_IT_UNDEF 'I' /* Undefined array item */
205 #define SX_KEY 'k' /* A hash key introducer */
206 #define SX_VALUE 'v' /* A hash value introducer */
207 #define SX_VL_UNDEF 'V' /* Undefined hash value */
208
209 /*
210 * Those are only used to retrieve "old" pre-0.7 binary images
211 */
212
213 #define SX_CLASS 'b' /* Object is blessed, class name length <255 */
214 #define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */
215 #define SX_STORED 'X' /* End of object */
216
217 /*
218 * Limits between short/long length representation.
219 */
220
221 #define LG_SCALAR 255 /* Large scalar length limit */
222 #define LG_BLESS 127 /* Large classname bless limit */
223
224 /*
225 * Operation types
226 */
227
228 #define ST_STORE 0x1 /* Store operation */
229 #define ST_RETRIEVE 0x2 /* Retrieval operation */
230 #define ST_CLONE 0x4 /* Deep cloning operation */
231
232 /*
233 * The following structure is used for hash table key retrieval. Since, when
234 * retrieving objects, we'll be facing blessed hash references, it's best
235 * to pre-allocate that buffer once and resize it as the need arises, never
236 * freeing it (keys will be saved away someplace else anyway, so even large
237 * keys are not enough a motivation to reclaim that space).
238 *
239 * This structure is also used for memory store/retrieve operations which
240 * happen in a fixed place before being malloc'ed elsewhere if persistence
241 * is required. Hence the aptr pointer.
242 */
243 struct extendable {
244 char *arena; /* Will hold hash key strings, resized as needed */
245 STRLEN asiz; /* Size of aforementioned buffer */
246 char *aptr; /* Arena pointer, for in-place read/write ops */
247 char *aend; /* First invalid address */
248 };
249
250 /*
251 * At store time:
252 * A hash table records the objects which have already been stored.
253 * Those are referred to as SX_OBJECT in the file, and their "tag" (i.e.
254 * an arbitrary sequence number) is used to identify them.
255 *
256 * At retrieve time:
257 * An array table records the objects which have already been retrieved,
258 * as seen by the tag determined by counting the objects themselves. The
259 * reference to that retrieved object is kept in the table, and is returned
260 * when an SX_OBJECT is found bearing that same tag.
261 *
262 * The same processing is used to record "classname" for blessed objects:
263 * indexing by a hash at store time, and via an array at retrieve time.
264 */
265
266 typedef unsigned long stag_t; /* Used by pre-0.6 binary format */
267
268 /*
269 * Make the tag type 64-bit on 64-bit platforms.
270 *
271 * If the tag number is low enough it's stored as a 32-bit value, but
272 * with very large arrays and hashes it's possible to go over 2**32
273 * scalars.
274 */
275
276 typedef STRLEN ntag_t;
277
278 /* used for where_is_undef - marks an unset value */
279 #define UNSET_NTAG_T (~(ntag_t)0)
280
281 /*
282 * The following "thread-safe" related defines were contributed by
283 * Murray Nesbitt <murray@activestate.com> and integrated by RAM, who
284 * only renamed things a little bit to ensure consistency with surrounding
285 * code. -- RAM, 14/09/1999
286 *
287 * The original patch suffered from the fact that the stcxt_t structure
288 * was global. Murray tried to minimize the impact on the code as much as
289 * possible.
290 *
291 * Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks
292 * on objects. Therefore, the notion of context needs to be generalized,
293 * threading or not.
294 */
295
296 #define MY_VERSION "Storable(" XS_VERSION ")"
297
298
299 /*
300 * Conditional UTF8 support.
301 *
302 */
303 #ifdef SvUTF8_on
304 #define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
305 #define HAS_UTF8_SCALARS
306 #ifdef HeKUTF8
307 #define HAS_UTF8_HASHES
308 #define HAS_UTF8_ALL
309 #else
310 /* 5.6 perl has utf8 scalars but not hashes */
311 #endif
312 #else
313 #define SvUTF8(sv) 0
314 #define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl"))
315 #endif
316 #ifndef HAS_UTF8_ALL
317 #define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
318 #endif
319 #ifndef SvWEAKREF
320 #define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl"))
321 #endif
322 #ifndef SvVOK
323 #define VSTRING_CROAK() CROAK(("Cannot retrieve vstring in this perl"))
324 #endif
325
326 #ifdef HvPLACEHOLDERS
327 #define HAS_RESTRICTED_HASHES
328 #else
329 #define HVhek_PLACEHOLD 0x200
330 #define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash"))
331 #endif
332
333 #ifdef HvHASKFLAGS
334 #define HAS_HASH_KEY_FLAGS
335 #endif
336
337 #ifdef ptr_table_new
338 #define USE_PTR_TABLE
339 #endif
340
341 /* do we need/want to clear padding on NVs? */
342 #if defined(LONG_DOUBLEKIND) && defined(USE_LONG_DOUBLE)
343 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
344 LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
345 # define NV_PADDING (NVSIZE - 10)
346 # else
347 # define NV_PADDING 0
348 # endif
349 #else
350 /* This is kind of a guess - it means we'll get an unneeded clear on 128-bit NV
351 but an upgraded perl will fix that
352 */
353 # if NVSIZE > 8
354 # define NV_CLEAR
355 # endif
356 # define NV_PADDING 0
357 #endif
358
359 typedef union {
360 NV nv;
361 U8 bytes[sizeof(NV)];
362 } NV_bytes;
363
364 /* Needed for 32bit with lengths > 2G - 4G, and 64bit */
365 #if PTRSIZE > 4
366 #define HAS_U64
367 #endif
368
369 /*
370 * Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
371 * files remap tainted and dirty when threading is enabled. That's bad for
372 * perl to remap such common words. -- RAM, 29/09/00
373 */
374
375 struct stcxt;
376 typedef struct stcxt {
377 int entry; /* flags recursion */
378 int optype; /* type of traversal operation */
379 /* which objects have been seen, store time.
380 tags are numbers, which are cast to (SV *) and stored directly */
381 #ifdef USE_PTR_TABLE
382 /* use pseen if we have ptr_tables. We have to store tag+1, because
383 tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table
384 without it being confused for a fetch lookup failure. */
385 struct ptr_tbl *pseen;
386 /* Still need hseen for the 0.6 file format code. */
387 #endif
388 HV *hseen;
389 AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */
390 AV *aseen; /* which objects have been seen, retrieve time */
391 ntag_t where_is_undef; /* index in aseen of PL_sv_undef */
392 HV *hclass; /* which classnames have been seen, store time */
393 AV *aclass; /* which classnames have been seen, retrieve time */
394 HV *hook; /* cache for hook methods per class name */
395 IV tagnum; /* incremented at store time for each seen object */
396 IV classnum; /* incremented at store time for each seen classname */
397 int netorder; /* true if network order used */
398 int s_tainted; /* true if input source is tainted, at retrieve time */
399 int forgive_me; /* whether to be forgiving... */
400 int deparse; /* whether to deparse code refs */
401 SV *eval; /* whether to eval source code */
402 int canonical; /* whether to store hashes sorted by key */
403 #ifndef HAS_RESTRICTED_HASHES
404 int derestrict; /* whether to downgrade restricted hashes */
405 #endif
406 #ifndef HAS_UTF8_ALL
407 int use_bytes; /* whether to bytes-ify utf8 */
408 #endif
409 int accept_future_minor; /* croak immediately on future minor versions? */
410 int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
411 int membuf_ro; /* true means membuf is read-only and msaved is rw */
412 struct extendable keybuf; /* for hash key retrieval */
413 struct extendable membuf; /* for memory store/retrieve operations */
414 struct extendable msaved; /* where potentially valid mbuf is saved */
415 PerlIO *fio; /* where I/O are performed, NULL for memory */
416 int ver_major; /* major of version for retrieved object */
417 int ver_minor; /* minor of version for retrieved object */
418 SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */
419 SV *prev; /* contexts chained backwards in real recursion */
420 SV *my_sv; /* the blessed scalar who's SvPVX() I am */
421
422 /* recur_sv:
423
424 A hashref of hashrefs or arrayref of arrayrefs is actually a
425 chain of four SVs, eg for an array ref containing an array ref:
426
427 RV -> AV (element) -> RV -> AV
428
429 To make this depth appear natural from a perl level we only
430 want to count this as two levels, so store_ref() stores it's RV
431 into recur_sv and store_array()/store_hash() will only count
432 that level if the AV/HV *isn't* recur_sv.
433
434 We can't just have store_hash()/store_array() not count that
435 level, since it's possible for XS code to store an AV or HV
436 directly as an element (though perl code trying to access such
437 an object will generally croak.)
438 */
439 SV *recur_sv; /* check only one recursive SV */
440 int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */
441 int flags; /* controls whether to bless or tie objects */
442 IV recur_depth; /* avoid stack overflows RT #97526 */
443 IV max_recur_depth; /* limit for recur_depth */
444 IV max_recur_depth_hash; /* limit for recur_depth for hashes */
445 #ifdef DEBUGME
446 int traceme; /* TRACEME() produces output */
447 #endif
448 } stcxt_t;
449
450 #define RECURSION_TOO_DEEP() \
451 (cxt->max_recur_depth != -1 && ++cxt->recur_depth > cxt->max_recur_depth)
452
453 /* There's cases where we need to check whether the hash recursion
454 limit has been reached without bumping the recursion levels, so the
455 hash check doesn't bump the depth.
456 */
457 #define RECURSION_TOO_DEEP_HASH() \
458 (cxt->max_recur_depth_hash != -1 && cxt->recur_depth > cxt->max_recur_depth_hash)
459 #define MAX_DEPTH_ERROR "Max. recursion depth with nested structures exceeded"
460
461 static int storable_free(pTHX_ SV *sv, MAGIC* mg);
462
463 static MGVTBL vtbl_storable = {
464 NULL, /* get */
465 NULL, /* set */
466 NULL, /* len */
467 NULL, /* clear */
468 storable_free,
469 #ifdef MGf_COPY
470 NULL, /* copy */
471 #endif
472 #ifdef MGf_DUP
473 NULL, /* dup */
474 #endif
475 #ifdef MGf_LOCAL
476 NULL /* local */
477 #endif
478 };
479
480 /* From Digest::MD5. */
481 #ifndef sv_magicext
482 # define sv_magicext(sv, obj, type, vtbl, name, namlen) \
483 THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen)
THX_sv_magicext(pTHX_ SV * sv,SV * obj,int type,MGVTBL const * vtbl,char const * name,I32 namlen)484 static MAGIC *THX_sv_magicext(pTHX_
485 SV *sv, SV *obj, int type,
486 MGVTBL const *vtbl, char const *name, I32 namlen)
487 {
488 MAGIC *mg;
489 if (obj || namlen)
490 /* exceeded intended usage of this reserve implementation */
491 return NULL;
492 Newxz(mg, 1, MAGIC);
493 mg->mg_virtual = (MGVTBL*)vtbl;
494 mg->mg_type = type;
495 mg->mg_ptr = (char *)name;
496 mg->mg_len = -1;
497 (void) SvUPGRADE(sv, SVt_PVMG);
498 mg->mg_moremagic = SvMAGIC(sv);
499 SvMAGIC_set(sv, mg);
500 SvMAGICAL_off(sv);
501 mg_magical(sv);
502 return mg;
503 }
504 #endif
505
506 #define NEW_STORABLE_CXT_OBJ(cxt) \
507 STMT_START { \
508 SV *self = newSV(sizeof(stcxt_t) - 1); \
509 SV *my_sv = newRV_noinc(self); \
510 sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \
511 cxt = (stcxt_t *)SvPVX(self); \
512 Zero(cxt, 1, stcxt_t); \
513 cxt->my_sv = my_sv; \
514 } STMT_END
515
516 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
517
518 #if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
519 #define dSTCXT_SV \
520 SV *perinterp_sv = get_sv(MY_VERSION, 0)
521 #else /* >= perl5.004_68 */
522 #define dSTCXT_SV \
523 SV *perinterp_sv = *hv_fetch(PL_modglobal, \
524 MY_VERSION, sizeof(MY_VERSION)-1, TRUE)
525 #endif /* < perl5.004_68 */
526
527 #define dSTCXT_PTR(T,name) \
528 T name = ((perinterp_sv \
529 && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \
530 ? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0))
531 #define dSTCXT \
532 dSTCXT_SV; \
533 dSTCXT_PTR(stcxt_t *, cxt)
534
535 #define INIT_STCXT \
536 dSTCXT; \
537 NEW_STORABLE_CXT_OBJ(cxt); \
538 assert(perinterp_sv); \
539 sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv))
540
541 #define SET_STCXT(x) \
542 STMT_START { \
543 dSTCXT_SV; \
544 sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \
545 } STMT_END
546
547 #else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
548
549 static stcxt_t *Context_ptr = NULL;
550 #define dSTCXT stcxt_t *cxt = Context_ptr
551 #define SET_STCXT(x) Context_ptr = x
552 #define INIT_STCXT \
553 dSTCXT; \
554 NEW_STORABLE_CXT_OBJ(cxt); \
555 SET_STCXT(cxt)
556
557
558 #endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */
559
560 /*
561 * KNOWN BUG:
562 * Croaking implies a memory leak, since we don't use setjmp/longjmp
563 * to catch the exit and free memory used during store or retrieve
564 * operations. This is not too difficult to fix, but I need to understand
565 * how Perl does it, and croaking is exceptional anyway, so I lack the
566 * motivation to do it.
567 *
568 * The current workaround is to mark the context as dirty when croaking,
569 * so that data structures can be freed whenever we renter Storable code
570 * (but only *then*: it's a workaround, not a fix).
571 *
572 * This is also imperfect, because we don't really know how far they trapped
573 * the croak(), and when we were recursing, we won't be able to clean anything
574 * but the topmost context stacked.
575 */
576
577 #define CROAK(x) STMT_START { cxt->s_dirty = 1; croak x; } STMT_END
578
579 /*
580 * End of "thread-safe" related definitions.
581 */
582
583 /*
584 * LOW_32BITS
585 *
586 * Keep only the low 32 bits of a pointer (used for tags, which are not
587 * really pointers).
588 */
589
590 #if PTRSIZE <= 4
591 #define LOW_32BITS(x) ((I32) (x))
592 #else
593 #define LOW_32BITS(x) ((I32) ((STRLEN) (x) & 0xffffffffUL))
594 #endif
595
596 /*
597 * PTR2TAG(x)
598 *
599 * Convert a pointer into an ntag_t.
600 */
601
602 #define PTR2TAG(x) ((ntag_t)(x))
603
604 #define TAG2PTR(x, type) ((y)(x))
605
606 /*
607 * oI, oS, oC
608 *
609 * Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
610 * Used in the WLEN and RLEN macros.
611 */
612
613 #if INTSIZE > 4
614 #define oI(x) ((I32 *) ((char *) (x) + 4))
615 #define oS(x) ((x) - 4)
616 #define oL(x) (x)
617 #define oC(x) (x = 0)
618 #define CRAY_HACK
619 #else
620 #define oI(x) (x)
621 #define oS(x) (x)
622 #define oL(x) (x)
623 #define oC(x)
624 #endif
625
626 /*
627 * key buffer handling
628 */
629 #define kbuf (cxt->keybuf).arena
630 #define ksiz (cxt->keybuf).asiz
631 #define KBUFINIT() \
632 STMT_START { \
633 if (!kbuf) { \
634 TRACEME(("** allocating kbuf of 128 bytes")); \
635 New(10003, kbuf, 128, char); \
636 ksiz = 128; \
637 } \
638 } STMT_END
639 #define KBUFCHK(x) \
640 STMT_START { \
641 if (x >= ksiz) { \
642 if (x >= I32_MAX) \
643 CROAK(("Too large size > I32_MAX")); \
644 TRACEME(("** extending kbuf to %d bytes (had %d)", \
645 (int)(x+1), (int)ksiz)); \
646 Renew(kbuf, x+1, char); \
647 ksiz = x+1; \
648 } \
649 } STMT_END
650
651 /*
652 * memory buffer handling
653 */
654 #define mbase (cxt->membuf).arena
655 #define msiz (cxt->membuf).asiz
656 #define mptr (cxt->membuf).aptr
657 #define mend (cxt->membuf).aend
658
659 #define MGROW (1 << 13)
660 #define MMASK (MGROW - 1)
661
662 #define round_mgrow(x) \
663 ((STRLEN) (((STRLEN) (x) + MMASK) & ~MMASK))
664 #define trunc_int(x) \
665 ((STRLEN) ((STRLEN) (x) & ~(sizeof(int)-1)))
666 #define int_aligned(x) \
667 ((STRLEN)(x) == trunc_int(x))
668
669 #define MBUF_INIT(x) \
670 STMT_START { \
671 if (!mbase) { \
672 TRACEME(("** allocating mbase of %d bytes", MGROW)); \
673 New(10003, mbase, (int)MGROW, char); \
674 msiz = (STRLEN)MGROW; \
675 } \
676 mptr = mbase; \
677 if (x) \
678 mend = mbase + x; \
679 else \
680 mend = mbase + msiz; \
681 } STMT_END
682
683 #define MBUF_TRUNC(x) mptr = mbase + x
684 #define MBUF_SIZE() (mptr - mbase)
685
686 /*
687 * MBUF_SAVE_AND_LOAD
688 * MBUF_RESTORE
689 *
690 * Those macros are used in do_retrieve() to save the current memory
691 * buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
692 * data from a string.
693 */
694 #define MBUF_SAVE_AND_LOAD(in) \
695 STMT_START { \
696 ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \
697 cxt->membuf_ro = 1; \
698 TRACEME(("saving mbuf")); \
699 StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \
700 MBUF_LOAD(in); \
701 } STMT_END
702
703 #define MBUF_RESTORE() \
704 STMT_START { \
705 ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
706 cxt->membuf_ro = 0; \
707 TRACEME(("restoring mbuf")); \
708 StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
709 } STMT_END
710
711 /*
712 * Use SvPOKp(), because SvPOK() fails on tainted scalars.
713 * See store_scalar() for other usage of this workaround.
714 */
715 #define MBUF_LOAD(v) \
716 STMT_START { \
717 ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
718 if (!SvPOKp(v)) \
719 CROAK(("Not a scalar string")); \
720 mptr = mbase = SvPV(v, msiz); \
721 mend = mbase + msiz; \
722 } STMT_END
723
724 #define MBUF_XTEND(x) \
725 STMT_START { \
726 STRLEN nsz = (STRLEN) round_mgrow((x)+msiz); \
727 STRLEN offset = mptr - mbase; \
728 ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
729 TRACEME(("** extending mbase from %ld to %ld bytes (wants %ld new)", \
730 (long)msiz, nsz, (long)(x))); \
731 Renew(mbase, nsz, char); \
732 msiz = nsz; \
733 mptr = mbase + offset; \
734 mend = mbase + nsz; \
735 } STMT_END
736
737 #define MBUF_CHK(x) \
738 STMT_START { \
739 if ((mptr + (x)) > mend) \
740 MBUF_XTEND(x); \
741 } STMT_END
742
743 #define MBUF_GETC(x) \
744 STMT_START { \
745 if (mptr < mend) \
746 x = (int) (unsigned char) *mptr++; \
747 else \
748 return (SV *) 0; \
749 } STMT_END
750
751 #ifdef CRAY_HACK
752 #define MBUF_GETINT(x) \
753 STMT_START { \
754 oC(x); \
755 if ((mptr + 4) <= mend) { \
756 memcpy(oI(&x), mptr, 4); \
757 mptr += 4; \
758 } else \
759 return (SV *) 0; \
760 } STMT_END
761 #else
762 #define MBUF_GETINT(x) \
763 STMT_START { \
764 if ((mptr + sizeof(int)) <= mend) { \
765 if (int_aligned(mptr)) \
766 x = *(int *) mptr; \
767 else \
768 memcpy(&x, mptr, sizeof(int)); \
769 mptr += sizeof(int); \
770 } else \
771 return (SV *) 0; \
772 } STMT_END
773 #endif
774
775 #define MBUF_READ(x,s) \
776 STMT_START { \
777 if ((mptr + (s)) <= mend) { \
778 memcpy(x, mptr, s); \
779 mptr += s; \
780 } else \
781 return (SV *) 0; \
782 } STMT_END
783
784 #define MBUF_SAFEREAD(x,s,z) \
785 STMT_START { \
786 if ((mptr + (s)) <= mend) { \
787 memcpy(x, mptr, s); \
788 mptr += s; \
789 } else { \
790 sv_free(z); \
791 return (SV *) 0; \
792 } \
793 } STMT_END
794
795 #define MBUF_SAFEPVREAD(x,s,z) \
796 STMT_START { \
797 if ((mptr + (s)) <= mend) { \
798 memcpy(x, mptr, s); \
799 mptr += s; \
800 } else { \
801 Safefree(z); \
802 return (SV *) 0; \
803 } \
804 } STMT_END
805
806 #define MBUF_PUTC(c) \
807 STMT_START { \
808 if (mptr < mend) \
809 *mptr++ = (char) c; \
810 else { \
811 MBUF_XTEND(1); \
812 *mptr++ = (char) c; \
813 } \
814 } STMT_END
815
816 #ifdef CRAY_HACK
817 #define MBUF_PUTINT(i) \
818 STMT_START { \
819 MBUF_CHK(4); \
820 memcpy(mptr, oI(&i), 4); \
821 mptr += 4; \
822 } STMT_END
823 #else
824 #define MBUF_PUTINT(i) \
825 STMT_START { \
826 MBUF_CHK(sizeof(int)); \
827 if (int_aligned(mptr)) \
828 *(int *) mptr = i; \
829 else \
830 memcpy(mptr, &i, sizeof(int)); \
831 mptr += sizeof(int); \
832 } STMT_END
833 #endif
834
835 #define MBUF_PUTLONG(l) \
836 STMT_START { \
837 MBUF_CHK(8); \
838 memcpy(mptr, &l, 8); \
839 mptr += 8; \
840 } STMT_END
841 #define MBUF_WRITE(x,s) \
842 STMT_START { \
843 MBUF_CHK(s); \
844 memcpy(mptr, x, s); \
845 mptr += s; \
846 } STMT_END
847
848 /*
849 * Possible return values for sv_type().
850 */
851
852 #define svis_REF 0
853 #define svis_SCALAR 1
854 #define svis_ARRAY 2
855 #define svis_HASH 3
856 #define svis_TIED 4
857 #define svis_TIED_ITEM 5
858 #define svis_CODE 6
859 #define svis_REGEXP 7
860 #define svis_OTHER 8
861
862 /*
863 * Flags for SX_HOOK.
864 */
865
866 #define SHF_TYPE_MASK 0x03
867 #define SHF_LARGE_CLASSLEN 0x04
868 #define SHF_LARGE_STRLEN 0x08
869 #define SHF_LARGE_LISTLEN 0x10
870 #define SHF_IDX_CLASSNAME 0x20
871 #define SHF_NEED_RECURSE 0x40
872 #define SHF_HAS_LIST 0x80
873
874 /*
875 * Types for SX_HOOK (last 2 bits in flags).
876 */
877
878 #define SHT_SCALAR 0
879 #define SHT_ARRAY 1
880 #define SHT_HASH 2
881 #define SHT_EXTRA 3 /* Read extra byte for type */
882
883 /*
884 * The following are held in the "extra byte"...
885 */
886
887 #define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */
888 #define SHT_TARRAY 5 /* 4 + 1 -- tied array */
889 #define SHT_THASH 6 /* 4 + 2 -- tied hash */
890
891 /*
892 * per hash flags for flagged hashes
893 */
894
895 #define SHV_RESTRICTED 0x01
896
897 /*
898 * per key flags for flagged hashes
899 */
900
901 #define SHV_K_UTF8 0x01
902 #define SHV_K_WASUTF8 0x02
903 #define SHV_K_LOCKED 0x04
904 #define SHV_K_ISSV 0x08
905 #define SHV_K_PLACEHOLDER 0x10
906
907 /*
908 * flags to allow blessing and/or tieing data the data we load
909 */
910 #define FLAG_BLESS_OK 2
911 #define FLAG_TIE_OK 4
912
913 /*
914 * Flags for SX_REGEXP.
915 */
916
917 #define SHR_U32_RE_LEN 0x01
918
919 /*
920 * Before 0.6, the magic string was "perl-store" (binary version number 0).
921 *
922 * Since 0.6 introduced many binary incompatibilities, the magic string has
923 * been changed to "pst0" to allow an old image to be properly retrieved by
924 * a newer Storable, but ensure a newer image cannot be retrieved with an
925 * older version.
926 *
927 * At 0.7, objects are given the ability to serialize themselves, and the
928 * set of markers is extended, backward compatibility is not jeopardized,
929 * so the binary version number could have remained unchanged. To correctly
930 * spot errors if a file making use of 0.7-specific extensions is given to
931 * 0.6 for retrieval, the binary version was moved to "2". And I'm introducing
932 * a "minor" version, to better track this kind of evolution from now on.
933 *
934 */
935 static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */
936 static const char magicstr[] = "pst0"; /* Used as a magic number */
937
938 #define MAGICSTR_BYTES 'p','s','t','0'
939 #define OLDMAGICSTR_BYTES 'p','e','r','l','-','s','t','o','r','e'
940
941 /* 5.6.x introduced the ability to have IVs as long long.
942 However, Configure still defined BYTEORDER based on the size of a long.
943 Storable uses the BYTEORDER value as part of the header, but doesn't
944 explicitly store sizeof(IV) anywhere in the header. Hence on 5.6.x built
945 with IV as long long on a platform that uses Configure (ie most things
946 except VMS and Windows) headers are identical for the different IV sizes,
947 despite the files containing some fields based on sizeof(IV)
948 Erk. Broken-ness.
949 5.8 is consistent - the following redefinition kludge is only needed on
950 5.6.x, but the interwork is needed on 5.8 while data survives in files
951 with the 5.6 header.
952
953 */
954
955 #if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4)
956 #ifndef NO_56_INTERWORK_KLUDGE
957 #define USE_56_INTERWORK_KLUDGE
958 #endif
959 #if BYTEORDER == 0x1234
960 #undef BYTEORDER
961 #define BYTEORDER 0x12345678
962 #else
963 #if BYTEORDER == 0x4321
964 #undef BYTEORDER
965 #define BYTEORDER 0x87654321
966 #endif
967 #endif
968 #endif
969
970 #if BYTEORDER == 0x1234
971 #define BYTEORDER_BYTES '1','2','3','4'
972 #else
973 #if BYTEORDER == 0x12345678
974 #define BYTEORDER_BYTES '1','2','3','4','5','6','7','8'
975 #ifdef USE_56_INTERWORK_KLUDGE
976 #define BYTEORDER_BYTES_56 '1','2','3','4'
977 #endif
978 #else
979 #if BYTEORDER == 0x87654321
980 #define BYTEORDER_BYTES '8','7','6','5','4','3','2','1'
981 #ifdef USE_56_INTERWORK_KLUDGE
982 #define BYTEORDER_BYTES_56 '4','3','2','1'
983 #endif
984 #else
985 #if BYTEORDER == 0x4321
986 #define BYTEORDER_BYTES '4','3','2','1'
987 #else
988 #error Unknown byteorder. Please append your byteorder to Storable.xs
989 #endif
990 #endif
991 #endif
992 #endif
993
994 #ifndef INT32_MAX
995 # define INT32_MAX 2147483647
996 #endif
997 #if IVSIZE > 4 && !defined(INT64_MAX)
998 # define INT64_MAX 9223372036854775807LL
999 #endif
1000
1001 static const char byteorderstr[] = {BYTEORDER_BYTES, 0};
1002 #ifdef USE_56_INTERWORK_KLUDGE
1003 static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
1004 #endif
1005
1006 #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
1007 #define STORABLE_BIN_MINOR 11 /* Binary minor "version" */
1008
1009 #if (PATCHLEVEL <= 5)
1010 #define STORABLE_BIN_WRITE_MINOR 4
1011 #elif !defined (SvVOK)
1012 /*
1013 * Perl 5.6.0-5.8.0 can do weak references, but not vstring magic.
1014 */
1015 #define STORABLE_BIN_WRITE_MINOR 8
1016 #elif PATCHLEVEL >= 19
1017 /* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */
1018 /* With 3.x we added LOBJECT */
1019 #define STORABLE_BIN_WRITE_MINOR 11
1020 #else
1021 #define STORABLE_BIN_WRITE_MINOR 9
1022 #endif /* (PATCHLEVEL <= 5) */
1023
1024 #if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1))
1025 #define PL_sv_placeholder PL_sv_undef
1026 #endif
1027
1028 /*
1029 * Useful store shortcuts...
1030 */
1031
1032 /*
1033 * Note that if you put more than one mark for storing a particular
1034 * type of thing, *and* in the retrieve_foo() function you mark both
1035 * the thingy's you get off with SEEN(), you *must* increase the
1036 * tagnum with cxt->tagnum++ along with this macro!
1037 * - samv 20Jan04
1038 */
1039 #define PUTMARK(x) \
1040 STMT_START { \
1041 if (!cxt->fio) \
1042 MBUF_PUTC(x); \
1043 else if (PerlIO_putc(cxt->fio, x) == EOF) \
1044 return -1; \
1045 } STMT_END
1046
1047 #define WRITE_I32(x) \
1048 STMT_START { \
1049 ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \
1050 if (!cxt->fio) \
1051 MBUF_PUTINT(x); \
1052 else if (PerlIO_write(cxt->fio, oI(&x), \
1053 oS(sizeof(x))) != oS(sizeof(x))) \
1054 return -1; \
1055 } STMT_END
1056
1057 #define WRITE_U64(x) \
1058 STMT_START { \
1059 ASSERT(sizeof(x) == sizeof(UV), ("writing an UV")); \
1060 if (!cxt->fio) \
1061 MBUF_PUTLONG(x); \
1062 else if (PerlIO_write(cxt->fio, oL(&x), \
1063 oS(sizeof(x))) != oS(sizeof(x))) \
1064 return -1; \
1065 } STMT_END
1066
1067 #ifdef HAS_HTONL
1068 #define WLEN(x) \
1069 STMT_START { \
1070 ASSERT(sizeof(x) == sizeof(int), ("WLEN writing an int")); \
1071 if (cxt->netorder) { \
1072 int y = (int) htonl(x); \
1073 if (!cxt->fio) \
1074 MBUF_PUTINT(y); \
1075 else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \
1076 return -1; \
1077 } else { \
1078 if (!cxt->fio) \
1079 MBUF_PUTINT(x); \
1080 else if (PerlIO_write(cxt->fio,oI(&x), \
1081 oS(sizeof(x))) != oS(sizeof(x))) \
1082 return -1; \
1083 } \
1084 } STMT_END
1085
1086 # ifdef HAS_U64
1087
1088 #define W64LEN(x) \
1089 STMT_START { \
1090 ASSERT(sizeof(x) == 8, ("W64LEN writing a U64")); \
1091 if (cxt->netorder) { \
1092 U32 buf[2]; \
1093 buf[1] = htonl(x & 0xffffffffUL); \
1094 buf[0] = htonl(x >> 32); \
1095 if (!cxt->fio) \
1096 MBUF_PUTLONG(buf); \
1097 else if (PerlIO_write(cxt->fio, buf, \
1098 sizeof(buf)) != sizeof(buf)) \
1099 return -1; \
1100 } else { \
1101 if (!cxt->fio) \
1102 MBUF_PUTLONG(x); \
1103 else if (PerlIO_write(cxt->fio,oI(&x), \
1104 oS(sizeof(x))) != oS(sizeof(x))) \
1105 return -1; \
1106 } \
1107 } STMT_END
1108
1109 # else
1110
1111 #define W64LEN(x) CROAK(("No 64bit UVs"))
1112
1113 # endif
1114
1115 #else
1116 #define WLEN(x) WRITE_I32(x)
1117 #ifdef HAS_U64
1118 #define W64LEN(x) WRITE_U64(x)
1119 #else
1120 #define W64LEN(x) CROAK(("no 64bit UVs"))
1121 #endif
1122 #endif
1123
1124 #define WRITE(x,y) \
1125 STMT_START { \
1126 if (!cxt->fio) \
1127 MBUF_WRITE(x,y); \
1128 else if (PerlIO_write(cxt->fio, x, y) != (SSize_t)y) \
1129 return -1; \
1130 } STMT_END
1131
1132 #define STORE_PV_LEN(pv, len, small, large) \
1133 STMT_START { \
1134 if (len <= LG_SCALAR) { \
1135 int ilen = (int) len; \
1136 unsigned char clen = (unsigned char) len; \
1137 PUTMARK(small); \
1138 PUTMARK(clen); \
1139 if (len) \
1140 WRITE(pv, ilen); \
1141 } else if (sizeof(len) > 4 && len > INT32_MAX) { \
1142 PUTMARK(SX_LOBJECT); \
1143 PUTMARK(large); \
1144 W64LEN(len); \
1145 WRITE(pv, len); \
1146 } else { \
1147 int ilen = (int) len; \
1148 PUTMARK(large); \
1149 WLEN(ilen); \
1150 WRITE(pv, ilen); \
1151 } \
1152 } STMT_END
1153
1154 #define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR)
1155
1156 /*
1157 * Store &PL_sv_undef in arrays without recursing through store(). We
1158 * actually use this to represent nonexistent elements, for historical
1159 * reasons.
1160 */
1161 #define STORE_SV_UNDEF() \
1162 STMT_START { \
1163 cxt->tagnum++; \
1164 PUTMARK(SX_SV_UNDEF); \
1165 } STMT_END
1166
1167 /*
1168 * Useful retrieve shortcuts...
1169 */
1170
1171 #define GETCHAR() \
1172 (cxt->fio ? PerlIO_getc(cxt->fio) \
1173 : (mptr >= mend ? EOF : (int) *mptr++))
1174
1175 #define GETMARK(x) \
1176 STMT_START { \
1177 if (!cxt->fio) \
1178 MBUF_GETC(x); \
1179 else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \
1180 return (SV *) 0; \
1181 } STMT_END
1182
1183 #define READ_I32(x) \
1184 STMT_START { \
1185 ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \
1186 oC(x); \
1187 if (!cxt->fio) \
1188 MBUF_GETINT(x); \
1189 else if (PerlIO_read(cxt->fio, oI(&x), \
1190 oS(sizeof(x))) != oS(sizeof(x))) \
1191 return (SV *) 0; \
1192 } STMT_END
1193
1194 #ifdef HAS_NTOHL
1195 #define RLEN(x) \
1196 STMT_START { \
1197 oC(x); \
1198 if (!cxt->fio) \
1199 MBUF_GETINT(x); \
1200 else if (PerlIO_read(cxt->fio, oI(&x), \
1201 oS(sizeof(x))) != oS(sizeof(x))) \
1202 return (SV *) 0; \
1203 if (cxt->netorder) \
1204 x = (int) ntohl(x); \
1205 } STMT_END
1206 #else
1207 #define RLEN(x) READ_I32(x)
1208 #endif
1209
1210 #define READ(x,y) \
1211 STMT_START { \
1212 if (!cxt->fio) \
1213 MBUF_READ(x, y); \
1214 else if (PerlIO_read(cxt->fio, x, y) != (SSize_t)y) \
1215 return (SV *) 0; \
1216 } STMT_END
1217
1218 #define SAFEREAD(x,y,z) \
1219 STMT_START { \
1220 if (!cxt->fio) \
1221 MBUF_SAFEREAD(x,y,z); \
1222 else if (PerlIO_read(cxt->fio, x, y) != (SSize_t)y) { \
1223 sv_free(z); \
1224 return (SV *) 0; \
1225 } \
1226 } STMT_END
1227
1228 #define SAFEPVREAD(x,y,z) \
1229 STMT_START { \
1230 if (!cxt->fio) \
1231 MBUF_SAFEPVREAD(x,y,z); \
1232 else if (PerlIO_read(cxt->fio, x, y) != y) { \
1233 Safefree(z); \
1234 return (SV *) 0; \
1235 } \
1236 } STMT_END
1237
1238 #ifdef HAS_U64
1239
1240 # if defined(HAS_NTOHL)
1241 # define Sntohl(x) ntohl(x)
1242 # elif BYTEORDER == 0x87654321 || BYTEORDER == 0x4321
1243 # define Sntohl(x) (x)
1244 # else
Sntohl(U32 x)1245 static U32 Sntohl(U32 x) {
1246 return ((x & 0xFF) << 24) + ((x * 0xFF00) << 8)
1247 + ((x & 0xFF0000) >> 8) + ((x & 0xFF000000) >> 24);
1248 }
1249 # endif
1250
1251 # define READ_U64(x) \
1252 STMT_START { \
1253 ASSERT(sizeof(x) == 8, ("R64LEN reading a U64")); \
1254 if (cxt->netorder) { \
1255 U32 buf[2]; \
1256 READ((void *)buf, sizeof(buf)); \
1257 (x) = ((UV)Sntohl(buf[0]) << 32) + Sntohl(buf[1]); \
1258 } \
1259 else { \
1260 READ(&(x), sizeof(x)); \
1261 } \
1262 } STMT_END
1263
1264 #endif
1265
1266 /*
1267 * SEEN() is used at retrieve time, to remember where object 'y', bearing a
1268 * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker,
1269 * we'll therefore know where it has been retrieved and will be able to
1270 * share the same reference, as in the original stored memory image.
1271 *
1272 * We also need to bless objects ASAP for hooks (which may compute "ref $x"
1273 * on the objects given to STORABLE_thaw and expect that to be defined), and
1274 * also for overloaded objects (for which we might not find the stash if the
1275 * object is not blessed yet--this might occur for overloaded objects that
1276 * refer to themselves indirectly: if we blessed upon return from a sub
1277 * retrieve(), the SX_OBJECT marker we'd found could not have overloading
1278 * restored on it because the underlying object would not be blessed yet!).
1279 *
1280 * To achieve that, the class name of the last retrieved object is passed down
1281 * recursively, and the first SEEN() call for which the class name is not NULL
1282 * will bless the object.
1283 *
1284 * i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef)
1285 *
1286 * SEEN0() is a short-cut where stash is always NULL.
1287 *
1288 * The _NN variants dont check for y being null
1289 */
1290 #define SEEN0_NN(y,i) \
1291 STMT_START { \
1292 if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) \
1293 : SvREFCNT_inc(y)) == 0) \
1294 return (SV *) 0; \
1295 TRACEME(("aseen(#%d) = 0x%" UVxf " (refcnt=%d)", \
1296 (int)cxt->tagnum-1, \
1297 PTR2UV(y), (int)SvREFCNT(y)-1)); \
1298 } STMT_END
1299
1300 #define SEEN0(y,i) \
1301 STMT_START { \
1302 if (!y) \
1303 return (SV *) 0; \
1304 SEEN0_NN(y,i); \
1305 } STMT_END
1306
1307 #define SEEN_NN(y,stash,i) \
1308 STMT_START { \
1309 SEEN0_NN(y,i); \
1310 if (stash) \
1311 BLESS((SV *)(y), (HV *)(stash)); \
1312 } STMT_END
1313
1314 #define SEEN(y,stash,i) \
1315 STMT_START { \
1316 if (!y) \
1317 return (SV *) 0; \
1318 SEEN_NN(y,stash, i); \
1319 } STMT_END
1320
1321 /*
1322 * Bless 's' in 'p', via a temporary reference, required by sv_bless().
1323 * "A" magic is added before the sv_bless for overloaded classes, this avoids
1324 * an expensive call to S_reset_amagic in sv_bless.
1325 */
1326 #define BLESS(s,stash) \
1327 STMT_START { \
1328 SV *ref; \
1329 if (cxt->flags & FLAG_BLESS_OK) { \
1330 TRACEME(("blessing 0x%" UVxf " in %s", PTR2UV(s), \
1331 HvNAME_get(stash))); \
1332 ref = newRV_noinc(s); \
1333 if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) { \
1334 cxt->in_retrieve_overloaded = 0; \
1335 SvAMAGIC_on(ref); \
1336 } \
1337 (void) sv_bless(ref, stash); \
1338 SvRV_set(ref, NULL); \
1339 SvREFCNT_dec(ref); \
1340 } \
1341 else { \
1342 TRACEME(("not blessing 0x%" UVxf " in %s", PTR2UV(s), \
1343 (HvNAME_get(stash)))); \
1344 } \
1345 } STMT_END
1346 /*
1347 * sort (used in store_hash) - conditionally use qsort when
1348 * sortsv is not available ( <= 5.6.1 ).
1349 */
1350
1351 #if (PATCHLEVEL <= 6)
1352
1353 #if defined(USE_ITHREADS)
1354
1355 #define STORE_HASH_SORT \
1356 ENTER; { \
1357 PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \
1358 SAVESPTR(orig_perl); \
1359 PERL_SET_CONTEXT(aTHX); \
1360 qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);\
1361 } LEAVE;
1362
1363 #else /* ! USE_ITHREADS */
1364
1365 #define STORE_HASH_SORT \
1366 qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp);
1367
1368 #endif /* USE_ITHREADS */
1369
1370 #else /* PATCHLEVEL > 6 */
1371
1372 #define STORE_HASH_SORT \
1373 sortsv(AvARRAY(av), len, Perl_sv_cmp);
1374
1375 #endif /* PATCHLEVEL <= 6 */
1376
1377 static int store(pTHX_ stcxt_t *cxt, SV *sv);
1378 static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname);
1379
1380 #define UNSEE() \
1381 STMT_START { \
1382 av_pop(cxt->aseen); \
1383 cxt->tagnum--; \
1384 } STMT_END
1385
1386 /*
1387 * Dynamic dispatching table for SV store.
1388 */
1389
1390 static int store_ref(pTHX_ stcxt_t *cxt, SV *sv);
1391 static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv);
1392 static int store_array(pTHX_ stcxt_t *cxt, AV *av);
1393 static int store_hash(pTHX_ stcxt_t *cxt, HV *hv);
1394 static int store_tied(pTHX_ stcxt_t *cxt, SV *sv);
1395 static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv);
1396 static int store_code(pTHX_ stcxt_t *cxt, CV *cv);
1397 static int store_regexp(pTHX_ stcxt_t *cxt, SV *sv);
1398 static int store_other(pTHX_ stcxt_t *cxt, SV *sv);
1399 static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg);
1400
1401 typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv);
1402
1403 static const sv_store_t sv_store[] = {
1404 (sv_store_t)store_ref, /* svis_REF */
1405 (sv_store_t)store_scalar, /* svis_SCALAR */
1406 (sv_store_t)store_array, /* svis_ARRAY */
1407 (sv_store_t)store_hash, /* svis_HASH */
1408 (sv_store_t)store_tied, /* svis_TIED */
1409 (sv_store_t)store_tied_item,/* svis_TIED_ITEM */
1410 (sv_store_t)store_code, /* svis_CODE */
1411 (sv_store_t)store_regexp, /* svis_REGEXP */
1412 (sv_store_t)store_other, /* svis_OTHER */
1413 };
1414
1415 #define SV_STORE(x) (*sv_store[x])
1416
1417 /*
1418 * Dynamic dispatching tables for SV retrieval.
1419 */
1420
1421 static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname);
1422 static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname);
1423 static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
1424 static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
1425 static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname);
1426 static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname);
1427 static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname);
1428 static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname);
1429 static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname);
1430 static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname);
1431 static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname);
1432 static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname);
1433 static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname);
1434 static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname);
1435 static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname);
1436 static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname);
1437 static SV *retrieve_lobject(pTHX_ stcxt_t *cxt, const char *cname);
1438 static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname);
1439
1440 /* helpers for U64 lobjects */
1441
1442 static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname);
1443 #ifdef HAS_U64
1444 static SV *get_larray(pTHX_ stcxt_t *cxt, UV len, const char *cname);
1445 static SV *get_lhash(pTHX_ stcxt_t *cxt, UV len, int hash_flags, const char *cname);
1446 static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags);
1447 #endif
1448 static int store_hentry(pTHX_ stcxt_t *cxt, HV* hv, UV i, HE *he, unsigned char hash_flags);
1449
1450 typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, const char *name);
1451
1452 static const sv_retrieve_t sv_old_retrieve[] = {
1453 0, /* SX_OBJECT -- entry unused dynamically */
1454 (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */
1455 (sv_retrieve_t)old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */
1456 (sv_retrieve_t)old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */
1457 (sv_retrieve_t)retrieve_ref, /* SX_REF */
1458 (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */
1459 (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */
1460 (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */
1461 (sv_retrieve_t)retrieve_byte, /* SX_BYTE */
1462 (sv_retrieve_t)retrieve_netint, /* SX_NETINT */
1463 (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */
1464 (sv_retrieve_t)retrieve_tied_array, /* SX_TIED_ARRAY */
1465 (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */
1466 (sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_SCALAR */
1467 (sv_retrieve_t)retrieve_other, /* SX_SV_UNDEF not supported */
1468 (sv_retrieve_t)retrieve_other, /* SX_SV_YES not supported */
1469 (sv_retrieve_t)retrieve_other, /* SX_SV_NO not supported */
1470 (sv_retrieve_t)retrieve_other, /* SX_BLESS not supported */
1471 (sv_retrieve_t)retrieve_other, /* SX_IX_BLESS not supported */
1472 (sv_retrieve_t)retrieve_other, /* SX_HOOK not supported */
1473 (sv_retrieve_t)retrieve_other, /* SX_OVERLOADED not supported */
1474 (sv_retrieve_t)retrieve_other, /* SX_TIED_KEY not supported */
1475 (sv_retrieve_t)retrieve_other, /* SX_TIED_IDX not supported */
1476 (sv_retrieve_t)retrieve_other, /* SX_UTF8STR not supported */
1477 (sv_retrieve_t)retrieve_other, /* SX_LUTF8STR not supported */
1478 (sv_retrieve_t)retrieve_other, /* SX_FLAG_HASH not supported */
1479 (sv_retrieve_t)retrieve_other, /* SX_CODE not supported */
1480 (sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */
1481 (sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */
1482 (sv_retrieve_t)retrieve_other, /* SX_VSTRING not supported */
1483 (sv_retrieve_t)retrieve_other, /* SX_LVSTRING not supported */
1484 (sv_retrieve_t)retrieve_other, /* SX_SVUNDEF_ELEM not supported */
1485 (sv_retrieve_t)retrieve_other, /* SX_REGEXP */
1486 (sv_retrieve_t)retrieve_other, /* SX_LOBJECT not supported */
1487 (sv_retrieve_t)retrieve_other, /* SX_LAST */
1488 };
1489
1490 static SV *retrieve_hook_common(pTHX_ stcxt_t *cxt, const char *cname, int large);
1491
1492 static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname);
1493 static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname);
1494 static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname);
1495 static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname);
1496 static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname);
1497 static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname);
1498 static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname);
1499 static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname);
1500 static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname);
1501 static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname);
1502 static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname);
1503 static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname);
1504 static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname);
1505 static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname);
1506 static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname);
1507 static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname);
1508 static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname);
1509 static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname);
1510
1511 static const sv_retrieve_t sv_retrieve[] = {
1512 0, /* SX_OBJECT -- entry unused dynamically */
1513 (sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */
1514 (sv_retrieve_t)retrieve_array, /* SX_ARRAY */
1515 (sv_retrieve_t)retrieve_hash, /* SX_HASH */
1516 (sv_retrieve_t)retrieve_ref, /* SX_REF */
1517 (sv_retrieve_t)retrieve_undef, /* SX_UNDEF */
1518 (sv_retrieve_t)retrieve_integer, /* SX_INTEGER */
1519 (sv_retrieve_t)retrieve_double, /* SX_DOUBLE */
1520 (sv_retrieve_t)retrieve_byte, /* SX_BYTE */
1521 (sv_retrieve_t)retrieve_netint, /* SX_NETINT */
1522 (sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */
1523 (sv_retrieve_t)retrieve_tied_array, /* SX_TIED_ARRAY */
1524 (sv_retrieve_t)retrieve_tied_hash, /* SX_TIED_HASH */
1525 (sv_retrieve_t)retrieve_tied_scalar,/* SX_TIED_SCALAR */
1526 (sv_retrieve_t)retrieve_sv_undef, /* SX_SV_UNDEF */
1527 (sv_retrieve_t)retrieve_sv_yes, /* SX_SV_YES */
1528 (sv_retrieve_t)retrieve_sv_no, /* SX_SV_NO */
1529 (sv_retrieve_t)retrieve_blessed, /* SX_BLESS */
1530 (sv_retrieve_t)retrieve_idx_blessed,/* SX_IX_BLESS */
1531 (sv_retrieve_t)retrieve_hook, /* SX_HOOK */
1532 (sv_retrieve_t)retrieve_overloaded, /* SX_OVERLOAD */
1533 (sv_retrieve_t)retrieve_tied_key, /* SX_TIED_KEY */
1534 (sv_retrieve_t)retrieve_tied_idx, /* SX_TIED_IDX */
1535 (sv_retrieve_t)retrieve_utf8str, /* SX_UTF8STR */
1536 (sv_retrieve_t)retrieve_lutf8str, /* SX_LUTF8STR */
1537 (sv_retrieve_t)retrieve_flag_hash, /* SX_HASH */
1538 (sv_retrieve_t)retrieve_code, /* SX_CODE */
1539 (sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */
1540 (sv_retrieve_t)retrieve_weakoverloaded,/* SX_WEAKOVERLOAD */
1541 (sv_retrieve_t)retrieve_vstring, /* SX_VSTRING */
1542 (sv_retrieve_t)retrieve_lvstring, /* SX_LVSTRING */
1543 (sv_retrieve_t)retrieve_svundef_elem,/* SX_SVUNDEF_ELEM */
1544 (sv_retrieve_t)retrieve_regexp, /* SX_REGEXP */
1545 (sv_retrieve_t)retrieve_lobject, /* SX_LOBJECT */
1546 (sv_retrieve_t)retrieve_other, /* SX_LAST */
1547 };
1548
1549 #define RETRIEVE(c,x) ((x) >= SX_LAST ? retrieve_other : *(c)->retrieve_vtbl[x])
1550
1551 static SV *mbuf2sv(pTHX);
1552
1553 /***
1554 *** Context management.
1555 ***/
1556
1557 /*
1558 * init_perinterp
1559 *
1560 * Called once per "thread" (interpreter) to initialize some global context.
1561 */
init_perinterp(pTHX)1562 static void init_perinterp(pTHX)
1563 {
1564 INIT_STCXT;
1565 INIT_TRACEME;
1566 cxt->netorder = 0; /* true if network order used */
1567 cxt->forgive_me = -1; /* whether to be forgiving... */
1568 cxt->accept_future_minor = -1; /* would otherwise occur too late */
1569 }
1570
1571 /*
1572 * reset_context
1573 *
1574 * Called at the end of every context cleaning, to perform common reset
1575 * operations.
1576 */
reset_context(stcxt_t * cxt)1577 static void reset_context(stcxt_t *cxt)
1578 {
1579 cxt->entry = 0;
1580 cxt->s_dirty = 0;
1581 cxt->recur_sv = NULL;
1582 cxt->recur_depth = 0;
1583 cxt->optype &= ~(ST_STORE|ST_RETRIEVE); /* Leave ST_CLONE alone */
1584 }
1585
1586 /*
1587 * init_store_context
1588 *
1589 * Initialize a new store context for real recursion.
1590 */
init_store_context(pTHX_ stcxt_t * cxt,PerlIO * f,int optype,int network_order)1591 static void init_store_context(pTHX_
1592 stcxt_t *cxt,
1593 PerlIO *f,
1594 int optype,
1595 int network_order)
1596 {
1597 INIT_TRACEME;
1598
1599 TRACEME(("init_store_context"));
1600
1601 cxt->netorder = network_order;
1602 cxt->forgive_me = -1; /* Fetched from perl if needed */
1603 cxt->deparse = -1; /* Idem */
1604 cxt->eval = NULL; /* Idem */
1605 cxt->canonical = -1; /* Idem */
1606 cxt->tagnum = -1; /* Reset tag numbers */
1607 cxt->classnum = -1; /* Reset class numbers */
1608 cxt->fio = f; /* Where I/O are performed */
1609 cxt->optype = optype; /* A store, or a deep clone */
1610 cxt->entry = 1; /* No recursion yet */
1611
1612 /*
1613 * The 'hseen' table is used to keep track of each SV stored and their
1614 * associated tag numbers is special. It is "abused" because the
1615 * values stored are not real SV, just integers cast to (SV *),
1616 * which explains the freeing below.
1617 *
1618 * It is also one possible bottleneck to achieve good storing speed,
1619 * so the "shared keys" optimization is turned off (unlikely to be
1620 * of any use here), and the hash table is "pre-extended". Together,
1621 * those optimizations increase the throughput by 12%.
1622 */
1623
1624 #ifdef USE_PTR_TABLE
1625 cxt->pseen = ptr_table_new();
1626 cxt->hseen = 0;
1627 #else
1628 cxt->hseen = newHV(); /* Table where seen objects are stored */
1629 HvSHAREKEYS_off(cxt->hseen);
1630 #endif
1631 /*
1632 * The following does not work well with perl5.004_04, and causes
1633 * a core dump later on, in a completely unrelated spot, which
1634 * makes me think there is a memory corruption going on.
1635 *
1636 * Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking
1637 * it below does not make any difference. It seems to work fine
1638 * with perl5.004_68 but given the probable nature of the bug,
1639 * that does not prove anything.
1640 *
1641 * It's a shame because increasing the amount of buckets raises
1642 * store() throughput by 5%, but until I figure this out, I can't
1643 * allow for this to go into production.
1644 *
1645 * It is reported fixed in 5.005, hence the #if.
1646 */
1647 #if PERL_VERSION >= 5
1648 #define HBUCKETS 4096 /* Buckets for %hseen */
1649 #ifndef USE_PTR_TABLE
1650 HvMAX(cxt->hseen) = HBUCKETS - 1; /* keys %hseen = $HBUCKETS; */
1651 #endif
1652 #endif
1653
1654 /*
1655 * The 'hclass' hash uses the same settings as 'hseen' above, but it is
1656 * used to assign sequential tags (numbers) to class names for blessed
1657 * objects.
1658 *
1659 * We turn the shared key optimization on.
1660 */
1661
1662 cxt->hclass = newHV(); /* Where seen classnames are stored */
1663
1664 #if PERL_VERSION >= 5
1665 HvMAX(cxt->hclass) = HBUCKETS - 1; /* keys %hclass = $HBUCKETS; */
1666 #endif
1667
1668 /*
1669 * The 'hook' hash table is used to keep track of the references on
1670 * the STORABLE_freeze hook routines, when found in some class name.
1671 *
1672 * It is assumed that the inheritance tree will not be changed during
1673 * storing, and that no new method will be dynamically created by the
1674 * hooks.
1675 */
1676
1677 cxt->hook = newHV(); /* Table where hooks are cached */
1678
1679 /*
1680 * The 'hook_seen' array keeps track of all the SVs returned by
1681 * STORABLE_freeze hooks for us to serialize, so that they are not
1682 * reclaimed until the end of the serialization process. Each SV is
1683 * only stored once, the first time it is seen.
1684 */
1685
1686 cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */
1687
1688 cxt->max_recur_depth = SvIV(get_sv("Storable::recursion_limit", GV_ADD));
1689 cxt->max_recur_depth_hash = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD));
1690 }
1691
1692 /*
1693 * clean_store_context
1694 *
1695 * Clean store context by
1696 */
clean_store_context(pTHX_ stcxt_t * cxt)1697 static void clean_store_context(pTHX_ stcxt_t *cxt)
1698 {
1699 HE *he;
1700
1701 TRACEMED(("clean_store_context"));
1702
1703 ASSERT(cxt->optype & ST_STORE, ("was performing a store()"));
1704
1705 /*
1706 * Insert real values into hashes where we stored faked pointers.
1707 */
1708
1709 #ifndef USE_PTR_TABLE
1710 if (cxt->hseen) {
1711 hv_iterinit(cxt->hseen);
1712 while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall */
1713 HeVAL(he) = &PL_sv_undef;
1714 }
1715 #endif
1716
1717 if (cxt->hclass) {
1718 hv_iterinit(cxt->hclass);
1719 while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall */
1720 HeVAL(he) = &PL_sv_undef;
1721 }
1722
1723 /*
1724 * And now dispose of them...
1725 *
1726 * The surrounding if() protection has been added because there might be
1727 * some cases where this routine is called more than once, during
1728 * exceptional events. This was reported by Marc Lehmann when Storable
1729 * is executed from mod_perl, and the fix was suggested by him.
1730 * -- RAM, 20/12/2000
1731 */
1732
1733 #ifdef USE_PTR_TABLE
1734 if (cxt->pseen) {
1735 struct ptr_tbl *pseen = cxt->pseen;
1736 cxt->pseen = 0;
1737 ptr_table_free(pseen);
1738 }
1739 assert(!cxt->hseen);
1740 #else
1741 if (cxt->hseen) {
1742 HV *hseen = cxt->hseen;
1743 cxt->hseen = 0;
1744 hv_undef(hseen);
1745 sv_free((SV *) hseen);
1746 }
1747 #endif
1748
1749 if (cxt->hclass) {
1750 HV *hclass = cxt->hclass;
1751 cxt->hclass = 0;
1752 hv_undef(hclass);
1753 sv_free((SV *) hclass);
1754 }
1755
1756 if (cxt->hook) {
1757 HV *hook = cxt->hook;
1758 cxt->hook = 0;
1759 hv_undef(hook);
1760 sv_free((SV *) hook);
1761 }
1762
1763 if (cxt->hook_seen) {
1764 AV *hook_seen = cxt->hook_seen;
1765 cxt->hook_seen = 0;
1766 av_undef(hook_seen);
1767 sv_free((SV *) hook_seen);
1768 }
1769
1770 cxt->forgive_me = -1; /* Fetched from perl if needed */
1771 cxt->deparse = -1; /* Idem */
1772 if (cxt->eval) {
1773 SvREFCNT_dec(cxt->eval);
1774 }
1775 cxt->eval = NULL; /* Idem */
1776 cxt->canonical = -1; /* Idem */
1777
1778 reset_context(cxt);
1779 }
1780
1781 /*
1782 * init_retrieve_context
1783 *
1784 * Initialize a new retrieve context for real recursion.
1785 */
init_retrieve_context(pTHX_ stcxt_t * cxt,int optype,int is_tainted)1786 static void init_retrieve_context(pTHX_
1787 stcxt_t *cxt, int optype, int is_tainted)
1788 {
1789 INIT_TRACEME;
1790
1791 TRACEME(("init_retrieve_context"));
1792
1793 /*
1794 * The hook hash table is used to keep track of the references on
1795 * the STORABLE_thaw hook routines, when found in some class name.
1796 *
1797 * It is assumed that the inheritance tree will not be changed during
1798 * storing, and that no new method will be dynamically created by the
1799 * hooks.
1800 */
1801
1802 cxt->hook = newHV(); /* Caches STORABLE_thaw */
1803
1804 #ifdef USE_PTR_TABLE
1805 cxt->pseen = 0;
1806 #endif
1807
1808 /*
1809 * If retrieving an old binary version, the cxt->retrieve_vtbl variable
1810 * was set to sv_old_retrieve. We'll need a hash table to keep track of
1811 * the correspondence between the tags and the tag number used by the
1812 * new retrieve routines.
1813 */
1814
1815 cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve)
1816 ? newHV() : 0);
1817
1818 cxt->aseen = newAV(); /* Where retrieved objects are kept */
1819 cxt->where_is_undef = UNSET_NTAG_T; /* Special case for PL_sv_undef */
1820 cxt->aclass = newAV(); /* Where seen classnames are kept */
1821 cxt->tagnum = 0; /* Have to count objects... */
1822 cxt->classnum = 0; /* ...and class names as well */
1823 cxt->optype = optype;
1824 cxt->s_tainted = is_tainted;
1825 cxt->entry = 1; /* No recursion yet */
1826 #ifndef HAS_RESTRICTED_HASHES
1827 cxt->derestrict = -1; /* Fetched from perl if needed */
1828 #endif
1829 #ifndef HAS_UTF8_ALL
1830 cxt->use_bytes = -1; /* Fetched from perl if needed */
1831 #endif
1832 cxt->accept_future_minor = -1;/* Fetched from perl if needed */
1833 cxt->in_retrieve_overloaded = 0;
1834
1835 cxt->max_recur_depth = SvIV(get_sv("Storable::recursion_limit", GV_ADD));
1836 cxt->max_recur_depth_hash = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD));
1837 }
1838
1839 /*
1840 * clean_retrieve_context
1841 *
1842 * Clean retrieve context by
1843 */
clean_retrieve_context(pTHX_ stcxt_t * cxt)1844 static void clean_retrieve_context(pTHX_ stcxt_t *cxt)
1845 {
1846 TRACEMED(("clean_retrieve_context"));
1847
1848 ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()"));
1849
1850 if (cxt->aseen) {
1851 AV *aseen = cxt->aseen;
1852 cxt->aseen = 0;
1853 av_undef(aseen);
1854 sv_free((SV *) aseen);
1855 }
1856 cxt->where_is_undef = UNSET_NTAG_T;
1857
1858 if (cxt->aclass) {
1859 AV *aclass = cxt->aclass;
1860 cxt->aclass = 0;
1861 av_undef(aclass);
1862 sv_free((SV *) aclass);
1863 }
1864
1865 if (cxt->hook) {
1866 HV *hook = cxt->hook;
1867 cxt->hook = 0;
1868 hv_undef(hook);
1869 sv_free((SV *) hook);
1870 }
1871
1872 if (cxt->hseen) {
1873 HV *hseen = cxt->hseen;
1874 cxt->hseen = 0;
1875 hv_undef(hseen);
1876 sv_free((SV *) hseen); /* optional HV, for backward compat. */
1877 }
1878
1879 #ifndef HAS_RESTRICTED_HASHES
1880 cxt->derestrict = -1; /* Fetched from perl if needed */
1881 #endif
1882 #ifndef HAS_UTF8_ALL
1883 cxt->use_bytes = -1; /* Fetched from perl if needed */
1884 #endif
1885 cxt->accept_future_minor = -1; /* Fetched from perl if needed */
1886
1887 cxt->in_retrieve_overloaded = 0;
1888 reset_context(cxt);
1889 }
1890
1891 /*
1892 * clean_context
1893 *
1894 * A workaround for the CROAK bug: cleanup the last context.
1895 */
clean_context(pTHX_ stcxt_t * cxt)1896 static void clean_context(pTHX_ stcxt_t *cxt)
1897 {
1898 TRACEMED(("clean_context"));
1899
1900 ASSERT(cxt->s_dirty, ("dirty context"));
1901
1902 if (cxt->membuf_ro)
1903 MBUF_RESTORE();
1904
1905 ASSERT(!cxt->membuf_ro, ("mbase is not read-only"));
1906
1907 if (cxt->optype & ST_RETRIEVE)
1908 clean_retrieve_context(aTHX_ cxt);
1909 else if (cxt->optype & ST_STORE)
1910 clean_store_context(aTHX_ cxt);
1911 else
1912 reset_context(cxt);
1913
1914 ASSERT(!cxt->s_dirty, ("context is clean"));
1915 ASSERT(cxt->entry == 0, ("context is reset"));
1916 }
1917
1918 /*
1919 * allocate_context
1920 *
1921 * Allocate a new context and push it on top of the parent one.
1922 * This new context is made globally visible via SET_STCXT().
1923 */
allocate_context(pTHX_ stcxt_t * parent_cxt)1924 static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt)
1925 {
1926 stcxt_t *cxt;
1927
1928 ASSERT(!parent_cxt->s_dirty, ("parent context clean"));
1929
1930 NEW_STORABLE_CXT_OBJ(cxt);
1931 TRACEMED(("allocate_context"));
1932
1933 cxt->prev = parent_cxt->my_sv;
1934 SET_STCXT(cxt);
1935
1936 ASSERT(!cxt->s_dirty, ("clean context"));
1937
1938 return cxt;
1939 }
1940
1941 /*
1942 * free_context
1943 *
1944 * Free current context, which cannot be the "root" one.
1945 * Make the context underneath globally visible via SET_STCXT().
1946 */
free_context(pTHX_ stcxt_t * cxt)1947 static void free_context(pTHX_ stcxt_t *cxt)
1948 {
1949 stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0);
1950
1951 TRACEMED(("free_context"));
1952
1953 ASSERT(!cxt->s_dirty, ("clean context"));
1954 ASSERT(prev, ("not freeing root context"));
1955 assert(prev);
1956
1957 SvREFCNT_dec(cxt->my_sv);
1958 SET_STCXT(prev);
1959
1960 ASSERT(cxt, ("context not void"));
1961 }
1962
1963 /***
1964 *** Predicates.
1965 ***/
1966
1967 /* these two functions are currently only used within asserts */
1968 #ifdef DASSERT
1969 /*
1970 * is_storing
1971 *
1972 * Tells whether we're in the middle of a store operation.
1973 */
is_storing(pTHX)1974 static int is_storing(pTHX)
1975 {
1976 dSTCXT;
1977
1978 return cxt->entry && (cxt->optype & ST_STORE);
1979 }
1980
1981 /*
1982 * is_retrieving
1983 *
1984 * Tells whether we're in the middle of a retrieve operation.
1985 */
is_retrieving(pTHX)1986 static int is_retrieving(pTHX)
1987 {
1988 dSTCXT;
1989
1990 return cxt->entry && (cxt->optype & ST_RETRIEVE);
1991 }
1992 #endif
1993
1994 /*
1995 * last_op_in_netorder
1996 *
1997 * Returns whether last operation was made using network order.
1998 *
1999 * This is typically out-of-band information that might prove useful
2000 * to people wishing to convert native to network order data when used.
2001 */
last_op_in_netorder(pTHX)2002 static int last_op_in_netorder(pTHX)
2003 {
2004 dSTCXT;
2005
2006 assert(cxt);
2007 return cxt->netorder;
2008 }
2009
2010 /***
2011 *** Hook lookup and calling routines.
2012 ***/
2013
2014 /*
2015 * pkg_fetchmeth
2016 *
2017 * A wrapper on gv_fetchmethod_autoload() which caches results.
2018 *
2019 * Returns the routine reference as an SV*, or null if neither the package
2020 * nor its ancestors know about the method.
2021 */
pkg_fetchmeth(pTHX_ HV * cache,HV * pkg,const char * method)2022 static SV *pkg_fetchmeth(pTHX_
2023 HV *cache,
2024 HV *pkg,
2025 const char *method)
2026 {
2027 GV *gv;
2028 SV *sv;
2029 const char *hvname = HvNAME_get(pkg);
2030 #ifdef DEBUGME
2031 dSTCXT;
2032 #endif
2033
2034 /*
2035 * The following code is the same as the one performed by UNIVERSAL::can
2036 * in the Perl core.
2037 */
2038
2039 gv = gv_fetchmethod_autoload(pkg, method, FALSE);
2040 if (gv && isGV(gv)) {
2041 sv = newRV_inc((SV*) GvCV(gv));
2042 TRACEME(("%s->%s: 0x%" UVxf, hvname, method, PTR2UV(sv)));
2043 } else {
2044 sv = newSVsv(&PL_sv_undef);
2045 TRACEME(("%s->%s: not found", hvname, method));
2046 }
2047
2048 /*
2049 * Cache the result, ignoring failure: if we can't store the value,
2050 * it just won't be cached.
2051 */
2052
2053 (void) hv_store(cache, hvname, strlen(hvname), sv, 0);
2054
2055 return SvOK(sv) ? sv : (SV *) 0;
2056 }
2057
2058 /*
2059 * pkg_hide
2060 *
2061 * Force cached value to be undef: hook ignored even if present.
2062 */
pkg_hide(pTHX_ HV * cache,HV * pkg,const char * method)2063 static void pkg_hide(pTHX_
2064 HV *cache,
2065 HV *pkg,
2066 const char *method)
2067 {
2068 const char *hvname = HvNAME_get(pkg);
2069 PERL_UNUSED_ARG(method);
2070 (void) hv_store(cache,
2071 hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0);
2072 }
2073
2074 /*
2075 * pkg_uncache
2076 *
2077 * Discard cached value: a whole fetch loop will be retried at next lookup.
2078 */
pkg_uncache(pTHX_ HV * cache,HV * pkg,const char * method)2079 static void pkg_uncache(pTHX_
2080 HV *cache,
2081 HV *pkg,
2082 const char *method)
2083 {
2084 const char *hvname = HvNAME_get(pkg);
2085 PERL_UNUSED_ARG(method);
2086 (void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
2087 }
2088
2089 /*
2090 * pkg_can
2091 *
2092 * Our own "UNIVERSAL::can", which caches results.
2093 *
2094 * Returns the routine reference as an SV*, or null if the object does not
2095 * know about the method.
2096 */
pkg_can(pTHX_ HV * cache,HV * pkg,const char * method)2097 static SV *pkg_can(pTHX_
2098 HV *cache,
2099 HV *pkg,
2100 const char *method)
2101 {
2102 SV **svh;
2103 SV *sv;
2104 const char *hvname = HvNAME_get(pkg);
2105 #ifdef DEBUGME
2106 dSTCXT;
2107 #endif
2108
2109 TRACEME(("pkg_can for %s->%s", hvname, method));
2110
2111 /*
2112 * Look into the cache to see whether we already have determined
2113 * where the routine was, if any.
2114 *
2115 * NOTA BENE: we don't use 'method' at all in our lookup, since we know
2116 * that only one hook (i.e. always the same) is cached in a given cache.
2117 */
2118
2119 svh = hv_fetch(cache, hvname, strlen(hvname), FALSE);
2120 if (svh) {
2121 sv = *svh;
2122 if (!SvOK(sv)) {
2123 TRACEME(("cached %s->%s: not found", hvname, method));
2124 return (SV *) 0;
2125 } else {
2126 TRACEME(("cached %s->%s: 0x%" UVxf,
2127 hvname, method, PTR2UV(sv)));
2128 return sv;
2129 }
2130 }
2131
2132 TRACEME(("not cached yet"));
2133 return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */
2134 }
2135
2136 /*
2137 * scalar_call
2138 *
2139 * Call routine as obj->hook(av) in scalar context.
2140 * Propagates the single returned value if not called in void context.
2141 */
scalar_call(pTHX_ SV * obj,SV * hook,int cloning,AV * av,I32 flags)2142 static SV *scalar_call(pTHX_
2143 SV *obj,
2144 SV *hook,
2145 int cloning,
2146 AV *av,
2147 I32 flags)
2148 {
2149 dSP;
2150 int count;
2151 SV *sv = 0;
2152 #ifdef DEBUGME
2153 dSTCXT;
2154 #endif
2155
2156 TRACEME(("scalar_call (cloning=%d)", cloning));
2157
2158 ENTER;
2159 SAVETMPS;
2160
2161 PUSHMARK(sp);
2162 XPUSHs(obj);
2163 XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */
2164 if (av) {
2165 SV **ary = AvARRAY(av);
2166 SSize_t cnt = AvFILLp(av) + 1;
2167 SSize_t i;
2168 XPUSHs(ary[0]); /* Frozen string */
2169 for (i = 1; i < cnt; i++) {
2170 TRACEME(("pushing arg #%d (0x%" UVxf ")...",
2171 (int)i, PTR2UV(ary[i])));
2172 XPUSHs(sv_2mortal(newRV_inc(ary[i])));
2173 }
2174 }
2175 PUTBACK;
2176
2177 TRACEME(("calling..."));
2178 count = call_sv(hook, flags); /* Go back to Perl code */
2179 TRACEME(("count = %d", count));
2180
2181 SPAGAIN;
2182
2183 if (count) {
2184 sv = POPs;
2185 SvREFCNT_inc(sv); /* We're returning it, must stay alive! */
2186 }
2187
2188 PUTBACK;
2189 FREETMPS;
2190 LEAVE;
2191
2192 return sv;
2193 }
2194
2195 /*
2196 * array_call
2197 *
2198 * Call routine obj->hook(cloning) in list context.
2199 * Returns the list of returned values in an array.
2200 */
array_call(pTHX_ SV * obj,SV * hook,int cloning)2201 static AV *array_call(pTHX_
2202 SV *obj,
2203 SV *hook,
2204 int cloning)
2205 {
2206 dSP;
2207 int count;
2208 AV *av;
2209 int i;
2210 #ifdef DEBUGME
2211 dSTCXT;
2212 #endif
2213
2214 TRACEME(("array_call (cloning=%d)", cloning));
2215
2216 ENTER;
2217 SAVETMPS;
2218
2219 PUSHMARK(sp);
2220 XPUSHs(obj); /* Target object */
2221 XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */
2222 PUTBACK;
2223
2224 count = call_sv(hook, G_ARRAY); /* Go back to Perl code */
2225
2226 SPAGAIN;
2227
2228 av = newAV();
2229 for (i = count - 1; i >= 0; i--) {
2230 SV *sv = POPs;
2231 av_store(av, i, SvREFCNT_inc(sv));
2232 }
2233
2234 PUTBACK;
2235 FREETMPS;
2236 LEAVE;
2237
2238 return av;
2239 }
2240
2241 #if PERL_VERSION < 15
2242 static void
cleanup_recursive_av(pTHX_ AV * av)2243 cleanup_recursive_av(pTHX_ AV* av) {
2244 SSize_t i = AvFILLp(av);
2245 SV** arr = AvARRAY(av);
2246 if (SvMAGICAL(av)) return;
2247 while (i >= 0) {
2248 if (arr[i]) {
2249 #if PERL_VERSION < 14
2250 arr[i] = NULL;
2251 #else
2252 SvREFCNT_dec(arr[i]);
2253 #endif
2254 }
2255 i--;
2256 }
2257 }
2258
2259 #ifndef SvREFCNT_IMMORTAL
2260 #ifdef DEBUGGING
2261 /* exercise the immortal resurrection code in sv_free2() */
2262 # define SvREFCNT_IMMORTAL 1000
2263 #else
2264 # define SvREFCNT_IMMORTAL ((~(U32)0)/2)
2265 #endif
2266 #endif
2267
2268 static void
cleanup_recursive_hv(pTHX_ HV * hv)2269 cleanup_recursive_hv(pTHX_ HV* hv) {
2270 SSize_t i = HvTOTALKEYS(hv);
2271 HE** arr = HvARRAY(hv);
2272 if (SvMAGICAL(hv)) return;
2273 while (i >= 0) {
2274 if (arr[i]) {
2275 SvREFCNT(HeVAL(arr[i])) = SvREFCNT_IMMORTAL;
2276 arr[i] = NULL; /* let it leak. too dangerous to clean it up here */
2277 }
2278 i--;
2279 }
2280 #if PERL_VERSION < 8
2281 ((XPVHV*)SvANY(hv))->xhv_array = NULL;
2282 #else
2283 HvARRAY(hv) = NULL;
2284 #endif
2285 HvTOTALKEYS(hv) = 0;
2286 }
2287 static void
cleanup_recursive_rv(pTHX_ SV * sv)2288 cleanup_recursive_rv(pTHX_ SV* sv) {
2289 if (sv && SvROK(sv))
2290 SvREFCNT_dec(SvRV(sv));
2291 }
2292 static void
cleanup_recursive_data(pTHX_ SV * sv)2293 cleanup_recursive_data(pTHX_ SV* sv) {
2294 if (SvTYPE(sv) == SVt_PVAV) {
2295 cleanup_recursive_av(aTHX_ (AV*)sv);
2296 }
2297 else if (SvTYPE(sv) == SVt_PVHV) {
2298 cleanup_recursive_hv(aTHX_ (HV*)sv);
2299 }
2300 else {
2301 cleanup_recursive_rv(aTHX_ sv);
2302 }
2303 }
2304 #endif
2305
2306 /*
2307 * known_class
2308 *
2309 * Lookup the class name in the 'hclass' table and either assign it a new ID
2310 * or return the existing one, by filling in 'classnum'.
2311 *
2312 * Return true if the class was known, false if the ID was just generated.
2313 */
known_class(pTHX_ stcxt_t * cxt,char * name,int len,I32 * classnum)2314 static int known_class(pTHX_
2315 stcxt_t *cxt,
2316 char *name, /* Class name */
2317 int len, /* Name length */
2318 I32 *classnum)
2319 {
2320 SV **svh;
2321 HV *hclass = cxt->hclass;
2322
2323 TRACEME(("known_class (%s)", name));
2324
2325 /*
2326 * Recall that we don't store pointers in this hash table, but tags.
2327 * Therefore, we need LOW_32BITS() to extract the relevant parts.
2328 */
2329
2330 svh = hv_fetch(hclass, name, len, FALSE);
2331 if (svh) {
2332 *classnum = LOW_32BITS(*svh);
2333 return TRUE;
2334 }
2335
2336 /*
2337 * Unknown classname, we need to record it.
2338 */
2339
2340 cxt->classnum++;
2341 if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0))
2342 CROAK(("Unable to record new classname"));
2343
2344 *classnum = cxt->classnum;
2345 return FALSE;
2346 }
2347
2348 /***
2349 *** Specific store routines.
2350 ***/
2351
2352 /*
2353 * store_ref
2354 *
2355 * Store a reference.
2356 * Layout is SX_REF <object> or SX_OVERLOAD <object>.
2357 */
store_ref(pTHX_ stcxt_t * cxt,SV * sv)2358 static int store_ref(pTHX_ stcxt_t *cxt, SV *sv)
2359 {
2360 int retval;
2361 int is_weak = 0;
2362 TRACEME(("store_ref (0x%" UVxf ")", PTR2UV(sv)));
2363
2364 /*
2365 * Follow reference, and check if target is overloaded.
2366 */
2367
2368 #ifdef SvWEAKREF
2369 if (SvWEAKREF(sv))
2370 is_weak = 1;
2371 TRACEME(("ref (0x%" UVxf ") is%s weak", PTR2UV(sv),
2372 is_weak ? "" : "n't"));
2373 #endif
2374 sv = SvRV(sv);
2375
2376 if (SvOBJECT(sv)) {
2377 HV *stash = (HV *) SvSTASH(sv);
2378 if (stash && Gv_AMG(stash)) {
2379 TRACEME(("ref (0x%" UVxf ") is overloaded", PTR2UV(sv)));
2380 PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD);
2381 } else
2382 PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
2383 } else
2384 PUTMARK(is_weak ? SX_WEAKREF : SX_REF);
2385
2386 cxt->recur_sv = sv;
2387
2388 TRACEME((">ref recur_depth %" IVdf ", recur_sv (0x%" UVxf ") max %" IVdf, cxt->recur_depth,
2389 PTR2UV(cxt->recur_sv), cxt->max_recur_depth));
2390 if (RECURSION_TOO_DEEP()) {
2391 #if PERL_VERSION < 15
2392 cleanup_recursive_data(aTHX_ (SV*)sv);
2393 #endif
2394 CROAK((MAX_DEPTH_ERROR));
2395 }
2396
2397 retval = store(aTHX_ cxt, sv);
2398 if (cxt->max_recur_depth != -1 && cxt->recur_depth > 0) {
2399 TRACEME(("<ref recur_depth --%" IVdf, cxt->recur_depth));
2400 --cxt->recur_depth;
2401 }
2402 return retval;
2403 }
2404
2405 /*
2406 * store_scalar
2407 *
2408 * Store a scalar.
2409 *
2410 * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
2411 * SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings.
2412 * The <data> section is omitted if <length> is 0.
2413 *
2414 * For vstrings, the vstring portion is stored first with
2415 * SX_LVSTRING <length> <data> or SX_VSTRING <length> <data>, followed by
2416 * SX_(L)SCALAR or SX_(L)UTF8STR with the actual PV.
2417 *
2418 * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
2419 * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>.
2420 *
2421 * For huge strings use SX_LOBJECT SX_type SX_U64 <type> <data>
2422 */
store_scalar(pTHX_ stcxt_t * cxt,SV * sv)2423 static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv)
2424 {
2425 IV iv;
2426 char *pv;
2427 STRLEN len;
2428 U32 flags = SvFLAGS(sv); /* "cc -O" may put it in register */
2429
2430 TRACEME(("store_scalar (0x%" UVxf ")", PTR2UV(sv)));
2431
2432 /*
2433 * For efficiency, break the SV encapsulation by peaking at the flags
2434 * directly without using the Perl macros to avoid dereferencing
2435 * sv->sv_flags each time we wish to check the flags.
2436 */
2437
2438 if (!(flags & SVf_OK)) { /* !SvOK(sv) */
2439 if (sv == &PL_sv_undef) {
2440 TRACEME(("immortal undef"));
2441 PUTMARK(SX_SV_UNDEF);
2442 } else {
2443 TRACEME(("undef at 0x%" UVxf, PTR2UV(sv)));
2444 PUTMARK(SX_UNDEF);
2445 }
2446 return 0;
2447 }
2448
2449 /*
2450 * Always store the string representation of a scalar if it exists.
2451 * Gisle Aas provided me with this test case, better than a long speach:
2452 *
2453 * perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)'
2454 * SV = PVNV(0x80c8520)
2455 * REFCNT = 1
2456 * FLAGS = (NOK,POK,pNOK,pPOK)
2457 * IV = 0
2458 * NV = 0
2459 * PV = 0x80c83d0 "abc"\0
2460 * CUR = 3
2461 * LEN = 4
2462 *
2463 * Write SX_SCALAR, length, followed by the actual data.
2464 *
2465 * Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as
2466 * appropriate, followed by the actual (binary) data. A double
2467 * is written as a string if network order, for portability.
2468 *
2469 * NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv).
2470 * The reason is that when the scalar value is tainted, the SvNOK(sv)
2471 * value is false.
2472 *
2473 * The test for a read-only scalar with both POK and NOK set is meant
2474 * to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the
2475 * address comparison for each scalar we store.
2476 */
2477
2478 #define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK)
2479
2480 if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) {
2481 if (sv == &PL_sv_yes) {
2482 TRACEME(("immortal yes"));
2483 PUTMARK(SX_SV_YES);
2484 } else if (sv == &PL_sv_no) {
2485 TRACEME(("immortal no"));
2486 PUTMARK(SX_SV_NO);
2487 } else {
2488 pv = SvPV(sv, len); /* We know it's SvPOK */
2489 goto string; /* Share code below */
2490 }
2491 } else if (flags & SVf_POK) {
2492 /* public string - go direct to string read. */
2493 goto string_readlen;
2494 } else if (
2495 #if (PATCHLEVEL <= 6)
2496 /* For 5.6 and earlier NV flag trumps IV flag, so only use integer
2497 direct if NV flag is off. */
2498 (flags & (SVf_NOK | SVf_IOK)) == SVf_IOK
2499 #else
2500 /* 5.7 rules are that if IV public flag is set, IV value is as
2501 good, if not better, than NV value. */
2502 flags & SVf_IOK
2503 #endif
2504 ) {
2505 iv = SvIV(sv);
2506 /*
2507 * Will come here from below with iv set if double is an integer.
2508 */
2509 integer:
2510
2511 /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
2512 #ifdef SVf_IVisUV
2513 /* Need to do this out here, else 0xFFFFFFFF becomes iv of -1
2514 * (for example) and that ends up in the optimised small integer
2515 * case.
2516 */
2517 if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) {
2518 TRACEME(("large unsigned integer as string, value = %" UVuf,
2519 SvUV(sv)));
2520 goto string_readlen;
2521 }
2522 #endif
2523 /*
2524 * Optimize small integers into a single byte, otherwise store as
2525 * a real integer (converted into network order if they asked).
2526 */
2527
2528 if (iv >= -128 && iv <= 127) {
2529 unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */
2530 PUTMARK(SX_BYTE);
2531 PUTMARK(siv);
2532 TRACEME(("small integer stored as %d", (int)siv));
2533 } else if (cxt->netorder) {
2534 #ifndef HAS_HTONL
2535 TRACEME(("no htonl, fall back to string for integer"));
2536 goto string_readlen;
2537 #else
2538 I32 niv;
2539
2540
2541 #if IVSIZE > 4
2542 if (
2543 #ifdef SVf_IVisUV
2544 /* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */
2545 ((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) ||
2546 #endif
2547 (iv > (IV)0x7FFFFFFF) || (iv < -(IV)0x80000000)) {
2548 /* Bigger than 32 bits. */
2549 TRACEME(("large network order integer as string, value = %" IVdf, iv));
2550 goto string_readlen;
2551 }
2552 #endif
2553
2554 niv = (I32) htonl((I32) iv);
2555 TRACEME(("using network order"));
2556 PUTMARK(SX_NETINT);
2557 WRITE_I32(niv);
2558 #endif
2559 } else {
2560 PUTMARK(SX_INTEGER);
2561 WRITE(&iv, sizeof(iv));
2562 }
2563
2564 TRACEME(("ok (integer 0x%" UVxf ", value = %" IVdf ")", PTR2UV(sv), iv));
2565 } else if (flags & SVf_NOK) {
2566 NV_bytes nv;
2567 #ifdef NV_CLEAR
2568 /* if we can't tell if there's padding, clear the whole NV and hope the
2569 compiler leaves the padding alone
2570 */
2571 Zero(&nv, 1, NV_bytes);
2572 #endif
2573 #if (PATCHLEVEL <= 6)
2574 nv.nv = SvNV(sv);
2575 /*
2576 * Watch for number being an integer in disguise.
2577 */
2578 if (nv.nv == (NV) (iv = I_V(nv.nv))) {
2579 TRACEME(("double %" NVff " is actually integer %" IVdf, nv, iv));
2580 goto integer; /* Share code above */
2581 }
2582 #else
2583
2584 SvIV_please(sv);
2585 if (SvIOK_notUV(sv)) {
2586 iv = SvIV(sv);
2587 goto integer; /* Share code above */
2588 }
2589 nv.nv = SvNV(sv);
2590 #endif
2591
2592 if (cxt->netorder) {
2593 TRACEME(("double %" NVff " stored as string", nv.nv));
2594 goto string_readlen; /* Share code below */
2595 }
2596 #if NV_PADDING
2597 Zero(nv.bytes + NVSIZE - NV_PADDING, NV_PADDING, char);
2598 #endif
2599
2600 PUTMARK(SX_DOUBLE);
2601 WRITE(&nv, sizeof(nv));
2602
2603 TRACEME(("ok (double 0x%" UVxf ", value = %" NVff ")", PTR2UV(sv), nv.nv));
2604
2605 } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) {
2606 #ifdef SvVOK
2607 MAGIC *mg;
2608 #endif
2609 UV wlen; /* For 64-bit machines */
2610
2611 string_readlen:
2612 pv = SvPV(sv, len);
2613
2614 /*
2615 * Will come here from above if it was readonly, POK and NOK but
2616 * neither &PL_sv_yes nor &PL_sv_no.
2617 */
2618 string:
2619
2620 #ifdef SvVOK
2621 if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) {
2622 /* The macro passes this by address, not value, and a lot of
2623 called code assumes that it's 32 bits without checking. */
2624 const SSize_t len = mg->mg_len;
2625 STORE_PV_LEN((const char *)mg->mg_ptr,
2626 len, SX_VSTRING, SX_LVSTRING);
2627 }
2628 #endif
2629
2630 wlen = (Size_t)len;
2631 if (SvUTF8 (sv))
2632 STORE_UTF8STR(pv, wlen);
2633 else
2634 STORE_SCALAR(pv, wlen);
2635 TRACEME(("ok (scalar 0x%" UVxf " '%s', length = %" UVuf ")",
2636 PTR2UV(sv), len >= 2048 ? "<string too long>" : SvPVX(sv),
2637 (UV)len));
2638 } else {
2639 CROAK(("Can't determine type of %s(0x%" UVxf ")",
2640 sv_reftype(sv, FALSE),
2641 PTR2UV(sv)));
2642 }
2643 return 0; /* Ok, no recursion on scalars */
2644 }
2645
2646 /*
2647 * store_array
2648 *
2649 * Store an array.
2650 *
2651 * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
2652 * Each item is stored as <object>.
2653 */
store_array(pTHX_ stcxt_t * cxt,AV * av)2654 static int store_array(pTHX_ stcxt_t *cxt, AV *av)
2655 {
2656 SV **sav;
2657 UV len = av_len(av) + 1;
2658 UV i;
2659 int ret;
2660 SV *const recur_sv = cxt->recur_sv;
2661
2662 TRACEME(("store_array (0x%" UVxf ")", PTR2UV(av)));
2663
2664 #ifdef HAS_U64
2665 if (len > 0x7fffffffu) {
2666 /*
2667 * Large array by emitting SX_LOBJECT 1 U64 data
2668 */
2669 PUTMARK(SX_LOBJECT);
2670 PUTMARK(SX_ARRAY);
2671 W64LEN(len);
2672 TRACEME(("lobject size = %lu", (unsigned long)len));
2673 } else
2674 #endif
2675 {
2676 /*
2677 * Normal array by emitting SX_ARRAY, followed by the array length.
2678 */
2679 I32 l = (I32)len;
2680 PUTMARK(SX_ARRAY);
2681 WLEN(l);
2682 TRACEME(("size = %d", (int)l));
2683 }
2684
2685 TRACEME((">array recur_depth %" IVdf ", recur_sv (0x%" UVxf ") max %" IVdf, cxt->recur_depth,
2686 PTR2UV(cxt->recur_sv), cxt->max_recur_depth));
2687 if (recur_sv != (SV*)av) {
2688 if (RECURSION_TOO_DEEP()) {
2689 /* with <= 5.14 it recurses in the cleanup also, needing 2x stack size */
2690 #if PERL_VERSION < 15
2691 cleanup_recursive_data(aTHX_ (SV*)av);
2692 #endif
2693 CROAK((MAX_DEPTH_ERROR));
2694 }
2695 }
2696
2697 /*
2698 * Now store each item recursively.
2699 */
2700
2701 for (i = 0; i < len; i++) {
2702 sav = av_fetch(av, i, 0);
2703 if (!sav) {
2704 TRACEME(("(#%d) nonexistent item", (int)i));
2705 STORE_SV_UNDEF();
2706 continue;
2707 }
2708 #if PATCHLEVEL >= 19
2709 /* In 5.19.3 and up, &PL_sv_undef can actually be stored in
2710 * an array; it no longer represents nonexistent elements.
2711 * Historically, we have used SX_SV_UNDEF in arrays for
2712 * nonexistent elements, so we use SX_SVUNDEF_ELEM for
2713 * &PL_sv_undef itself. */
2714 if (*sav == &PL_sv_undef) {
2715 TRACEME(("(#%d) undef item", (int)i));
2716 cxt->tagnum++;
2717 PUTMARK(SX_SVUNDEF_ELEM);
2718 continue;
2719 }
2720 #endif
2721 TRACEME(("(#%d) item", (int)i));
2722 if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall */
2723 return ret;
2724 }
2725
2726 if (recur_sv != (SV*)av) {
2727 assert(cxt->max_recur_depth == -1 || cxt->recur_depth > 0);
2728 if (cxt->max_recur_depth != -1 && cxt->recur_depth > 0) {
2729 TRACEME(("<array recur_depth --%" IVdf, cxt->recur_depth));
2730 --cxt->recur_depth;
2731 }
2732 }
2733 TRACEME(("ok (array)"));
2734
2735 return 0;
2736 }
2737
2738
2739 #if (PATCHLEVEL <= 6)
2740
2741 /*
2742 * sortcmp
2743 *
2744 * Sort two SVs
2745 * Borrowed from perl source file pp_ctl.c, where it is used by pp_sort.
2746 */
2747 static int
sortcmp(const void * a,const void * b)2748 sortcmp(const void *a, const void *b)
2749 {
2750 #if defined(USE_ITHREADS)
2751 dTHX;
2752 #endif /* USE_ITHREADS */
2753 return sv_cmp(*(SV * const *) a, *(SV * const *) b);
2754 }
2755
2756 #endif /* PATCHLEVEL <= 6 */
2757
2758 /*
2759 * store_hash
2760 *
2761 * Store a hash table.
2762 *
2763 * For a "normal" hash (not restricted, no utf8 keys):
2764 *
2765 * Layout is SX_HASH <size> followed by each key/value pair, in random order.
2766 * Values are stored as <object>.
2767 * Keys are stored as <length> <data>, the <data> section being omitted
2768 * if length is 0.
2769 *
2770 * For a "fancy" hash (restricted or utf8 keys):
2771 *
2772 * Layout is SX_FLAG_HASH <size> <hash flags> followed by each key/value pair,
2773 * in random order.
2774 * Values are stored as <object>.
2775 * Keys are stored as <flags> <length> <data>, the <data> section being omitted
2776 * if length is 0.
2777 * Currently the only hash flag is "restricted"
2778 * Key flags are as for hv.h
2779 */
store_hash(pTHX_ stcxt_t * cxt,HV * hv)2780 static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
2781 {
2782 dVAR;
2783 UV len = (UV)HvTOTALKEYS(hv);
2784 Size_t i;
2785 int ret = 0;
2786 I32 riter;
2787 HE *eiter;
2788 int flagged_hash = ((SvREADONLY(hv)
2789 #ifdef HAS_HASH_KEY_FLAGS
2790 || HvHASKFLAGS(hv)
2791 #endif
2792 ) ? 1 : 0);
2793 unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0);
2794 SV * const recur_sv = cxt->recur_sv;
2795
2796 /*
2797 * Signal hash by emitting SX_HASH, followed by the table length.
2798 * Max number of keys per perl version:
2799 * IV - 5.12
2800 * STRLEN 5.14 - 5.24 (size_t: U32/U64)
2801 * SSize_t 5.22c - 5.24c (I32/I64)
2802 * U32 5.25c -
2803 */
2804
2805 if (len > 0x7fffffffu) { /* keys > I32_MAX */
2806 /*
2807 * Large hash: SX_LOBJECT type hashflags? U64 data
2808 *
2809 * Stupid limitation:
2810 * Note that perl5 can store more than 2G keys, but only iterate
2811 * over 2G max. (cperl can)
2812 * We need to manually iterate over it then, unsorted.
2813 * But until perl itself cannot do that, skip that.
2814 */
2815 TRACEME(("lobject size = %lu", (unsigned long)len));
2816 #ifdef HAS_U64
2817 PUTMARK(SX_LOBJECT);
2818 if (flagged_hash) {
2819 PUTMARK(SX_FLAG_HASH);
2820 PUTMARK(hash_flags);
2821 } else {
2822 PUTMARK(SX_HASH);
2823 }
2824 W64LEN(len);
2825 return store_lhash(aTHX_ cxt, hv, hash_flags);
2826 #else
2827 /* <5.12 you could store larger hashes, but cannot iterate over them.
2828 So we reject them, it's a bug. */
2829 CROAK(("Cannot store large objects on a 32bit system"));
2830 #endif
2831 } else {
2832 I32 l = (I32)len;
2833 if (flagged_hash) {
2834 TRACEME(("store_hash (0x%" UVxf ") (flags %x)", PTR2UV(hv),
2835 (unsigned int)hash_flags));
2836 PUTMARK(SX_FLAG_HASH);
2837 PUTMARK(hash_flags);
2838 } else {
2839 TRACEME(("store_hash (0x%" UVxf ")", PTR2UV(hv)));
2840 PUTMARK(SX_HASH);
2841 }
2842 WLEN(l);
2843 TRACEME(("size = %d, used = %d", (int)l, (int)HvUSEDKEYS(hv)));
2844 }
2845
2846 TRACEME((">hash recur_depth %" IVdf ", recur_sv (0x%" UVxf ") max %" IVdf, cxt->recur_depth,
2847 PTR2UV(cxt->recur_sv), cxt->max_recur_depth_hash));
2848 if (recur_sv != (SV*)hv && cxt->max_recur_depth_hash != -1) {
2849 ++cxt->recur_depth;
2850 }
2851 if (RECURSION_TOO_DEEP_HASH()) {
2852 #if PERL_VERSION < 15
2853 cleanup_recursive_data(aTHX_ (SV*)hv);
2854 #endif
2855 CROAK((MAX_DEPTH_ERROR));
2856 }
2857
2858 /*
2859 * Save possible iteration state via each() on that table.
2860 *
2861 * Note that perl as of 5.24 *can* store more than 2G keys, but *not*
2862 * iterate over it.
2863 * Lengths of hash keys are also limited to I32, which is good.
2864 */
2865
2866 riter = HvRITER_get(hv);
2867 eiter = HvEITER_get(hv);
2868 hv_iterinit(hv);
2869
2870 /*
2871 * Now store each item recursively.
2872 *
2873 * If canonical is defined to some true value then store each
2874 * key/value pair in sorted order otherwise the order is random.
2875 * Canonical order is irrelevant when a deep clone operation is performed.
2876 *
2877 * Fetch the value from perl only once per store() operation, and only
2878 * when needed.
2879 */
2880
2881 if (
2882 !(cxt->optype & ST_CLONE)
2883 && (cxt->canonical == 1
2884 || (cxt->canonical < 0
2885 && (cxt->canonical =
2886 (SvTRUE(get_sv("Storable::canonical", GV_ADD))
2887 ? 1 : 0))))
2888 ) {
2889 /*
2890 * Storing in order, sorted by key.
2891 * Run through the hash, building up an array of keys in a
2892 * mortal array, sort the array and then run through the
2893 * array.
2894 */
2895 AV *av = newAV();
2896 av_extend (av, len);
2897
2898 TRACEME(("using canonical order"));
2899
2900 for (i = 0; i < len; i++) {
2901 #ifdef HAS_RESTRICTED_HASHES
2902 HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
2903 #else
2904 HE *he = hv_iternext(hv);
2905 #endif
2906 av_store(av, i, hv_iterkeysv(he));
2907 }
2908
2909 STORE_HASH_SORT;
2910
2911 for (i = 0; i < len; i++) {
2912 #ifdef HAS_RESTRICTED_HASHES
2913 int placeholders = (int)HvPLACEHOLDERS_get(hv);
2914 #endif
2915 unsigned char flags = 0;
2916 char *keyval;
2917 STRLEN keylen_tmp;
2918 I32 keylen;
2919 SV *key = av_shift(av);
2920 /* This will fail if key is a placeholder.
2921 Track how many placeholders we have, and error if we
2922 "see" too many. */
2923 HE *he = hv_fetch_ent(hv, key, 0, 0);
2924 SV *val;
2925
2926 if (he) {
2927 if (!(val = HeVAL(he))) {
2928 /* Internal error, not I/O error */
2929 return 1;
2930 }
2931 } else {
2932 #ifdef HAS_RESTRICTED_HASHES
2933 /* Should be a placeholder. */
2934 if (placeholders-- < 0) {
2935 /* This should not happen - number of
2936 retrieves should be identical to
2937 number of placeholders. */
2938 return 1;
2939 }
2940 /* Value is never needed, and PL_sv_undef is
2941 more space efficient to store. */
2942 val = &PL_sv_undef;
2943 ASSERT (flags == 0,
2944 ("Flags not 0 but %d", (int)flags));
2945 flags = SHV_K_PLACEHOLDER;
2946 #else
2947 return 1;
2948 #endif
2949 }
2950
2951 /*
2952 * Store value first.
2953 */
2954
2955 TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
2956
2957 if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */
2958 goto out;
2959
2960 /*
2961 * Write key string.
2962 * Keys are written after values to make sure retrieval
2963 * can be optimal in terms of memory usage, where keys are
2964 * read into a fixed unique buffer called kbuf.
2965 * See retrieve_hash() for details.
2966 */
2967
2968 /* Implementation of restricted hashes isn't nicely
2969 abstracted: */
2970 if ((hash_flags & SHV_RESTRICTED)
2971 && SvTRULYREADONLY(val)) {
2972 flags |= SHV_K_LOCKED;
2973 }
2974
2975 keyval = SvPV(key, keylen_tmp);
2976 keylen = keylen_tmp;
2977 #ifdef HAS_UTF8_HASHES
2978 /* If you build without optimisation on pre 5.6
2979 then nothing spots that SvUTF8(key) is always 0,
2980 so the block isn't optimised away, at which point
2981 the linker dislikes the reference to
2982 bytes_from_utf8. */
2983 if (SvUTF8(key)) {
2984 const char *keysave = keyval;
2985 bool is_utf8 = TRUE;
2986
2987 /* Just casting the &klen to (STRLEN) won't work
2988 well if STRLEN and I32 are of different widths.
2989 --jhi */
2990 keyval = (char*)bytes_from_utf8((U8*)keyval,
2991 &keylen_tmp,
2992 &is_utf8);
2993
2994 /* If we were able to downgrade here, then than
2995 means that we have a key which only had chars
2996 0-255, but was utf8 encoded. */
2997
2998 if (keyval != keysave) {
2999 keylen = keylen_tmp;
3000 flags |= SHV_K_WASUTF8;
3001 } else {
3002 /* keylen_tmp can't have changed, so no need
3003 to assign back to keylen. */
3004 flags |= SHV_K_UTF8;
3005 }
3006 }
3007 #endif
3008
3009 if (flagged_hash) {
3010 PUTMARK(flags);
3011 TRACEME(("(#%d) key '%s' flags %x %u", (int)i, keyval, flags, *keyval));
3012 } else {
3013 /* This is a workaround for a bug in 5.8.0
3014 that causes the HEK_WASUTF8 flag to be
3015 set on an HEK without the hash being
3016 marked as having key flags. We just
3017 cross our fingers and drop the flag.
3018 AMS 20030901 */
3019 assert (flags == 0 || flags == SHV_K_WASUTF8);
3020 TRACEME(("(#%d) key '%s'", (int)i, keyval));
3021 }
3022 WLEN(keylen);
3023 if (keylen)
3024 WRITE(keyval, keylen);
3025 if (flags & SHV_K_WASUTF8)
3026 Safefree (keyval);
3027 }
3028
3029 /*
3030 * Free up the temporary array
3031 */
3032
3033 av_undef(av);
3034 sv_free((SV *) av);
3035
3036 } else {
3037
3038 /*
3039 * Storing in "random" order (in the order the keys are stored
3040 * within the hash). This is the default and will be faster!
3041 */
3042
3043 for (i = 0; i < len; i++) {
3044 #ifdef HV_ITERNEXT_WANTPLACEHOLDERS
3045 HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS);
3046 #else
3047 HE *he = hv_iternext(hv);
3048 #endif
3049 SV *val = (he ? hv_iterval(hv, he) : 0);
3050
3051 if (val == 0)
3052 return 1; /* Internal error, not I/O error */
3053
3054 if ((ret = store_hentry(aTHX_ cxt, hv, i, he, hash_flags)))
3055 goto out;
3056 #if 0
3057 /* Implementation of restricted hashes isn't nicely
3058 abstracted: */
3059 flags = (((hash_flags & SHV_RESTRICTED)
3060 && SvTRULYREADONLY(val))
3061 ? SHV_K_LOCKED : 0);
3062
3063 if (val == &PL_sv_placeholder) {
3064 flags |= SHV_K_PLACEHOLDER;
3065 val = &PL_sv_undef;
3066 }
3067
3068 /*
3069 * Store value first.
3070 */
3071
3072 TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
3073
3074 if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall */
3075 goto out;
3076
3077
3078 hek = HeKEY_hek(he);
3079 len = HEK_LEN(hek);
3080 if (len == HEf_SVKEY) {
3081 /* This is somewhat sick, but the internal APIs are
3082 * such that XS code could put one of these in in
3083 * a regular hash.
3084 * Maybe we should be capable of storing one if
3085 * found.
3086 */
3087 key_sv = HeKEY_sv(he);
3088 flags |= SHV_K_ISSV;
3089 } else {
3090 /* Regular string key. */
3091 #ifdef HAS_HASH_KEY_FLAGS
3092 if (HEK_UTF8(hek))
3093 flags |= SHV_K_UTF8;
3094 if (HEK_WASUTF8(hek))
3095 flags |= SHV_K_WASUTF8;
3096 #endif
3097 key = HEK_KEY(hek);
3098 }
3099 /*
3100 * Write key string.
3101 * Keys are written after values to make sure retrieval
3102 * can be optimal in terms of memory usage, where keys are
3103 * read into a fixed unique buffer called kbuf.
3104 * See retrieve_hash() for details.
3105 */
3106
3107 if (flagged_hash) {
3108 PUTMARK(flags);
3109 TRACEME(("(#%d) key '%s' flags %x", (int)i, key, flags));
3110 } else {
3111 /* This is a workaround for a bug in 5.8.0
3112 that causes the HEK_WASUTF8 flag to be
3113 set on an HEK without the hash being
3114 marked as having key flags. We just
3115 cross our fingers and drop the flag.
3116 AMS 20030901 */
3117 assert (flags == 0 || flags == SHV_K_WASUTF8);
3118 TRACEME(("(#%d) key '%s'", (int)i, key));
3119 }
3120 if (flags & SHV_K_ISSV) {
3121 int ret;
3122 if ((ret = store(aTHX_ cxt, key_sv)))
3123 goto out;
3124 } else {
3125 WLEN(len);
3126 if (len)
3127 WRITE(key, len);
3128 }
3129 #endif
3130 }
3131 }
3132
3133 TRACEME(("ok (hash 0x%" UVxf ")", PTR2UV(hv)));
3134
3135 out:
3136 assert(cxt->max_recur_depth_hash != -1 && cxt->recur_depth > 0);
3137 TRACEME(("<hash recur_depth --%" IVdf , cxt->recur_depth));
3138 if (cxt->max_recur_depth_hash != -1 && recur_sv != (SV*)hv && cxt->recur_depth > 0) {
3139 --cxt->recur_depth;
3140 }
3141 HvRITER_set(hv, riter); /* Restore hash iterator state */
3142 HvEITER_set(hv, eiter);
3143
3144 return ret;
3145 }
3146
store_hentry(pTHX_ stcxt_t * cxt,HV * hv,UV i,HE * he,unsigned char hash_flags)3147 static int store_hentry(pTHX_
3148 stcxt_t *cxt, HV* hv, UV i, HE *he, unsigned char hash_flags)
3149 {
3150 int ret = 0;
3151 SV* val = hv_iterval(hv, he);
3152 int flagged_hash = ((SvREADONLY(hv)
3153 #ifdef HAS_HASH_KEY_FLAGS
3154 || HvHASKFLAGS(hv)
3155 #endif
3156 ) ? 1 : 0);
3157 unsigned char flags = (((hash_flags & SHV_RESTRICTED)
3158 && SvTRULYREADONLY(val))
3159 ? SHV_K_LOCKED : 0);
3160 #ifndef DEBUGME
3161 PERL_UNUSED_ARG(i);
3162 #endif
3163 if (val == &PL_sv_placeholder) {
3164 flags |= SHV_K_PLACEHOLDER;
3165 val = &PL_sv_undef;
3166 }
3167
3168 /*
3169 * Store value first.
3170 */
3171
3172 TRACEME(("(#%d) value 0x%" UVxf, (int)i, PTR2UV(val)));
3173
3174 {
3175 HEK* hek = HeKEY_hek(he);
3176 I32 len = HEK_LEN(hek);
3177 SV *key_sv = NULL;
3178 char *key = 0;
3179
3180 if ((ret = store(aTHX_ cxt, val)))
3181 return ret;
3182 if (len == HEf_SVKEY) {
3183 key_sv = HeKEY_sv(he);
3184 flags |= SHV_K_ISSV;
3185 } else {
3186 /* Regular string key. */
3187 #ifdef HAS_HASH_KEY_FLAGS
3188 if (HEK_UTF8(hek))
3189 flags |= SHV_K_UTF8;
3190 if (HEK_WASUTF8(hek))
3191 flags |= SHV_K_WASUTF8;
3192 #endif
3193 key = HEK_KEY(hek);
3194 }
3195 /*
3196 * Write key string.
3197 * Keys are written after values to make sure retrieval
3198 * can be optimal in terms of memory usage, where keys are
3199 * read into a fixed unique buffer called kbuf.
3200 * See retrieve_hash() for details.
3201 */
3202
3203 if (flagged_hash) {
3204 PUTMARK(flags);
3205 TRACEME(("(#%d) key '%s' flags %x", (int)i, key, flags));
3206 } else {
3207 /* This is a workaround for a bug in 5.8.0
3208 that causes the HEK_WASUTF8 flag to be
3209 set on an HEK without the hash being
3210 marked as having key flags. We just
3211 cross our fingers and drop the flag.
3212 AMS 20030901 */
3213 assert (flags == 0 || flags == SHV_K_WASUTF8);
3214 TRACEME(("(#%d) key '%s'", (int)i, key));
3215 }
3216 if (flags & SHV_K_ISSV) {
3217 if ((ret = store(aTHX_ cxt, key_sv)))
3218 return ret;
3219 } else {
3220 WLEN(len);
3221 if (len)
3222 WRITE(key, len);
3223 }
3224 }
3225 return ret;
3226 }
3227
3228
3229 #ifdef HAS_U64
3230 /*
3231 * store_lhash
3232 *
3233 * Store a overlong hash table, with >2G keys, which we cannot iterate
3234 * over with perl5. xhv_eiter is only I32 there. (only cperl can)
3235 * and we also do not want to sort it.
3236 * So we walk the buckets and chains manually.
3237 *
3238 * type, len and flags are already written.
3239 */
3240
store_lhash(pTHX_ stcxt_t * cxt,HV * hv,unsigned char hash_flags)3241 static int store_lhash(pTHX_ stcxt_t *cxt, HV *hv, unsigned char hash_flags)
3242 {
3243 dVAR;
3244 int ret = 0;
3245 Size_t i;
3246 UV ix = 0;
3247 HE** array;
3248 #ifdef DEBUGME
3249 UV len = (UV)HvTOTALKEYS(hv);
3250 #endif
3251 SV * const recur_sv = cxt->recur_sv;
3252 if (hash_flags) {
3253 TRACEME(("store_lhash (0x%" UVxf ") (flags %x)", PTR2UV(hv),
3254 (int) hash_flags));
3255 } else {
3256 TRACEME(("store_lhash (0x%" UVxf ")", PTR2UV(hv)));
3257 }
3258 TRACEME(("size = %" UVuf ", used = %" UVuf, len, (UV)HvUSEDKEYS(hv)));
3259
3260 TRACEME(("recur_depth %" IVdf ", recur_sv (0x%" UVxf ")", cxt->recur_depth,
3261 PTR2UV(cxt->recur_sv)));
3262 if (recur_sv != (SV*)hv && cxt->max_recur_depth_hash != -1) {
3263 ++cxt->recur_depth;
3264 }
3265 if (RECURSION_TOO_DEEP_HASH()) {
3266 #if PERL_VERSION < 15
3267 cleanup_recursive_data(aTHX_ (SV*)hv);
3268 #endif
3269 CROAK((MAX_DEPTH_ERROR));
3270 }
3271
3272 array = HvARRAY(hv);
3273 for (i = 0; i <= (Size_t)HvMAX(hv); i++) {
3274 HE* entry = array[i];
3275 if (!entry) continue;
3276 if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags)))
3277 return ret;
3278 while ((entry = HeNEXT(entry))) {
3279 if ((ret = store_hentry(aTHX_ cxt, hv, ix++, entry, hash_flags)))
3280 return ret;
3281 }
3282 }
3283 if (recur_sv == (SV*)hv && cxt->max_recur_depth_hash != -1 && cxt->recur_depth > 0) {
3284 TRACEME(("recur_depth --%" IVdf, cxt->recur_depth));
3285 --cxt->recur_depth;
3286 }
3287 assert(ix == len);
3288 return ret;
3289 }
3290 #endif
3291
3292 /*
3293 * store_code
3294 *
3295 * Store a code reference.
3296 *
3297 * Layout is SX_CODE <length> followed by a scalar containing the perl
3298 * source code of the code reference.
3299 */
store_code(pTHX_ stcxt_t * cxt,CV * cv)3300 static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
3301 {
3302 #if PERL_VERSION < 6
3303 /*
3304 * retrieve_code does not work with perl 5.005 or less
3305 */
3306 return store_other(aTHX_ cxt, (SV*)cv);
3307 #else
3308 dSP;
3309 STRLEN len;
3310 STRLEN count, reallen;
3311 SV *text, *bdeparse;
3312
3313 TRACEME(("store_code (0x%" UVxf ")", PTR2UV(cv)));
3314
3315 if (
3316 cxt->deparse == 0 ||
3317 (cxt->deparse < 0 &&
3318 !(cxt->deparse =
3319 SvTRUE(get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0))
3320 ) {
3321 return store_other(aTHX_ cxt, (SV*)cv);
3322 }
3323
3324 /*
3325 * Require B::Deparse. At least B::Deparse 0.61 is needed for
3326 * blessed code references.
3327 */
3328 /* Ownership of both SVs is passed to load_module, which frees them. */
3329 load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("B::Deparse"), newSVnv(0.61));
3330 SPAGAIN;
3331
3332 ENTER;
3333 SAVETMPS;
3334
3335 /*
3336 * create the B::Deparse object
3337 */
3338
3339 PUSHMARK(sp);
3340 XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP));
3341 PUTBACK;
3342 count = call_method("new", G_SCALAR);
3343 SPAGAIN;
3344 if (count != 1)
3345 CROAK(("Unexpected return value from B::Deparse::new\n"));
3346 bdeparse = POPs;
3347
3348 /*
3349 * call the coderef2text method
3350 */
3351
3352 PUSHMARK(sp);
3353 XPUSHs(bdeparse); /* XXX is this already mortal? */
3354 XPUSHs(sv_2mortal(newRV_inc((SV*)cv)));
3355 PUTBACK;
3356 count = call_method("coderef2text", G_SCALAR);
3357 SPAGAIN;
3358 if (count != 1)
3359 CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
3360
3361 text = POPs;
3362 len = SvCUR(text);
3363 reallen = strlen(SvPV_nolen(text));
3364
3365 /*
3366 * Empty code references or XS functions are deparsed as
3367 * "(prototype) ;" or ";".
3368 */
3369
3370 if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') {
3371 CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
3372 }
3373
3374 /*
3375 * Signal code by emitting SX_CODE.
3376 */
3377
3378 PUTMARK(SX_CODE);
3379 cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */
3380 TRACEME(("size = %d", (int)len));
3381 TRACEME(("code = %s", SvPV_nolen(text)));
3382
3383 /*
3384 * Now store the source code.
3385 */
3386
3387 if(SvUTF8 (text))
3388 STORE_UTF8STR(SvPV_nolen(text), len);
3389 else
3390 STORE_SCALAR(SvPV_nolen(text), len);
3391
3392 FREETMPS;
3393 LEAVE;
3394
3395 TRACEME(("ok (code)"));
3396
3397 return 0;
3398 #endif
3399 }
3400
3401 #if PERL_VERSION < 8
3402 # define PERL_MAGIC_qr 'r' /* precompiled qr// regex */
3403 # define BFD_Svs_SMG_OR_RMG SVs_RMG
3404 #elif ((PERL_VERSION==8) && (PERL_SUBVERSION >= 1) || (PERL_VERSION>8))
3405 # define BFD_Svs_SMG_OR_RMG SVs_SMG
3406 # define MY_PLACEHOLDER PL_sv_placeholder
3407 #else
3408 # define BFD_Svs_SMG_OR_RMG SVs_RMG
3409 # define MY_PLACEHOLDER PL_sv_undef
3410 #endif
3411
get_regexp(pTHX_ stcxt_t * cxt,SV * sv,SV ** re,SV ** flags)3412 static int get_regexp(pTHX_ stcxt_t *cxt, SV* sv, SV **re, SV **flags) {
3413 dSP;
3414 SV* rv;
3415 #if PERL_VERSION >= 12
3416 CV *cv = get_cv("re::regexp_pattern", 0);
3417 #else
3418 CV *cv = get_cv("Storable::_regexp_pattern", 0);
3419 #endif
3420 I32 count;
3421
3422 assert(cv);
3423
3424 ENTER;
3425 SAVETMPS;
3426 rv = sv_2mortal((SV*)newRV_inc(sv));
3427 PUSHMARK(sp);
3428 XPUSHs(rv);
3429 PUTBACK;
3430 /* optimize to call the XS directly later */
3431 count = call_sv((SV*)cv, G_ARRAY);
3432 SPAGAIN;
3433 if (count < 2)
3434 CROAK(("re::regexp_pattern returned only %d results", count));
3435 *flags = POPs;
3436 SvREFCNT_inc(*flags);
3437 *re = POPs;
3438 SvREFCNT_inc(*re);
3439
3440 PUTBACK;
3441 FREETMPS;
3442 LEAVE;
3443
3444 return 1;
3445 }
3446
store_regexp(pTHX_ stcxt_t * cxt,SV * sv)3447 static int store_regexp(pTHX_ stcxt_t *cxt, SV *sv) {
3448 SV *re = NULL;
3449 SV *flags = NULL;
3450 const char *re_pv;
3451 const char *flags_pv;
3452 STRLEN re_len;
3453 STRLEN flags_len;
3454 U8 op_flags = 0;
3455
3456 if (!get_regexp(aTHX_ cxt, sv, &re, &flags))
3457 return -1;
3458
3459 re_pv = SvPV(re, re_len);
3460 flags_pv = SvPV(flags, flags_len);
3461
3462 if (re_len > 0xFF) {
3463 op_flags |= SHR_U32_RE_LEN;
3464 }
3465
3466 PUTMARK(SX_REGEXP);
3467 PUTMARK(op_flags);
3468 if (op_flags & SHR_U32_RE_LEN) {
3469 U32 re_len32 = re_len;
3470 WLEN(re_len32);
3471 }
3472 else
3473 PUTMARK(re_len);
3474 WRITE(re_pv, re_len);
3475 PUTMARK(flags_len);
3476 WRITE(flags_pv, flags_len);
3477
3478 return 0;
3479 }
3480
3481 /*
3482 * store_tied
3483 *
3484 * When storing a tied object (be it a tied scalar, array or hash), we lay out
3485 * a special mark, followed by the underlying tied object. For instance, when
3486 * dealing with a tied hash, we store SX_TIED_HASH <hash object>, where
3487 * <hash object> stands for the serialization of the tied hash.
3488 */
store_tied(pTHX_ stcxt_t * cxt,SV * sv)3489 static int store_tied(pTHX_ stcxt_t *cxt, SV *sv)
3490 {
3491 MAGIC *mg;
3492 SV *obj = NULL;
3493 int ret = 0;
3494 int svt = SvTYPE(sv);
3495 char mtype = 'P';
3496
3497 TRACEME(("store_tied (0x%" UVxf ")", PTR2UV(sv)));
3498
3499 /*
3500 * We have a small run-time penalty here because we chose to factorise
3501 * all tieds objects into the same routine, and not have a store_tied_hash,
3502 * a store_tied_array, etc...
3503 *
3504 * Don't use a switch() statement, as most compilers don't optimize that
3505 * well for 2/3 values. An if() else if() cascade is just fine. We put
3506 * tied hashes first, as they are the most likely beasts.
3507 */
3508
3509 if (svt == SVt_PVHV) {
3510 TRACEME(("tied hash"));
3511 PUTMARK(SX_TIED_HASH); /* Introduces tied hash */
3512 } else if (svt == SVt_PVAV) {
3513 TRACEME(("tied array"));
3514 PUTMARK(SX_TIED_ARRAY); /* Introduces tied array */
3515 } else {
3516 TRACEME(("tied scalar"));
3517 PUTMARK(SX_TIED_SCALAR); /* Introduces tied scalar */
3518 mtype = 'q';
3519 }
3520
3521 if (!(mg = mg_find(sv, mtype)))
3522 CROAK(("No magic '%c' found while storing tied %s", mtype,
3523 (svt == SVt_PVHV) ? "hash" :
3524 (svt == SVt_PVAV) ? "array" : "scalar"));
3525
3526 /*
3527 * The mg->mg_obj found by mg_find() above actually points to the
3528 * underlying tied Perl object implementation. For instance, if the
3529 * original SV was that of a tied array, then mg->mg_obj is an AV.
3530 *
3531 * Note that we store the Perl object as-is. We don't call its FETCH
3532 * method along the way. At retrieval time, we won't call its STORE
3533 * method either, but the tieing magic will be re-installed. In itself,
3534 * that ensures that the tieing semantics are preserved since further
3535 * accesses on the retrieved object will indeed call the magic methods...
3536 */
3537
3538 /* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */
3539 obj = mg->mg_obj ? mg->mg_obj : newSV(0);
3540 if ((ret = store(aTHX_ cxt, obj)))
3541 return ret;
3542
3543 TRACEME(("ok (tied)"));
3544
3545 return 0;
3546 }
3547
3548 /*
3549 * store_tied_item
3550 *
3551 * Stores a reference to an item within a tied structure:
3552 *
3553 * . \$h{key}, stores both the (tied %h) object and 'key'.
3554 * . \$a[idx], stores both the (tied @a) object and 'idx'.
3555 *
3556 * Layout is therefore either:
3557 * SX_TIED_KEY <object> <key>
3558 * SX_TIED_IDX <object> <index>
3559 */
store_tied_item(pTHX_ stcxt_t * cxt,SV * sv)3560 static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv)
3561 {
3562 MAGIC *mg;
3563 int ret;
3564
3565 TRACEME(("store_tied_item (0x%" UVxf ")", PTR2UV(sv)));
3566
3567 if (!(mg = mg_find(sv, 'p')))
3568 CROAK(("No magic 'p' found while storing reference to tied item"));
3569
3570 /*
3571 * We discriminate between \$h{key} and \$a[idx] via mg_ptr.
3572 */
3573
3574 if (mg->mg_ptr) {
3575 TRACEME(("store_tied_item: storing a ref to a tied hash item"));
3576 PUTMARK(SX_TIED_KEY);
3577 TRACEME(("store_tied_item: storing OBJ 0x%" UVxf, PTR2UV(mg->mg_obj)));
3578
3579 if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */
3580 return ret;
3581
3582 TRACEME(("store_tied_item: storing PTR 0x%" UVxf, PTR2UV(mg->mg_ptr)));
3583
3584 if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */
3585 return ret;
3586 } else {
3587 I32 idx = mg->mg_len;
3588
3589 TRACEME(("store_tied_item: storing a ref to a tied array item "));
3590 PUTMARK(SX_TIED_IDX);
3591 TRACEME(("store_tied_item: storing OBJ 0x%" UVxf, PTR2UV(mg->mg_obj)));
3592
3593 if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */
3594 return ret;
3595
3596 TRACEME(("store_tied_item: storing IDX %d", (int)idx));
3597
3598 WLEN(idx);
3599 }
3600
3601 TRACEME(("ok (tied item)"));
3602
3603 return 0;
3604 }
3605
3606 /*
3607 * store_hook -- dispatched manually, not via sv_store[]
3608 *
3609 * The blessed SV is serialized by a hook.
3610 *
3611 * Simple Layout is:
3612 *
3613 * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
3614 *
3615 * where <flags> indicates how long <len>, <len2> and <len3> are, whether
3616 * the trailing part [] is present, the type of object (scalar, array or hash).
3617 * There is also a bit which says how the classname is stored between:
3618 *
3619 * <len> <classname>
3620 * <index>
3621 *
3622 * and when the <index> form is used (classname already seen), the "large
3623 * classname" bit in <flags> indicates how large the <index> is.
3624 *
3625 * The serialized string returned by the hook is of length <len2> and comes
3626 * next. It is an opaque string for us.
3627 *
3628 * Those <len3> object IDs which are listed last represent the extra references
3629 * not directly serialized by the hook, but which are linked to the object.
3630 *
3631 * When recursion is mandated to resolve object-IDs not yet seen, we have
3632 * instead, with <header> being flags with bits set to indicate the object type
3633 * and that recursion was indeed needed:
3634 *
3635 * SX_HOOK <header> <object> <header> <object> <flags>
3636 *
3637 * that same header being repeated between serialized objects obtained through
3638 * recursion, until we reach flags indicating no recursion, at which point
3639 * we know we've resynchronized with a single layout, after <flags>.
3640 *
3641 * When storing a blessed ref to a tied variable, the following format is
3642 * used:
3643 *
3644 * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
3645 *
3646 * The first <flags> indication carries an object of type SHT_EXTRA, and the
3647 * real object type is held in the <extra> flag. At the very end of the
3648 * serialization stream, the underlying magic object is serialized, just like
3649 * any other tied variable.
3650 */
store_hook(pTHX_ stcxt_t * cxt,SV * sv,int type,HV * pkg,SV * hook)3651 static int store_hook(
3652 pTHX_
3653 stcxt_t *cxt,
3654 SV *sv,
3655 int type,
3656 HV *pkg,
3657 SV *hook)
3658 {
3659 I32 len;
3660 char *classname;
3661 STRLEN len2;
3662 SV *ref;
3663 AV *av;
3664 SV **ary;
3665 int count; /* really len3 + 1 */
3666 unsigned char flags;
3667 char *pv;
3668 int i;
3669 int recursed = 0; /* counts recursion */
3670 int obj_type; /* object type, on 2 bits */
3671 I32 classnum;
3672 int ret;
3673 int clone = cxt->optype & ST_CLONE;
3674 char mtype = '\0'; /* for blessed ref to tied structures */
3675 unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */
3676 #ifdef HAS_U64
3677 int need_large_oids = 0;
3678 #endif
3679
3680 TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), (int)cxt->tagnum));
3681
3682 /*
3683 * Determine object type on 2 bits.
3684 */
3685
3686 switch (type) {
3687 case svis_REF:
3688 case svis_SCALAR:
3689 obj_type = SHT_SCALAR;
3690 break;
3691 case svis_ARRAY:
3692 obj_type = SHT_ARRAY;
3693 break;
3694 case svis_HASH:
3695 obj_type = SHT_HASH;
3696 break;
3697 case svis_TIED:
3698 /*
3699 * Produced by a blessed ref to a tied data structure, $o in the
3700 * following Perl code.
3701 *
3702 * my %h;
3703 * tie %h, 'FOO';
3704 * my $o = bless \%h, 'BAR';
3705 *
3706 * Signal the tie-ing magic by setting the object type as SHT_EXTRA
3707 * (since we have only 2 bits in <flags> to store the type), and an
3708 * <extra> byte flag will be emitted after the FIRST <flags> in the
3709 * stream, carrying what we put in 'eflags'.
3710 */
3711 obj_type = SHT_EXTRA;
3712 switch (SvTYPE(sv)) {
3713 case SVt_PVHV:
3714 eflags = (unsigned char) SHT_THASH;
3715 mtype = 'P';
3716 break;
3717 case SVt_PVAV:
3718 eflags = (unsigned char) SHT_TARRAY;
3719 mtype = 'P';
3720 break;
3721 default:
3722 eflags = (unsigned char) SHT_TSCALAR;
3723 mtype = 'q';
3724 break;
3725 }
3726 break;
3727 default:
3728 CROAK(("Unexpected object type (%d) in store_hook()", type));
3729 }
3730 flags = SHF_NEED_RECURSE | obj_type;
3731
3732 classname = HvNAME_get(pkg);
3733 len = strlen(classname);
3734
3735 /*
3736 * To call the hook, we need to fake a call like:
3737 *
3738 * $object->STORABLE_freeze($cloning);
3739 *
3740 * but we don't have the $object here. For instance, if $object is
3741 * a blessed array, what we have in 'sv' is the array, and we can't
3742 * call a method on those.
3743 *
3744 * Therefore, we need to create a temporary reference to the object and
3745 * make the call on that reference.
3746 */
3747
3748 TRACEME(("about to call STORABLE_freeze on class %s", classname));
3749
3750 ref = newRV_inc(sv); /* Temporary reference */
3751 av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */
3752 SvREFCNT_dec(ref); /* Reclaim temporary reference */
3753
3754 count = AvFILLp(av) + 1;
3755 TRACEME(("store_hook, array holds %d items", count));
3756
3757 /*
3758 * If they return an empty list, it means they wish to ignore the
3759 * hook for this class (and not just this instance -- that's for them
3760 * to handle if they so wish).
3761 *
3762 * Simply disable the cached entry for the hook (it won't be recomputed
3763 * since it's present in the cache) and recurse to store_blessed().
3764 */
3765
3766 if (!count) {
3767 /* free empty list returned by the hook */
3768 av_undef(av);
3769 sv_free((SV *) av);
3770
3771 /*
3772 * They must not change their mind in the middle of a serialization.
3773 */
3774
3775 if (hv_fetch(cxt->hclass, classname, len, FALSE))
3776 CROAK(("Too late to ignore hooks for %s class \"%s\"",
3777 (cxt->optype & ST_CLONE) ? "cloning" : "storing",
3778 classname));
3779
3780 pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
3781
3782 ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"),
3783 ("hook invisible"));
3784 TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname));
3785
3786 return store_blessed(aTHX_ cxt, sv, type, pkg);
3787 }
3788
3789 /*
3790 * Get frozen string.
3791 */
3792
3793 ary = AvARRAY(av);
3794 pv = SvPV(ary[0], len2);
3795 /* We can't use pkg_can here because it only caches one method per
3796 * package */
3797 {
3798 GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE);
3799 if (gv && isGV(gv)) {
3800 if (count > 1)
3801 CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname));
3802 goto check_done;
3803 }
3804 }
3805
3806 #ifdef HAS_U64
3807 if (count > I32_MAX) {
3808 CROAK(("Too many references returned by STORABLE_freeze()"));
3809 }
3810 #endif
3811
3812 /*
3813 * If they returned more than one item, we need to serialize some
3814 * extra references if not already done.
3815 *
3816 * Loop over the array, starting at position #1, and for each item,
3817 * ensure it is a reference, serialize it if not already done, and
3818 * replace the entry with the tag ID of the corresponding serialized
3819 * object.
3820 *
3821 * We CHEAT by not calling av_fetch() and read directly within the
3822 * array, for speed.
3823 */
3824
3825 for (i = 1; i < count; i++) {
3826 #ifdef USE_PTR_TABLE
3827 char *fake_tag;
3828 #else
3829 SV **svh;
3830 #endif
3831 SV *rsv = ary[i];
3832 SV *xsv;
3833 SV *tag;
3834 AV *av_hook = cxt->hook_seen;
3835
3836 if (!SvROK(rsv))
3837 CROAK(("Item #%d returned by STORABLE_freeze "
3838 "for %s is not a reference", (int)i, classname));
3839 xsv = SvRV(rsv); /* Follow ref to know what to look for */
3840
3841 /*
3842 * Look in hseen and see if we have a tag already.
3843 * Serialize entry if not done already, and get its tag.
3844 */
3845
3846 #ifdef USE_PTR_TABLE
3847 /* Fakery needed because ptr_table_fetch returns zero for a
3848 failure, whereas the existing code assumes that it can
3849 safely store a tag zero. So for ptr_tables we store tag+1
3850 */
3851 if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv)))
3852 goto sv_seen; /* Avoid moving code too far to the right */
3853 #else
3854 if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE)))
3855 goto sv_seen; /* Avoid moving code too far to the right */
3856 #endif
3857
3858 TRACEME(("listed object %d at 0x%" UVxf " is unknown", i-1,
3859 PTR2UV(xsv)));
3860
3861 /*
3862 * We need to recurse to store that object and get it to be known
3863 * so that we can resolve the list of object-IDs at retrieve time.
3864 *
3865 * The first time we do this, we need to emit the proper header
3866 * indicating that we recursed, and what the type of object is (the
3867 * object we're storing via a user-hook). Indeed, during retrieval,
3868 * we'll have to create the object before recursing to retrieve the
3869 * others, in case those would point back at that object.
3870 */
3871
3872 /* [SX_HOOK] <flags> [<extra>] <object>*/
3873 if (!recursed++) {
3874 #ifdef HAS_U64
3875 if (len2 > INT32_MAX)
3876 PUTMARK(SX_LOBJECT);
3877 #endif
3878 PUTMARK(SX_HOOK);
3879 PUTMARK(flags);
3880 if (obj_type == SHT_EXTRA)
3881 PUTMARK(eflags);
3882 } else
3883 PUTMARK(flags);
3884
3885 if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */
3886 return ret;
3887
3888 #ifdef USE_PTR_TABLE
3889 fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv);
3890 if (!fake_tag)
3891 CROAK(("Could not serialize item #%d from hook in %s",
3892 (int)i, classname));
3893 #else
3894 svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE);
3895 if (!svh)
3896 CROAK(("Could not serialize item #%d from hook in %s",
3897 (int)i, classname));
3898 #endif
3899 /*
3900 * It was the first time we serialized 'xsv'.
3901 *
3902 * Keep this SV alive until the end of the serialization: if we
3903 * disposed of it right now by decrementing its refcount, and it was
3904 * a temporary value, some next temporary value allocated during
3905 * another STORABLE_freeze might take its place, and we'd wrongly
3906 * assume that new SV was already serialized, based on its presence
3907 * in cxt->hseen.
3908 *
3909 * Therefore, push it away in cxt->hook_seen.
3910 */
3911
3912 av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv));
3913
3914 sv_seen:
3915 /*
3916 * Dispose of the REF they returned. If we saved the 'xsv' away
3917 * in the array of returned SVs, that will not cause the underlying
3918 * referenced SV to be reclaimed.
3919 */
3920
3921 ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF"));
3922 SvREFCNT_dec(rsv); /* Dispose of reference */
3923
3924 /*
3925 * Replace entry with its tag (not a real SV, so no refcnt increment)
3926 */
3927
3928 #ifdef USE_PTR_TABLE
3929 tag = (SV *)--fake_tag;
3930 #else
3931 tag = *svh;
3932 #endif
3933 ary[i] = tag;
3934 TRACEME(("listed object %d at 0x%" UVxf " is tag #%" UVuf,
3935 i-1, PTR2UV(xsv), PTR2UV(tag)));
3936 #ifdef HAS_U64
3937 if ((U32)PTR2TAG(tag) != PTR2TAG(tag))
3938 need_large_oids = 1;
3939 #endif
3940 }
3941
3942 /*
3943 * Allocate a class ID if not already done.
3944 *
3945 * This needs to be done after the recursion above, since at retrieval
3946 * time, we'll see the inner objects first. Many thanks to
3947 * Salvador Ortiz Garcia <sog@msg.com.mx> who spot that bug and
3948 * proposed the right fix. -- RAM, 15/09/2000
3949 */
3950
3951 check_done:
3952 if (!known_class(aTHX_ cxt, classname, len, &classnum)) {
3953 TRACEME(("first time we see class %s, ID = %d", classname, (int)classnum));
3954 classnum = -1; /* Mark: we must store classname */
3955 } else {
3956 TRACEME(("already seen class %s, ID = %d", classname, (int)classnum));
3957 }
3958
3959 /*
3960 * Compute leading flags.
3961 */
3962
3963 flags = obj_type;
3964 if (((classnum == -1) ? len : classnum) > LG_SCALAR)
3965 flags |= SHF_LARGE_CLASSLEN;
3966 if (classnum != -1)
3967 flags |= SHF_IDX_CLASSNAME;
3968 if (len2 > LG_SCALAR)
3969 flags |= SHF_LARGE_STRLEN;
3970 if (count > 1)
3971 flags |= SHF_HAS_LIST;
3972 if (count > (LG_SCALAR + 1))
3973 flags |= SHF_LARGE_LISTLEN;
3974 #ifdef HAS_U64
3975 if (need_large_oids)
3976 flags |= SHF_LARGE_LISTLEN;
3977 #endif
3978
3979 /*
3980 * We're ready to emit either serialized form:
3981 *
3982 * SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
3983 * SX_HOOK <flags> <index> <len2> <str> [<len3> <object-IDs>]
3984 *
3985 * If we recursed, the SX_HOOK has already been emitted.
3986 */
3987
3988 TRACEME(("SX_HOOK (recursed=%d) flags=0x%x "
3989 "class=%" IVdf " len=%" IVdf " len2=%" IVdf " len3=%d",
3990 recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1));
3991
3992 /* SX_HOOK <flags> [<extra>] */
3993 if (!recursed) {
3994 #ifdef HAS_U64
3995 if (len2 > INT32_MAX)
3996 PUTMARK(SX_LOBJECT);
3997 #endif
3998 PUTMARK(SX_HOOK);
3999 PUTMARK(flags);
4000 if (obj_type == SHT_EXTRA)
4001 PUTMARK(eflags);
4002 } else
4003 PUTMARK(flags);
4004
4005 /* <len> <classname> or <index> */
4006 if (flags & SHF_IDX_CLASSNAME) {
4007 if (flags & SHF_LARGE_CLASSLEN)
4008 WLEN(classnum);
4009 else {
4010 unsigned char cnum = (unsigned char) classnum;
4011 PUTMARK(cnum);
4012 }
4013 } else {
4014 if (flags & SHF_LARGE_CLASSLEN)
4015 WLEN(len);
4016 else {
4017 unsigned char clen = (unsigned char) len;
4018 PUTMARK(clen);
4019 }
4020 WRITE(classname, len); /* Final \0 is omitted */
4021 }
4022
4023 /* <len2> <frozen-str> */
4024 #ifdef HAS_U64
4025 if (len2 > INT32_MAX) {
4026 W64LEN(len2);
4027 }
4028 else
4029 #endif
4030 if (flags & SHF_LARGE_STRLEN) {
4031 U32 wlen2 = len2; /* STRLEN might be 8 bytes */
4032 WLEN(wlen2); /* Must write an I32 for 64-bit machines */
4033 } else {
4034 unsigned char clen = (unsigned char) len2;
4035 PUTMARK(clen);
4036 }
4037 if (len2)
4038 WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */
4039
4040 /* [<len3> <object-IDs>] */
4041 if (flags & SHF_HAS_LIST) {
4042 int len3 = count - 1;
4043 if (flags & SHF_LARGE_LISTLEN) {
4044 #ifdef HAS_U64
4045 int tlen3 = need_large_oids ? -len3 : len3;
4046 WLEN(tlen3);
4047 #else
4048 WLEN(len3);
4049 #endif
4050 }
4051 else {
4052 unsigned char clen = (unsigned char) len3;
4053 PUTMARK(clen);
4054 }
4055
4056 /*
4057 * NOTA BENE, for 64-bit machines: the ary[i] below does not yield a
4058 * real pointer, rather a tag number, well under the 32-bit limit.
4059 * Which is wrong... if we have more than 2**32 SVs we can get ids over
4060 * the 32-bit limit.
4061 */
4062
4063 for (i = 1; i < count; i++) {
4064 #ifdef HAS_U64
4065 if (need_large_oids) {
4066 ntag_t tag = PTR2TAG(ary[i]);
4067 W64LEN(tag);
4068 TRACEME(("object %d, tag #%" UVuf, i-1, (UV)tag));
4069 }
4070 else
4071 #endif
4072 {
4073 I32 tagval = htonl(LOW_32BITS(ary[i]));
4074 WRITE_I32(tagval);
4075 TRACEME(("object %d, tag #%d", i-1, ntohl(tagval)));
4076 }
4077 }
4078 }
4079
4080 /*
4081 * Free the array. We need extra care for indices after 0, since they
4082 * don't hold real SVs but integers cast.
4083 */
4084
4085 if (count > 1)
4086 AvFILLp(av) = 0; /* Cheat, nothing after 0 interests us */
4087 av_undef(av);
4088 sv_free((SV *) av);
4089
4090 /*
4091 * If object was tied, need to insert serialization of the magic object.
4092 */
4093
4094 if (obj_type == SHT_EXTRA) {
4095 MAGIC *mg;
4096
4097 if (!(mg = mg_find(sv, mtype))) {
4098 int svt = SvTYPE(sv);
4099 CROAK(("No magic '%c' found while storing ref to tied %s with hook",
4100 mtype, (svt == SVt_PVHV) ? "hash" :
4101 (svt == SVt_PVAV) ? "array" : "scalar"));
4102 }
4103
4104 TRACEME(("handling the magic object 0x%" UVxf " part of 0x%" UVxf,
4105 PTR2UV(mg->mg_obj), PTR2UV(sv)));
4106
4107 /*
4108 * [<magic object>]
4109 */
4110 if ((ret = store(aTHX_ cxt, mg->mg_obj)))
4111 return ret;
4112 }
4113
4114 return 0;
4115 }
4116
4117 /*
4118 * store_blessed -- dispatched manually, not via sv_store[]
4119 *
4120 * Check whether there is a STORABLE_xxx hook defined in the class or in one
4121 * of its ancestors. If there is, then redispatch to store_hook();
4122 *
4123 * Otherwise, the blessed SV is stored using the following layout:
4124 *
4125 * SX_BLESS <flag> <len> <classname> <object>
4126 *
4127 * where <flag> indicates whether <len> is stored on 0 or 4 bytes, depending
4128 * on the high-order bit in flag: if 1, then length follows on 4 bytes.
4129 * Otherwise, the low order bits give the length, thereby giving a compact
4130 * representation for class names less than 127 chars long.
4131 *
4132 * Each <classname> seen is remembered and indexed, so that the next time
4133 * an object in the blessed in the same <classname> is stored, the following
4134 * will be emitted:
4135 *
4136 * SX_IX_BLESS <flag> <index> <object>
4137 *
4138 * where <index> is the classname index, stored on 0 or 4 bytes depending
4139 * on the high-order bit in flag (same encoding as above for <len>).
4140 */
store_blessed(pTHX_ stcxt_t * cxt,SV * sv,int type,HV * pkg)4141 static int store_blessed(
4142 pTHX_
4143 stcxt_t *cxt,
4144 SV *sv,
4145 int type,
4146 HV *pkg)
4147 {
4148 SV *hook;
4149 char *classname;
4150 I32 len;
4151 I32 classnum;
4152
4153 TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg)));
4154
4155 /*
4156 * Look for a hook for this blessed SV and redirect to store_hook()
4157 * if needed.
4158 */
4159
4160 hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze");
4161 if (hook)
4162 return store_hook(aTHX_ cxt, sv, type, pkg, hook);
4163
4164 /*
4165 * This is a blessed SV without any serialization hook.
4166 */
4167
4168 classname = HvNAME_get(pkg);
4169 len = strlen(classname);
4170
4171 TRACEME(("blessed 0x%" UVxf " in %s, no hook: tagged #%d",
4172 PTR2UV(sv), classname, (int)cxt->tagnum));
4173
4174 /*
4175 * Determine whether it is the first time we see that class name (in which
4176 * case it will be stored in the SX_BLESS form), or whether we already
4177 * saw that class name before (in which case the SX_IX_BLESS form will be
4178 * used).
4179 */
4180
4181 if (known_class(aTHX_ cxt, classname, len, &classnum)) {
4182 TRACEME(("already seen class %s, ID = %d", classname, (int)classnum));
4183 PUTMARK(SX_IX_BLESS);
4184 if (classnum <= LG_BLESS) {
4185 unsigned char cnum = (unsigned char) classnum;
4186 PUTMARK(cnum);
4187 } else {
4188 unsigned char flag = (unsigned char) 0x80;
4189 PUTMARK(flag);
4190 WLEN(classnum);
4191 }
4192 } else {
4193 TRACEME(("first time we see class %s, ID = %d", classname,
4194 (int)classnum));
4195 PUTMARK(SX_BLESS);
4196 if (len <= LG_BLESS) {
4197 unsigned char clen = (unsigned char) len;
4198 PUTMARK(clen);
4199 } else {
4200 unsigned char flag = (unsigned char) 0x80;
4201 PUTMARK(flag);
4202 WLEN(len); /* Don't BER-encode, this should be rare */
4203 }
4204 WRITE(classname, len); /* Final \0 is omitted */
4205 }
4206
4207 /*
4208 * Now emit the <object> part.
4209 */
4210
4211 return SV_STORE(type)(aTHX_ cxt, sv);
4212 }
4213
4214 /*
4215 * store_other
4216 *
4217 * We don't know how to store the item we reached, so return an error condition.
4218 * (it's probably a GLOB, some CODE reference, etc...)
4219 *
4220 * If they defined the 'forgive_me' variable at the Perl level to some
4221 * true value, then don't croak, just warn, and store a placeholder string
4222 * instead.
4223 */
store_other(pTHX_ stcxt_t * cxt,SV * sv)4224 static int store_other(pTHX_ stcxt_t *cxt, SV *sv)
4225 {
4226 STRLEN len;
4227 char buf[80];
4228
4229 TRACEME(("store_other"));
4230
4231 /*
4232 * Fetch the value from perl only once per store() operation.
4233 */
4234
4235 if (
4236 cxt->forgive_me == 0 ||
4237 (cxt->forgive_me < 0 &&
4238 !(cxt->forgive_me = SvTRUE
4239 (get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
4240 )
4241 CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
4242
4243 warn("Can't store item %s(0x%" UVxf ")",
4244 sv_reftype(sv, FALSE), PTR2UV(sv));
4245
4246 /*
4247 * Store placeholder string as a scalar instead...
4248 */
4249
4250 (void) sprintf(buf, "You lost %s(0x%" UVxf ")%c", sv_reftype(sv, FALSE),
4251 PTR2UV(sv), (char) 0);
4252
4253 len = strlen(buf);
4254 if (len < 80)
4255 STORE_SCALAR(buf, len);
4256 TRACEME(("ok (dummy \"%s\", length = %" IVdf ")", buf, (IV) len));
4257
4258 return 0;
4259 }
4260
4261 /***
4262 *** Store driving routines
4263 ***/
4264
4265 /*
4266 * sv_type
4267 *
4268 * WARNING: partially duplicates Perl's sv_reftype for speed.
4269 *
4270 * Returns the type of the SV, identified by an integer. That integer
4271 * may then be used to index the dynamic routine dispatch table.
4272 */
sv_type(pTHX_ SV * sv)4273 static int sv_type(pTHX_ SV *sv)
4274 {
4275 switch (SvTYPE(sv)) {
4276 case SVt_NULL:
4277 #if PERL_VERSION <= 10
4278 case SVt_IV:
4279 #endif
4280 case SVt_NV:
4281 /*
4282 * No need to check for ROK, that can't be set here since there
4283 * is no field capable of hodling the xrv_rv reference.
4284 */
4285 return svis_SCALAR;
4286 case SVt_PV:
4287 #if PERL_VERSION <= 10
4288 case SVt_RV:
4289 #else
4290 case SVt_IV:
4291 #endif
4292 case SVt_PVIV:
4293 case SVt_PVNV:
4294 /*
4295 * Starting from SVt_PV, it is possible to have the ROK flag
4296 * set, the pointer to the other SV being either stored in
4297 * the xrv_rv (in the case of a pure SVt_RV), or as the
4298 * xpv_pv field of an SVt_PV and its heirs.
4299 *
4300 * However, those SV cannot be magical or they would be an
4301 * SVt_PVMG at least.
4302 */
4303 return SvROK(sv) ? svis_REF : svis_SCALAR;
4304 case SVt_PVMG:
4305 #if PERL_VERSION <= 10
4306 if ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
4307 == (SVs_OBJECT|BFD_Svs_SMG_OR_RMG)
4308 && mg_find(sv, PERL_MAGIC_qr)) {
4309 return svis_REGEXP;
4310 }
4311 #endif
4312 case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */
4313 if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) ==
4314 (SVs_GMG|SVs_SMG|SVs_RMG) &&
4315 (mg_find(sv, 'p')))
4316 return svis_TIED_ITEM;
4317 /* FALL THROUGH */
4318 #if PERL_VERSION < 9
4319 case SVt_PVBM:
4320 #endif
4321 if ((SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) ==
4322 (SVs_GMG|SVs_SMG|SVs_RMG) &&
4323 (mg_find(sv, 'q')))
4324 return svis_TIED;
4325 return SvROK(sv) ? svis_REF : svis_SCALAR;
4326 case SVt_PVAV:
4327 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
4328 return svis_TIED;
4329 return svis_ARRAY;
4330 case SVt_PVHV:
4331 if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
4332 return svis_TIED;
4333 return svis_HASH;
4334 case SVt_PVCV:
4335 return svis_CODE;
4336 #if PERL_VERSION > 8
4337 /* case SVt_INVLIST: */
4338 #endif
4339 #if PERL_VERSION > 10
4340 case SVt_REGEXP:
4341 return svis_REGEXP;
4342 #endif
4343 default:
4344 break;
4345 }
4346
4347 return svis_OTHER;
4348 }
4349
4350 /*
4351 * store
4352 *
4353 * Recursively store objects pointed to by the sv to the specified file.
4354 *
4355 * Layout is <content> or SX_OBJECT <tagnum> if we reach an already stored
4356 * object (one for which storage has started -- it may not be over if we have
4357 * a self-referenced structure). This data set forms a stored <object>.
4358 */
store(pTHX_ stcxt_t * cxt,SV * sv)4359 static int store(pTHX_ stcxt_t *cxt, SV *sv)
4360 {
4361 SV **svh;
4362 int ret;
4363 int type;
4364 #ifdef USE_PTR_TABLE
4365 struct ptr_tbl *pseen = cxt->pseen;
4366 #else
4367 HV *hseen = cxt->hseen;
4368 #endif
4369
4370 TRACEME(("store (0x%" UVxf ")", PTR2UV(sv)));
4371
4372 /*
4373 * If object has already been stored, do not duplicate data.
4374 * Simply emit the SX_OBJECT marker followed by its tag data.
4375 * The tag is always written in network order.
4376 *
4377 * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a
4378 * real pointer, rather a tag number (watch the insertion code below).
4379 * That means it probably safe to assume it is well under the 32-bit
4380 * limit, and makes the truncation safe.
4381 * -- RAM, 14/09/1999
4382 */
4383
4384 #ifdef USE_PTR_TABLE
4385 svh = (SV **)ptr_table_fetch(pseen, sv);
4386 #else
4387 svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE);
4388 #endif
4389 if (svh) {
4390 ntag_t tagval;
4391 if (sv == &PL_sv_undef) {
4392 /* We have seen PL_sv_undef before, but fake it as
4393 if we have not.
4394
4395 Not the simplest solution to making restricted
4396 hashes work on 5.8.0, but it does mean that
4397 repeated references to the one true undef will
4398 take up less space in the output file.
4399 */
4400 /* Need to jump past the next hv_store, because on the
4401 second store of undef the old hash value will be
4402 SvREFCNT_dec()ed, and as Storable cheats horribly
4403 by storing non-SVs in the hash a SEGV will ensure.
4404 Need to increase the tag number so that the
4405 receiver has no idea what games we're up to. This
4406 special casing doesn't affect hooks that store
4407 undef, as the hook routine does its own lookup into
4408 hseen. Also this means that any references back
4409 to PL_sv_undef (from the pathological case of hooks
4410 storing references to it) will find the seen hash
4411 entry for the first time, as if we didn't have this
4412 hackery here. (That hseen lookup works even on 5.8.0
4413 because it's a key of &PL_sv_undef and a value
4414 which is a tag number, not a value which is
4415 PL_sv_undef.) */
4416 cxt->tagnum++;
4417 type = svis_SCALAR;
4418 goto undef_special_case;
4419 }
4420
4421 #ifdef USE_PTR_TABLE
4422 tagval = PTR2TAG(((char *)svh)-1);
4423 #else
4424 tagval = PTR2TAG(*svh);
4425 #endif
4426 #ifdef HAS_U64
4427
4428 /* older versions of Storable streat the tag as a signed value
4429 used in an array lookup, corrupting the data structure.
4430 Ensure only a newer Storable will be able to parse this tag id
4431 if it's over the 2G mark.
4432 */
4433 if (tagval > I32_MAX) {
4434
4435 TRACEME(("object 0x%" UVxf " seen as #%" UVuf, PTR2UV(sv),
4436 (UV)tagval));
4437
4438 PUTMARK(SX_LOBJECT);
4439 PUTMARK(SX_OBJECT);
4440 W64LEN(tagval);
4441 return 0;
4442 }
4443 else
4444 #endif
4445 {
4446 I32 ltagval;
4447
4448 ltagval = htonl((I32)tagval);
4449
4450 TRACEME(("object 0x%" UVxf " seen as #%d", PTR2UV(sv),
4451 ntohl(ltagval)));
4452
4453 PUTMARK(SX_OBJECT);
4454 WRITE_I32(ltagval);
4455 return 0;
4456 }
4457 }
4458
4459 /*
4460 * Allocate a new tag and associate it with the address of the sv being
4461 * stored, before recursing...
4462 *
4463 * In order to avoid creating new SvIVs to hold the tagnum we just
4464 * cast the tagnum to an SV pointer and store that in the hash. This
4465 * means that we must clean up the hash manually afterwards, but gives
4466 * us a 15% throughput increase.
4467 *
4468 */
4469
4470 cxt->tagnum++;
4471 #ifdef USE_PTR_TABLE
4472 ptr_table_store(pseen, sv, INT2PTR(SV*, 1 + cxt->tagnum));
4473 #else
4474 if (!hv_store(hseen,
4475 (char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0))
4476 return -1;
4477 #endif
4478
4479 /*
4480 * Store 'sv' and everything beneath it, using appropriate routine.
4481 * Abort immediately if we get a non-zero status back.
4482 */
4483
4484 type = sv_type(aTHX_ sv);
4485
4486 undef_special_case:
4487 TRACEME(("storing 0x%" UVxf " tag #%d, type %d...",
4488 PTR2UV(sv), (int)cxt->tagnum, (int)type));
4489
4490 if (SvOBJECT(sv)) {
4491 HV *pkg = SvSTASH(sv);
4492 ret = store_blessed(aTHX_ cxt, sv, type, pkg);
4493 } else
4494 ret = SV_STORE(type)(aTHX_ cxt, sv);
4495
4496 TRACEME(("%s (stored 0x%" UVxf ", refcnt=%d, %s)",
4497 ret ? "FAILED" : "ok", PTR2UV(sv),
4498 (int)SvREFCNT(sv), sv_reftype(sv, FALSE)));
4499
4500 return ret;
4501 }
4502
4503 /*
4504 * magic_write
4505 *
4506 * Write magic number and system information into the file.
4507 * Layout is <magic> <network> [<len> <byteorder> <sizeof int> <sizeof long>
4508 * <sizeof ptr>] where <len> is the length of the byteorder hexa string.
4509 * All size and lengths are written as single characters here.
4510 *
4511 * Note that no byte ordering info is emitted when <network> is true, since
4512 * integers will be emitted in network order in that case.
4513 */
magic_write(pTHX_ stcxt_t * cxt)4514 static int magic_write(pTHX_ stcxt_t *cxt)
4515 {
4516 /*
4517 * Starting with 0.6, the "use_network_order" byte flag is also used to
4518 * indicate the version number of the binary image, encoded in the upper
4519 * bits. The bit 0 is always used to indicate network order.
4520 */
4521 /*
4522 * Starting with 0.7, a full byte is dedicated to the minor version of
4523 * the binary format, which is incremented only when new markers are
4524 * introduced, for instance, but when backward compatibility is preserved.
4525 */
4526
4527 /* Make these at compile time. The WRITE() macro is sufficiently complex
4528 that it saves about 200 bytes doing it this way and only using it
4529 once. */
4530 static const unsigned char network_file_header[] = {
4531 MAGICSTR_BYTES,
4532 (STORABLE_BIN_MAJOR << 1) | 1,
4533 STORABLE_BIN_WRITE_MINOR
4534 };
4535 static const unsigned char file_header[] = {
4536 MAGICSTR_BYTES,
4537 (STORABLE_BIN_MAJOR << 1) | 0,
4538 STORABLE_BIN_WRITE_MINOR,
4539 /* sizeof the array includes the 0 byte at the end: */
4540 (char) sizeof (byteorderstr) - 1,
4541 BYTEORDER_BYTES,
4542 (unsigned char) sizeof(int),
4543 (unsigned char) sizeof(long),
4544 (unsigned char) sizeof(char *),
4545 (unsigned char) sizeof(NV)
4546 };
4547 #ifdef USE_56_INTERWORK_KLUDGE
4548 static const unsigned char file_header_56[] = {
4549 MAGICSTR_BYTES,
4550 (STORABLE_BIN_MAJOR << 1) | 0,
4551 STORABLE_BIN_WRITE_MINOR,
4552 /* sizeof the array includes the 0 byte at the end: */
4553 (char) sizeof (byteorderstr_56) - 1,
4554 BYTEORDER_BYTES_56,
4555 (unsigned char) sizeof(int),
4556 (unsigned char) sizeof(long),
4557 (unsigned char) sizeof(char *),
4558 (unsigned char) sizeof(NV)
4559 };
4560 #endif
4561 const unsigned char *header;
4562 SSize_t length;
4563
4564 TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) : -1));
4565
4566 if (cxt->netorder) {
4567 header = network_file_header;
4568 length = sizeof (network_file_header);
4569 } else {
4570 #ifdef USE_56_INTERWORK_KLUDGE
4571 if (SvTRUE(get_sv("Storable::interwork_56_64bit", GV_ADD))) {
4572 header = file_header_56;
4573 length = sizeof (file_header_56);
4574 } else
4575 #endif
4576 {
4577 header = file_header;
4578 length = sizeof (file_header);
4579 }
4580 }
4581
4582 if (!cxt->fio) {
4583 /* sizeof the array includes the 0 byte at the end. */
4584 header += sizeof (magicstr) - 1;
4585 length -= sizeof (magicstr) - 1;
4586 }
4587
4588 WRITE( (unsigned char*) header, length);
4589
4590 if (!cxt->netorder) {
4591 TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)",
4592 (unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1,
4593 (int) sizeof(int), (int) sizeof(long),
4594 (int) sizeof(char *), (int) sizeof(NV)));
4595 }
4596 return 0;
4597 }
4598
4599 /*
4600 * do_store
4601 *
4602 * Common code for store operations.
4603 *
4604 * When memory store is requested (f = NULL) and a non null SV* is given in
4605 * 'res', it is filled with a new SV created out of the memory buffer.
4606 *
4607 * It is required to provide a non-null 'res' when the operation type is not
4608 * dclone() and store() is performed to memory.
4609 */
do_store(pTHX_ PerlIO * f,SV * sv,int optype,int network_order,SV ** res)4610 static int do_store(pTHX_
4611 PerlIO *f,
4612 SV *sv,
4613 int optype,
4614 int network_order,
4615 SV **res)
4616 {
4617 dSTCXT;
4618 int status;
4619
4620 ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res,
4621 ("must supply result SV pointer for real recursion to memory"));
4622
4623 TRACEMED(("do_store (optype=%d, netorder=%d)",
4624 optype, network_order));
4625
4626 optype |= ST_STORE;
4627
4628 /*
4629 * Workaround for CROAK leak: if they enter with a "dirty" context,
4630 * free up memory for them now.
4631 */
4632
4633 assert(cxt);
4634 if (cxt->s_dirty)
4635 clean_context(aTHX_ cxt);
4636
4637 /*
4638 * Now that STORABLE_xxx hooks exist, it is possible that they try to
4639 * re-enter store() via the hooks. We need to stack contexts.
4640 */
4641
4642 if (cxt->entry)
4643 cxt = allocate_context(aTHX_ cxt);
4644
4645 INIT_TRACEME;
4646
4647 cxt->entry++;
4648
4649 ASSERT(cxt->entry == 1, ("starting new recursion"));
4650 ASSERT(!cxt->s_dirty, ("clean context"));
4651
4652 /*
4653 * Ensure sv is actually a reference. From perl, we called something
4654 * like:
4655 * pstore(aTHX_ FILE, \@array);
4656 * so we must get the scalar value behind that reference.
4657 */
4658
4659 if (!SvROK(sv))
4660 CROAK(("Not a reference"));
4661 sv = SvRV(sv); /* So follow it to know what to store */
4662
4663 /*
4664 * If we're going to store to memory, reset the buffer.
4665 */
4666
4667 if (!f)
4668 MBUF_INIT(0);
4669
4670 /*
4671 * Prepare context and emit headers.
4672 */
4673
4674 init_store_context(aTHX_ cxt, f, optype, network_order);
4675
4676 if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */
4677 return 0; /* Error */
4678
4679 /*
4680 * Recursively store object...
4681 */
4682
4683 ASSERT(is_storing(aTHX), ("within store operation"));
4684
4685 status = store(aTHX_ cxt, sv); /* Just do it! */
4686
4687 /*
4688 * If they asked for a memory store and they provided an SV pointer,
4689 * make an SV string out of the buffer and fill their pointer.
4690 *
4691 * When asking for ST_REAL, it's MANDATORY for the caller to provide
4692 * an SV, since context cleanup might free the buffer if we did recurse.
4693 * (unless caller is dclone(), which is aware of that).
4694 */
4695
4696 if (!cxt->fio && res)
4697 *res = mbuf2sv(aTHX);
4698
4699 TRACEME(("do_store returns %d", status));
4700
4701 /*
4702 * Final cleanup.
4703 *
4704 * The "root" context is never freed, since it is meant to be always
4705 * handy for the common case where no recursion occurs at all (i.e.
4706 * we enter store() outside of any Storable code and leave it, period).
4707 * We know it's the "root" context because there's nothing stacked
4708 * underneath it.
4709 *
4710 * OPTIMIZATION:
4711 *
4712 * When deep cloning, we don't free the context: doing so would force
4713 * us to copy the data in the memory buffer. Sicne we know we're
4714 * about to enter do_retrieve...
4715 */
4716
4717 clean_store_context(aTHX_ cxt);
4718 if (cxt->prev && !(cxt->optype & ST_CLONE))
4719 free_context(aTHX_ cxt);
4720
4721 return status == 0;
4722 }
4723
4724 /***
4725 *** Memory stores.
4726 ***/
4727
4728 /*
4729 * mbuf2sv
4730 *
4731 * Build a new SV out of the content of the internal memory buffer.
4732 */
mbuf2sv(pTHX)4733 static SV *mbuf2sv(pTHX)
4734 {
4735 dSTCXT;
4736
4737 assert(cxt);
4738 return newSVpv(mbase, MBUF_SIZE());
4739 }
4740
4741 /***
4742 *** Specific retrieve callbacks.
4743 ***/
4744
4745 /*
4746 * retrieve_other
4747 *
4748 * Return an error via croak, since it is not possible that we get here
4749 * under normal conditions, when facing a file produced via pstore().
4750 */
retrieve_other(pTHX_ stcxt_t * cxt,const char * cname)4751 static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname)
4752 {
4753 PERL_UNUSED_ARG(cname);
4754 if (
4755 cxt->ver_major != STORABLE_BIN_MAJOR &&
4756 cxt->ver_minor != STORABLE_BIN_MINOR
4757 ) {
4758 CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d",
4759 cxt->fio ? "file" : "string",
4760 cxt->ver_major, cxt->ver_minor,
4761 STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
4762 } else {
4763 CROAK(("Corrupted storable %s (binary v%d.%d)",
4764 cxt->fio ? "file" : "string",
4765 cxt->ver_major, cxt->ver_minor));
4766 }
4767
4768 return (SV *) 0; /* Just in case */
4769 }
4770
4771 /*
4772 * retrieve_idx_blessed
4773 *
4774 * Layout is SX_IX_BLESS <index> <object> with SX_IX_BLESS already read.
4775 * <index> can be coded on either 1 or 5 bytes.
4776 */
retrieve_idx_blessed(pTHX_ stcxt_t * cxt,const char * cname)4777 static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname)
4778 {
4779 I32 idx;
4780 const char *classname;
4781 SV **sva;
4782 SV *sv;
4783
4784 PERL_UNUSED_ARG(cname);
4785 TRACEME(("retrieve_idx_blessed (#%d)", (int)cxt->tagnum));
4786 ASSERT(!cname, ("no bless-into class given here, got %s", cname));
4787
4788 GETMARK(idx); /* Index coded on a single char? */
4789 if (idx & 0x80)
4790 RLEN(idx);
4791
4792 /*
4793 * Fetch classname in 'aclass'
4794 */
4795
4796 sva = av_fetch(cxt->aclass, idx, FALSE);
4797 if (!sva)
4798 CROAK(("Class name #%" IVdf " should have been seen already",
4799 (IV) idx));
4800
4801 classname = SvPVX(*sva); /* We know it's a PV, by construction */
4802
4803 TRACEME(("class ID %d => %s", (int)idx, classname));
4804
4805 /*
4806 * Retrieve object and bless it.
4807 */
4808
4809 sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN
4810 will be blessed */
4811
4812 return sv;
4813 }
4814
4815 /*
4816 * retrieve_blessed
4817 *
4818 * Layout is SX_BLESS <len> <classname> <object> with SX_BLESS already read.
4819 * <len> can be coded on either 1 or 5 bytes.
4820 */
retrieve_blessed(pTHX_ stcxt_t * cxt,const char * cname)4821 static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname)
4822 {
4823 U32 len;
4824 SV *sv;
4825 char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
4826 char *classname = buf;
4827 char *malloced_classname = NULL;
4828
4829 PERL_UNUSED_ARG(cname);
4830 TRACEME(("retrieve_blessed (#%d)", (int)cxt->tagnum));
4831 ASSERT(!cname, ("no bless-into class given here, got %s", cname));
4832
4833 /*
4834 * Decode class name length and read that name.
4835 *
4836 * Short classnames have two advantages: their length is stored on one
4837 * single byte, and the string can be read on the stack.
4838 */
4839
4840 GETMARK(len); /* Length coded on a single char? */
4841 if (len & 0x80) {
4842 RLEN(len);
4843 TRACEME(("** allocating %ld bytes for class name", (long)len+1));
4844 if (len > I32_MAX)
4845 CROAK(("Corrupted classname length %lu", (long)len));
4846 PL_nomemok = TRUE; /* handle error by ourselves */
4847 New(10003, classname, len+1, char);
4848 PL_nomemok = FALSE;
4849 if (!classname)
4850 CROAK(("Out of memory with len %ld", (long)len));
4851 PL_nomemok = FALSE;
4852 malloced_classname = classname;
4853 }
4854 SAFEPVREAD(classname, (I32)len, malloced_classname);
4855 classname[len] = '\0'; /* Mark string end */
4856
4857 /*
4858 * It's a new classname, otherwise it would have been an SX_IX_BLESS.
4859 */
4860
4861 TRACEME(("new class name \"%s\" will bear ID = %d", classname,
4862 (int)cxt->classnum));
4863
4864 if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) {
4865 Safefree(malloced_classname);
4866 return (SV *) 0;
4867 }
4868
4869 /*
4870 * Retrieve object and bless it.
4871 */
4872
4873 sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */
4874 if (malloced_classname)
4875 Safefree(malloced_classname);
4876
4877 return sv;
4878 }
4879
4880 /*
4881 * retrieve_hook
4882 *
4883 * Layout: SX_HOOK <flags> <len> <classname> <len2> <str> [<len3> <object-IDs>]
4884 * with leading mark already read, as usual.
4885 *
4886 * When recursion was involved during serialization of the object, there
4887 * is an unknown amount of serialized objects after the SX_HOOK mark. Until
4888 * we reach a <flags> marker with the recursion bit cleared.
4889 *
4890 * If the first <flags> byte contains a type of SHT_EXTRA, then the real type
4891 * is held in the <extra> byte, and if the object is tied, the serialized
4892 * magic object comes at the very end:
4893 *
4894 * SX_HOOK <flags> <extra> ... [<len3> <object-IDs>] <magic object>
4895 *
4896 * This means the STORABLE_thaw hook will NOT get a tied variable during its
4897 * processing (since we won't have seen the magic object by the time the hook
4898 * is called). See comments below for why it was done that way.
4899 */
retrieve_hook_common(pTHX_ stcxt_t * cxt,const char * cname,int large)4900 static SV *retrieve_hook_common(pTHX_ stcxt_t *cxt, const char *cname, int large)
4901 {
4902 U32 len;
4903 char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */
4904 char *classname = buf;
4905 unsigned int flags;
4906 STRLEN len2;
4907 SV *frozen;
4908 I32 len3 = 0;
4909 AV *av = 0;
4910 SV *hook;
4911 SV *sv;
4912 SV *rv;
4913 GV *attach;
4914 HV *stash;
4915 int obj_type;
4916 int clone = cxt->optype & ST_CLONE;
4917 char mtype = '\0';
4918 unsigned int extra_type = 0;
4919 #ifdef HAS_U64
4920 int has_large_oids = 0;
4921 #endif
4922
4923 PERL_UNUSED_ARG(cname);
4924 TRACEME(("retrieve_hook (#%d)", (int)cxt->tagnum));
4925 ASSERT(!cname, ("no bless-into class given here, got %s", cname));
4926
4927 #ifndef HAS_U64
4928 assert(!large);
4929 PERL_UNUSED_ARG(large);
4930 #endif
4931
4932 /*
4933 * Read flags, which tell us about the type, and whether we need
4934 * to recurse.
4935 */
4936
4937 GETMARK(flags);
4938
4939 /*
4940 * Create the (empty) object, and mark it as seen.
4941 *
4942 * This must be done now, because tags are incremented, and during
4943 * serialization, the object tag was affected before recursion could
4944 * take place.
4945 */
4946
4947 obj_type = flags & SHF_TYPE_MASK;
4948 switch (obj_type) {
4949 case SHT_SCALAR:
4950 sv = newSV(0);
4951 break;
4952 case SHT_ARRAY:
4953 sv = (SV *) newAV();
4954 break;
4955 case SHT_HASH:
4956 sv = (SV *) newHV();
4957 break;
4958 case SHT_EXTRA:
4959 /*
4960 * Read <extra> flag to know the type of the object.
4961 * Record associated magic type for later.
4962 */
4963 GETMARK(extra_type);
4964 switch (extra_type) {
4965 case SHT_TSCALAR:
4966 sv = newSV(0);
4967 mtype = 'q';
4968 break;
4969 case SHT_TARRAY:
4970 sv = (SV *) newAV();
4971 mtype = 'P';
4972 break;
4973 case SHT_THASH:
4974 sv = (SV *) newHV();
4975 mtype = 'P';
4976 break;
4977 default:
4978 return retrieve_other(aTHX_ cxt, 0);/* Let it croak */
4979 }
4980 break;
4981 default:
4982 return retrieve_other(aTHX_ cxt, 0); /* Let it croak */
4983 }
4984 SEEN0_NN(sv, 0); /* Don't bless yet */
4985
4986 /*
4987 * Whilst flags tell us to recurse, do so.
4988 *
4989 * We don't need to remember the addresses returned by retrieval, because
4990 * all the references will be obtained through indirection via the object
4991 * tags in the object-ID list.
4992 *
4993 * We need to decrement the reference count for these objects
4994 * because, if the user doesn't save a reference to them in the hook,
4995 * they must be freed when this context is cleaned.
4996 */
4997
4998 while (flags & SHF_NEED_RECURSE) {
4999 TRACEME(("retrieve_hook recursing..."));
5000 rv = retrieve(aTHX_ cxt, 0);
5001 if (!rv)
5002 return (SV *) 0;
5003 SvREFCNT_dec(rv);
5004 TRACEME(("retrieve_hook back with rv=0x%" UVxf,
5005 PTR2UV(rv)));
5006 GETMARK(flags);
5007 }
5008
5009 if (flags & SHF_IDX_CLASSNAME) {
5010 SV **sva;
5011 I32 idx;
5012
5013 /*
5014 * Fetch index from 'aclass'
5015 */
5016
5017 if (flags & SHF_LARGE_CLASSLEN)
5018 RLEN(idx);
5019 else
5020 GETMARK(idx);
5021
5022 sva = av_fetch(cxt->aclass, idx, FALSE);
5023 if (!sva)
5024 CROAK(("Class name #%" IVdf " should have been seen already",
5025 (IV) idx));
5026
5027 classname = SvPVX(*sva); /* We know it's a PV, by construction */
5028 TRACEME(("class ID %d => %s", (int)idx, classname));
5029
5030 } else {
5031 /*
5032 * Decode class name length and read that name.
5033 *
5034 * NOTA BENE: even if the length is stored on one byte, we don't read
5035 * on the stack. Just like retrieve_blessed(), we limit the name to
5036 * LG_BLESS bytes. This is an arbitrary decision.
5037 */
5038 char *malloced_classname = NULL;
5039
5040 if (flags & SHF_LARGE_CLASSLEN)
5041 RLEN(len);
5042 else
5043 GETMARK(len);
5044
5045 TRACEME(("** allocating %ld bytes for class name", (long)len+1));
5046 if (len > I32_MAX) /* security */
5047 CROAK(("Corrupted classname length %lu", (long)len));
5048 else if (len > LG_BLESS) { /* security: signed len */
5049 PL_nomemok = TRUE; /* handle error by ourselves */
5050 New(10003, classname, len+1, char);
5051 PL_nomemok = FALSE;
5052 if (!classname)
5053 CROAK(("Out of memory with len %u", (unsigned)len+1));
5054 malloced_classname = classname;
5055 }
5056
5057 SAFEPVREAD(classname, (I32)len, malloced_classname);
5058 classname[len] = '\0'; /* Mark string end */
5059
5060 /*
5061 * Record new classname.
5062 */
5063
5064 if (!av_store(cxt->aclass, cxt->classnum++,
5065 newSVpvn(classname, len))) {
5066 Safefree(malloced_classname);
5067 return (SV *) 0;
5068 }
5069 }
5070
5071 TRACEME(("class name: %s", classname));
5072
5073 /*
5074 * Decode user-frozen string length and read it in an SV.
5075 *
5076 * For efficiency reasons, we read data directly into the SV buffer.
5077 * To understand that code, read retrieve_scalar()
5078 */
5079
5080 #ifdef HAS_U64
5081 if (large) {
5082 READ_U64(len2);
5083 }
5084 else
5085 #endif
5086 if (flags & SHF_LARGE_STRLEN) {
5087 U32 len32;
5088 RLEN(len32);
5089 len2 = len32;
5090 }
5091 else
5092 GETMARK(len2);
5093
5094 frozen = NEWSV(10002, len2 ? len2 : 1);
5095 if (len2) {
5096 SAFEREAD(SvPVX(frozen), len2, frozen);
5097 }
5098 SvCUR_set(frozen, len2);
5099 *SvEND(frozen) = '\0';
5100 (void) SvPOK_only(frozen); /* Validates string pointer */
5101 if (cxt->s_tainted) /* Is input source tainted? */
5102 SvTAINT(frozen);
5103
5104 TRACEME(("frozen string: %d bytes", (int)len2));
5105
5106 /*
5107 * Decode object-ID list length, if present.
5108 */
5109
5110 if (flags & SHF_HAS_LIST) {
5111 if (flags & SHF_LARGE_LISTLEN) {
5112 RLEN(len3);
5113 if (len3 < 0) {
5114 #ifdef HAS_U64
5115 ++has_large_oids;
5116 len3 = -len3;
5117 #else
5118 CROAK(("Large object ids in hook data not supported on 32-bit platforms"));
5119 #endif
5120
5121 }
5122 }
5123 else
5124 GETMARK(len3);
5125 if (len3) {
5126 av = newAV();
5127 av_extend(av, len3 + 1); /* Leave room for [0] */
5128 AvFILLp(av) = len3; /* About to be filled anyway */
5129 }
5130 }
5131
5132 TRACEME(("has %d object IDs to link", (int)len3));
5133
5134 /*
5135 * Read object-ID list into array.
5136 * Because we pre-extended it, we can cheat and fill it manually.
5137 *
5138 * We read object tags and we can convert them into SV* on the fly
5139 * because we know all the references listed in there (as tags)
5140 * have been already serialized, hence we have a valid correspondence
5141 * between each of those tags and the recreated SV.
5142 */
5143
5144 if (av) {
5145 SV **ary = AvARRAY(av);
5146 int i;
5147 for (i = 1; i <= len3; i++) { /* We leave [0] alone */
5148 ntag_t tag;
5149 SV **svh;
5150 SV *xsv;
5151
5152 #ifdef HAS_U64
5153 if (has_large_oids) {
5154 READ_U64(tag);
5155 }
5156 else {
5157 U32 tmp;
5158 READ_I32(tmp);
5159 tag = ntohl(tmp);
5160 }
5161 #else
5162 READ_I32(tag);
5163 tag = ntohl(tag);
5164 #endif
5165
5166 svh = av_fetch(cxt->aseen, tag, FALSE);
5167 if (!svh) {
5168 if (tag == cxt->where_is_undef) {
5169 /* av_fetch uses PL_sv_undef internally, hence this
5170 somewhat gruesome hack. */
5171 xsv = &PL_sv_undef;
5172 svh = &xsv;
5173 } else {
5174 CROAK(("Object #%" IVdf
5175 " should have been retrieved already",
5176 (IV) tag));
5177 }
5178 }
5179 xsv = *svh;
5180 ary[i] = SvREFCNT_inc(xsv);
5181 }
5182 }
5183
5184 /*
5185 * Look up the STORABLE_attach hook
5186 * If blessing is disabled, just return what we've got.
5187 */
5188 if (!(cxt->flags & FLAG_BLESS_OK)) {
5189 TRACEME(("skipping bless because flags is %d", cxt->flags));
5190 return sv;
5191 }
5192
5193 /*
5194 * Bless the object and look up the STORABLE_thaw hook.
5195 */
5196 stash = gv_stashpv(classname, GV_ADD);
5197
5198 /* Handle attach case; again can't use pkg_can because it only
5199 * caches one method */
5200 attach = gv_fetchmethod_autoload(stash, "STORABLE_attach", FALSE);
5201 if (attach && isGV(attach)) {
5202 SV* attached;
5203 SV* attach_hook = newRV_inc((SV*) GvCV(attach));
5204
5205 if (av)
5206 CROAK(("STORABLE_attach called with unexpected references"));
5207 av = newAV();
5208 av_extend(av, 1);
5209 AvFILLp(av) = 0;
5210 AvARRAY(av)[0] = SvREFCNT_inc(frozen);
5211 rv = newSVpv(classname, 0);
5212 attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
5213 /* Free memory after a call */
5214 SvREFCNT_dec(rv);
5215 SvREFCNT_dec(frozen);
5216 av_undef(av);
5217 sv_free((SV *) av);
5218 SvREFCNT_dec(attach_hook);
5219 if (attached &&
5220 SvROK(attached) &&
5221 sv_derived_from(attached, classname)
5222 ) {
5223 UNSEE();
5224 /* refcnt of unneeded sv is 2 at this point
5225 (one from newHV, second from SEEN call) */
5226 SvREFCNT_dec(sv);
5227 SvREFCNT_dec(sv);
5228 /* we need to free RV but preserve value that RV point to */
5229 sv = SvRV(attached);
5230 SEEN0_NN(sv, 0);
5231 SvRV_set(attached, NULL);
5232 SvREFCNT_dec(attached);
5233 if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
5234 Safefree(classname);
5235 return sv;
5236 }
5237 CROAK(("STORABLE_attach did not return a %s object", classname));
5238 }
5239
5240 /*
5241 * Bless the object and look up the STORABLE_thaw hook.
5242 */
5243
5244 BLESS(sv, stash);
5245
5246 hook = pkg_can(aTHX_ cxt->hook, stash, "STORABLE_thaw");
5247 if (!hook) {
5248 /*
5249 * Hook not found. Maybe they did not require the module where this
5250 * hook is defined yet?
5251 *
5252 * If the load below succeeds, we'll be able to find the hook.
5253 * Still, it only works reliably when each class is defined in a
5254 * file of its own.
5255 */
5256
5257 TRACEME(("No STORABLE_thaw defined for objects of class %s", classname));
5258 TRACEME(("Going to load module '%s'", classname));
5259 load_module(PERL_LOADMOD_NOIMPORT, newSVpv(classname, 0), Nullsv);
5260
5261 /*
5262 * We cache results of pkg_can, so we need to uncache before attempting
5263 * the lookup again.
5264 */
5265
5266 pkg_uncache(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
5267 hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
5268
5269 if (!hook)
5270 CROAK(("No STORABLE_thaw defined for objects of class %s "
5271 "(even after a \"require %s;\")", classname, classname));
5272 }
5273
5274 /*
5275 * If we don't have an 'av' yet, prepare one.
5276 * Then insert the frozen string as item [0].
5277 */
5278
5279 if (!av) {
5280 av = newAV();
5281 av_extend(av, 1);
5282 AvFILLp(av) = 0;
5283 }
5284 AvARRAY(av)[0] = SvREFCNT_inc(frozen);
5285
5286 /*
5287 * Call the hook as:
5288 *
5289 * $object->STORABLE_thaw($cloning, $frozen, @refs);
5290 *
5291 * where $object is our blessed (empty) object, $cloning is a boolean
5292 * telling whether we're running a deep clone, $frozen is the frozen
5293 * string the user gave us in his serializing hook, and @refs, which may
5294 * be empty, is the list of extra references he returned along for us
5295 * to serialize.
5296 *
5297 * In effect, the hook is an alternate creation routine for the class,
5298 * the object itself being already created by the runtime.
5299 */
5300
5301 TRACEME(("calling STORABLE_thaw on %s at 0x%" UVxf " (%" IVdf " args)",
5302 classname, PTR2UV(sv), (IV) AvFILLp(av) + 1));
5303
5304 rv = newRV_inc(sv);
5305 (void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR|G_DISCARD);
5306 SvREFCNT_dec(rv);
5307
5308 /*
5309 * Final cleanup.
5310 */
5311
5312 SvREFCNT_dec(frozen);
5313 av_undef(av);
5314 sv_free((SV *) av);
5315 if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
5316 Safefree(classname);
5317
5318 /*
5319 * If we had an <extra> type, then the object was not as simple, and
5320 * we need to restore extra magic now.
5321 */
5322
5323 if (!extra_type)
5324 return sv;
5325
5326 TRACEME(("retrieving magic object for 0x%" UVxf "...", PTR2UV(sv)));
5327
5328 rv = retrieve(aTHX_ cxt, 0); /* Retrieve <magic object> */
5329
5330 TRACEME(("restoring the magic object 0x%" UVxf " part of 0x%" UVxf,
5331 PTR2UV(rv), PTR2UV(sv)));
5332
5333 switch (extra_type) {
5334 case SHT_TSCALAR:
5335 sv_upgrade(sv, SVt_PVMG);
5336 break;
5337 case SHT_TARRAY:
5338 sv_upgrade(sv, SVt_PVAV);
5339 AvREAL_off((AV *)sv);
5340 break;
5341 case SHT_THASH:
5342 sv_upgrade(sv, SVt_PVHV);
5343 break;
5344 default:
5345 CROAK(("Forgot to deal with extra type %d", extra_type));
5346 break;
5347 }
5348
5349 /*
5350 * Adding the magic only now, well after the STORABLE_thaw hook was called
5351 * means the hook cannot know it deals with an object whose variable is
5352 * tied. But this is happening when retrieving $o in the following case:
5353 *
5354 * my %h;
5355 * tie %h, 'FOO';
5356 * my $o = bless \%h, 'BAR';
5357 *
5358 * The 'BAR' class is NOT the one where %h is tied into. Therefore, as
5359 * far as the 'BAR' class is concerned, the fact that %h is not a REAL
5360 * hash but a tied one should not matter at all, and remain transparent.
5361 * This means the magic must be restored by Storable AFTER the hook is
5362 * called.
5363 *
5364 * That looks very reasonable to me, but then I've come up with this
5365 * after a bug report from David Nesting, who was trying to store such
5366 * an object and caused Storable to fail. And unfortunately, it was
5367 * also the easiest way to retrofit support for blessed ref to tied objects
5368 * into the existing design. -- RAM, 17/02/2001
5369 */
5370
5371 sv_magic(sv, rv, mtype, (char *)NULL, 0);
5372 SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */
5373
5374 return sv;
5375 }
5376
retrieve_hook(pTHX_ stcxt_t * cxt,const char * cname)5377 static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) {
5378 return retrieve_hook_common(aTHX_ cxt, cname, FALSE);
5379 }
5380
5381 /*
5382 * retrieve_ref
5383 *
5384 * Retrieve reference to some other scalar.
5385 * Layout is SX_REF <object>, with SX_REF already read.
5386 */
retrieve_ref(pTHX_ stcxt_t * cxt,const char * cname)5387 static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname)
5388 {
5389 SV *rv;
5390 SV *sv;
5391 HV *stash;
5392
5393 TRACEME(("retrieve_ref (#%d)", (int)cxt->tagnum));
5394
5395 /*
5396 * We need to create the SV that holds the reference to the yet-to-retrieve
5397 * object now, so that we may record the address in the seen table.
5398 * Otherwise, if the object to retrieve references us, we won't be able
5399 * to resolve the SX_OBJECT we'll see at that point! Hence we cannot
5400 * do the retrieve first and use rv = newRV(sv) since it will be too late
5401 * for SEEN() recording.
5402 */
5403
5404 rv = NEWSV(10002, 0);
5405 if (cname)
5406 stash = gv_stashpv(cname, GV_ADD);
5407 else
5408 stash = 0;
5409 SEEN_NN(rv, stash, 0); /* Will return if rv is null */
5410 sv = retrieve(aTHX_ cxt, 0);/* Retrieve <object> */
5411 if (!sv)
5412 return (SV *) 0; /* Failed */
5413
5414 /*
5415 * WARNING: breaks RV encapsulation.
5416 *
5417 * Now for the tricky part. We have to upgrade our existing SV, so that
5418 * it is now an RV on sv... Again, we cheat by duplicating the code
5419 * held in newSVrv(), since we already got our SV from retrieve().
5420 *
5421 * We don't say:
5422 *
5423 * SvRV(rv) = SvREFCNT_inc(sv);
5424 *
5425 * here because the reference count we got from retrieve() above is
5426 * already correct: if the object was retrieved from the file, then
5427 * its reference count is one. Otherwise, if it was retrieved via
5428 * an SX_OBJECT indication, a ref count increment was done.
5429 */
5430
5431 if (cname) {
5432 /* No need to do anything, as rv will already be PVMG. */
5433 assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV);
5434 } else {
5435 sv_upgrade(rv, SVt_RV);
5436 }
5437
5438 SvRV_set(rv, sv); /* $rv = \$sv */
5439 SvROK_on(rv);
5440 /*if (cxt->entry && ++cxt->ref_cnt > MAX_REF_CNT) {
5441 CROAK(("Max. recursion depth with nested refs exceeded"));
5442 }*/
5443
5444 TRACEME(("ok (retrieve_ref at 0x%" UVxf ")", PTR2UV(rv)));
5445
5446 return rv;
5447 }
5448
5449 /*
5450 * retrieve_weakref
5451 *
5452 * Retrieve weak reference to some other scalar.
5453 * Layout is SX_WEAKREF <object>, with SX_WEAKREF already read.
5454 */
retrieve_weakref(pTHX_ stcxt_t * cxt,const char * cname)5455 static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname)
5456 {
5457 SV *sv;
5458
5459 TRACEME(("retrieve_weakref (#%d)", (int)cxt->tagnum));
5460
5461 sv = retrieve_ref(aTHX_ cxt, cname);
5462 if (sv) {
5463 #ifdef SvWEAKREF
5464 sv_rvweaken(sv);
5465 #else
5466 WEAKREF_CROAK();
5467 #endif
5468 }
5469 return sv;
5470 }
5471
5472 /*
5473 * retrieve_overloaded
5474 *
5475 * Retrieve reference to some other scalar with overloading.
5476 * Layout is SX_OVERLOAD <object>, with SX_OVERLOAD already read.
5477 */
retrieve_overloaded(pTHX_ stcxt_t * cxt,const char * cname)5478 static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname)
5479 {
5480 SV *rv;
5481 SV *sv;
5482 HV *stash;
5483
5484 TRACEME(("retrieve_overloaded (#%d)", (int)cxt->tagnum));
5485
5486 /*
5487 * Same code as retrieve_ref(), duplicated to avoid extra call.
5488 */
5489
5490 rv = NEWSV(10002, 0);
5491 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5492 SEEN_NN(rv, stash, 0); /* Will return if rv is null */
5493 cxt->in_retrieve_overloaded = 1; /* so sv_bless doesn't call S_reset_amagic */
5494 sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
5495 cxt->in_retrieve_overloaded = 0;
5496 if (!sv)
5497 return (SV *) 0; /* Failed */
5498
5499 /*
5500 * WARNING: breaks RV encapsulation.
5501 */
5502
5503 SvUPGRADE(rv, SVt_RV);
5504 SvRV_set(rv, sv); /* $rv = \$sv */
5505 SvROK_on(rv);
5506
5507 /*
5508 * Restore overloading magic.
5509 */
5510
5511 stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0;
5512 if (!stash) {
5513 CROAK(("Cannot restore overloading on %s(0x%" UVxf
5514 ") (package <unknown>)",
5515 sv_reftype(sv, FALSE),
5516 PTR2UV(sv)));
5517 }
5518 if (!Gv_AMG(stash)) {
5519 const char *package = HvNAME_get(stash);
5520 TRACEME(("No overloading defined for package %s", package));
5521 TRACEME(("Going to load module '%s'", package));
5522 load_module(PERL_LOADMOD_NOIMPORT, newSVpv(package, 0), Nullsv);
5523 if (!Gv_AMG(stash)) {
5524 CROAK(("Cannot restore overloading on %s(0x%" UVxf
5525 ") (package %s) (even after a \"require %s;\")",
5526 sv_reftype(sv, FALSE),
5527 PTR2UV(sv),
5528 package, package));
5529 }
5530 }
5531
5532 SvAMAGIC_on(rv);
5533
5534 TRACEME(("ok (retrieve_overloaded at 0x%" UVxf ")", PTR2UV(rv)));
5535
5536 return rv;
5537 }
5538
5539 /*
5540 * retrieve_weakoverloaded
5541 *
5542 * Retrieve weak overloaded reference to some other scalar.
5543 * Layout is SX_WEAKOVERLOADED <object>, with SX_WEAKOVERLOADED already read.
5544 */
retrieve_weakoverloaded(pTHX_ stcxt_t * cxt,const char * cname)5545 static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname)
5546 {
5547 SV *sv;
5548
5549 TRACEME(("retrieve_weakoverloaded (#%d)", (int)cxt->tagnum));
5550
5551 sv = retrieve_overloaded(aTHX_ cxt, cname);
5552 if (sv) {
5553 #ifdef SvWEAKREF
5554 sv_rvweaken(sv);
5555 #else
5556 WEAKREF_CROAK();
5557 #endif
5558 }
5559 return sv;
5560 }
5561
5562 /*
5563 * retrieve_tied_array
5564 *
5565 * Retrieve tied array
5566 * Layout is SX_TIED_ARRAY <object>, with SX_TIED_ARRAY already read.
5567 */
retrieve_tied_array(pTHX_ stcxt_t * cxt,const char * cname)5568 static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname)
5569 {
5570 SV *tv;
5571 SV *sv;
5572 HV *stash;
5573
5574 TRACEME(("retrieve_tied_array (#%d)", (int)cxt->tagnum));
5575
5576 if (!(cxt->flags & FLAG_TIE_OK)) {
5577 CROAK(("Tying is disabled."));
5578 }
5579
5580 tv = NEWSV(10002, 0);
5581 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5582 SEEN_NN(tv, stash, 0); /* Will return if tv is null */
5583 sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
5584 if (!sv)
5585 return (SV *) 0; /* Failed */
5586
5587 sv_upgrade(tv, SVt_PVAV);
5588 sv_magic(tv, sv, 'P', (char *)NULL, 0);
5589 SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
5590
5591 TRACEME(("ok (retrieve_tied_array at 0x%" UVxf ")", PTR2UV(tv)));
5592
5593 return tv;
5594 }
5595
5596 /*
5597 * retrieve_tied_hash
5598 *
5599 * Retrieve tied hash
5600 * Layout is SX_TIED_HASH <object>, with SX_TIED_HASH already read.
5601 */
retrieve_tied_hash(pTHX_ stcxt_t * cxt,const char * cname)5602 static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname)
5603 {
5604 SV *tv;
5605 SV *sv;
5606 HV *stash;
5607
5608 TRACEME(("retrieve_tied_hash (#%d)", (int)cxt->tagnum));
5609
5610 if (!(cxt->flags & FLAG_TIE_OK)) {
5611 CROAK(("Tying is disabled."));
5612 }
5613
5614 tv = NEWSV(10002, 0);
5615 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5616 SEEN_NN(tv, stash, 0); /* Will return if tv is null */
5617 sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
5618 if (!sv)
5619 return (SV *) 0; /* Failed */
5620
5621 sv_upgrade(tv, SVt_PVHV);
5622 sv_magic(tv, sv, 'P', (char *)NULL, 0);
5623 SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
5624
5625 TRACEME(("ok (retrieve_tied_hash at 0x%" UVxf ")", PTR2UV(tv)));
5626
5627 return tv;
5628 }
5629
5630 /*
5631 * retrieve_tied_scalar
5632 *
5633 * Retrieve tied scalar
5634 * Layout is SX_TIED_SCALAR <object>, with SX_TIED_SCALAR already read.
5635 */
retrieve_tied_scalar(pTHX_ stcxt_t * cxt,const char * cname)5636 static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname)
5637 {
5638 SV *tv;
5639 SV *sv, *obj = NULL;
5640 HV *stash;
5641
5642 TRACEME(("retrieve_tied_scalar (#%d)", (int)cxt->tagnum));
5643
5644 if (!(cxt->flags & FLAG_TIE_OK)) {
5645 CROAK(("Tying is disabled."));
5646 }
5647
5648 tv = NEWSV(10002, 0);
5649 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5650 SEEN_NN(tv, stash, 0); /* Will return if rv is null */
5651 sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
5652 if (!sv) {
5653 return (SV *) 0; /* Failed */
5654 }
5655 else if (SvTYPE(sv) != SVt_NULL) {
5656 obj = sv;
5657 }
5658
5659 sv_upgrade(tv, SVt_PVMG);
5660 sv_magic(tv, obj, 'q', (char *)NULL, 0);
5661
5662 if (obj) {
5663 /* Undo refcnt inc from sv_magic() */
5664 SvREFCNT_dec(obj);
5665 }
5666
5667 TRACEME(("ok (retrieve_tied_scalar at 0x%" UVxf ")", PTR2UV(tv)));
5668
5669 return tv;
5670 }
5671
5672 /*
5673 * retrieve_tied_key
5674 *
5675 * Retrieve reference to value in a tied hash.
5676 * Layout is SX_TIED_KEY <object> <key>, with SX_TIED_KEY already read.
5677 */
retrieve_tied_key(pTHX_ stcxt_t * cxt,const char * cname)5678 static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname)
5679 {
5680 SV *tv;
5681 SV *sv;
5682 SV *key;
5683 HV *stash;
5684
5685 TRACEME(("retrieve_tied_key (#%d)", (int)cxt->tagnum));
5686
5687 if (!(cxt->flags & FLAG_TIE_OK)) {
5688 CROAK(("Tying is disabled."));
5689 }
5690
5691 tv = NEWSV(10002, 0);
5692 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5693 SEEN_NN(tv, stash, 0); /* Will return if tv is null */
5694 sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
5695 if (!sv)
5696 return (SV *) 0; /* Failed */
5697
5698 key = retrieve(aTHX_ cxt, 0); /* Retrieve <key> */
5699 if (!key)
5700 return (SV *) 0; /* Failed */
5701
5702 sv_upgrade(tv, SVt_PVMG);
5703 sv_magic(tv, sv, 'p', (char *)key, HEf_SVKEY);
5704 SvREFCNT_dec(key); /* Undo refcnt inc from sv_magic() */
5705 SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
5706
5707 return tv;
5708 }
5709
5710 /*
5711 * retrieve_tied_idx
5712 *
5713 * Retrieve reference to value in a tied array.
5714 * Layout is SX_TIED_IDX <object> <idx>, with SX_TIED_IDX already read.
5715 */
retrieve_tied_idx(pTHX_ stcxt_t * cxt,const char * cname)5716 static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname)
5717 {
5718 SV *tv;
5719 SV *sv;
5720 HV *stash;
5721 I32 idx;
5722
5723 TRACEME(("retrieve_tied_idx (#%d)", (int)cxt->tagnum));
5724
5725 if (!(cxt->flags & FLAG_TIE_OK)) {
5726 CROAK(("Tying is disabled."));
5727 }
5728
5729 tv = NEWSV(10002, 0);
5730 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5731 SEEN_NN(tv, stash, 0); /* Will return if tv is null */
5732 sv = retrieve(aTHX_ cxt, 0); /* Retrieve <object> */
5733 if (!sv)
5734 return (SV *) 0; /* Failed */
5735
5736 RLEN(idx); /* Retrieve <idx> */
5737
5738 sv_upgrade(tv, SVt_PVMG);
5739 sv_magic(tv, sv, 'p', (char *)NULL, idx);
5740 SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
5741
5742 return tv;
5743 }
5744
5745 /*
5746 * get_lstring
5747 *
5748 * Helper to read a string
5749 */
get_lstring(pTHX_ stcxt_t * cxt,UV len,int isutf8,const char * cname)5750 static SV *get_lstring(pTHX_ stcxt_t *cxt, UV len, int isutf8, const char *cname)
5751 {
5752 SV *sv;
5753 HV *stash;
5754
5755 TRACEME(("get_lstring (#%d), len = %" UVuf, (int)cxt->tagnum, len));
5756
5757 /*
5758 * Allocate an empty scalar of the suitable length.
5759 */
5760
5761 sv = NEWSV(10002, len);
5762 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5763 SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
5764
5765 if (len == 0) {
5766 SvPVCLEAR(sv);
5767 return sv;
5768 }
5769
5770 /*
5771 * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation.
5772 *
5773 * Now, for efficiency reasons, read data directly inside the SV buffer,
5774 * and perform the SV final settings directly by duplicating the final
5775 * work done by sv_setpv. Since we're going to allocate lots of scalars
5776 * this way, it's worth the hassle and risk.
5777 */
5778
5779 SAFEREAD(SvPVX(sv), len, sv);
5780 SvCUR_set(sv, len); /* Record C string length */
5781 *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */
5782 (void) SvPOK_only(sv); /* Validate string pointer */
5783 if (cxt->s_tainted) /* Is input source tainted? */
5784 SvTAINT(sv); /* External data cannot be trusted */
5785
5786 /* Check for CVE-215-1592 */
5787 if (cname && len == 13 && strEQc(cname, "CGITempFile")
5788 && strEQc(SvPVX(sv), "mt-config.cgi")) {
5789 #if defined(USE_CPERL) && defined(WARN_SECURITY)
5790 Perl_warn_security(aTHX_
5791 "Movable-Type CVE-2015-1592 Storable metasploit attack");
5792 #else
5793 Perl_warn(aTHX_
5794 "SECURITY: Movable-Type CVE-2015-1592 Storable metasploit attack");
5795 #endif
5796 }
5797
5798 if (isutf8) {
5799 TRACEME(("large utf8 string len %" UVuf " '%s'", len,
5800 len >= 2048 ? "<string too long>" : SvPVX(sv)));
5801 #ifdef HAS_UTF8_SCALARS
5802 SvUTF8_on(sv);
5803 #else
5804 if (cxt->use_bytes < 0)
5805 cxt->use_bytes
5806 = (SvTRUE(get_sv("Storable::drop_utf8", GV_ADD))
5807 ? 1 : 0);
5808 if (cxt->use_bytes == 0)
5809 UTF8_CROAK();
5810 #endif
5811 } else {
5812 TRACEME(("large string len %" UVuf " '%s'", len,
5813 len >= 2048 ? "<string too long>" : SvPVX(sv)));
5814 }
5815 TRACEME(("ok (get_lstring at 0x%" UVxf ")", PTR2UV(sv)));
5816
5817 return sv;
5818 }
5819
5820 /*
5821 * retrieve_lscalar
5822 *
5823 * Retrieve defined long (string) scalar.
5824 *
5825 * Layout is SX_LSCALAR <length> <data>, with SX_LSCALAR already read.
5826 * The scalar is "long" in that <length> is larger than LG_SCALAR so it
5827 * was not stored on a single byte, but in 4 bytes. For strings longer than
5828 * 4 byte (>2GB) see retrieve_lobject.
5829 */
retrieve_lscalar(pTHX_ stcxt_t * cxt,const char * cname)5830 static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname)
5831 {
5832 U32 len;
5833 RLEN(len);
5834 return get_lstring(aTHX_ cxt, len, 0, cname);
5835 }
5836
5837 /*
5838 * retrieve_scalar
5839 *
5840 * Retrieve defined short (string) scalar.
5841 *
5842 * Layout is SX_SCALAR <length> <data>, with SX_SCALAR already read.
5843 * The scalar is "short" so <length> is single byte. If it is 0, there
5844 * is no <data> section.
5845 */
retrieve_scalar(pTHX_ stcxt_t * cxt,const char * cname)5846 static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname)
5847 {
5848 int len;
5849 /*SV *sv;
5850 HV *stash;*/
5851
5852 GETMARK(len);
5853 TRACEME(("retrieve_scalar (#%d), len = %d", (int)cxt->tagnum, len));
5854 return get_lstring(aTHX_ cxt, (UV)len, 0, cname);
5855 }
5856
5857 /*
5858 * retrieve_utf8str
5859 *
5860 * Like retrieve_scalar(), but tag result as utf8.
5861 * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
5862 */
retrieve_utf8str(pTHX_ stcxt_t * cxt,const char * cname)5863 static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname)
5864 {
5865 int len;
5866 /*SV *sv;*/
5867
5868 TRACEME(("retrieve_utf8str"));
5869 GETMARK(len);
5870 return get_lstring(aTHX_ cxt, (UV)len, 1, cname);
5871 }
5872
5873 /*
5874 * retrieve_lutf8str
5875 *
5876 * Like retrieve_lscalar(), but tag result as utf8.
5877 * If we're retrieving UTF8 data in a non-UTF8 perl, croaks.
5878 */
retrieve_lutf8str(pTHX_ stcxt_t * cxt,const char * cname)5879 static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname)
5880 {
5881 U32 len;
5882
5883 TRACEME(("retrieve_lutf8str"));
5884
5885 RLEN(len);
5886 return get_lstring(aTHX_ cxt, (UV)len, 1, cname);
5887 }
5888
5889 /*
5890 * retrieve_vstring
5891 *
5892 * Retrieve a vstring, and then retrieve the stringy scalar following it,
5893 * attaching the vstring to the scalar via magic.
5894 * If we're retrieving a vstring in a perl without vstring magic, croaks.
5895 *
5896 * The vstring layout mirrors an SX_SCALAR string:
5897 * SX_VSTRING <length> <data> with SX_VSTRING already read.
5898 */
retrieve_vstring(pTHX_ stcxt_t * cxt,const char * cname)5899 static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname)
5900 {
5901 #ifdef SvVOK
5902 char s[256];
5903 int len;
5904 SV *sv;
5905
5906 GETMARK(len);
5907 TRACEME(("retrieve_vstring (#%d), len = %d", (int)cxt->tagnum, len));
5908
5909 READ(s, len);
5910 sv = retrieve(aTHX_ cxt, cname);
5911 if (!sv)
5912 return (SV *) 0; /* Failed */
5913 sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len);
5914 /* 5.10.0 and earlier seem to need this */
5915 SvRMAGICAL_on(sv);
5916
5917 TRACEME(("ok (retrieve_vstring at 0x%" UVxf ")", PTR2UV(sv)));
5918 return sv;
5919 #else
5920 VSTRING_CROAK();
5921 return Nullsv;
5922 #endif
5923 }
5924
5925 /*
5926 * retrieve_lvstring
5927 *
5928 * Like retrieve_vstring, but for longer vstrings.
5929 */
retrieve_lvstring(pTHX_ stcxt_t * cxt,const char * cname)5930 static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname)
5931 {
5932 #ifdef SvVOK
5933 char *s;
5934 I32 len;
5935 SV *sv;
5936
5937 RLEN(len);
5938 TRACEME(("retrieve_lvstring (#%d), len = %" IVdf,
5939 (int)cxt->tagnum, (IV)len));
5940
5941 New(10003, s, len+1, char);
5942 SAFEPVREAD(s, len, s);
5943
5944 sv = retrieve(aTHX_ cxt, cname);
5945 if (!sv) {
5946 Safefree(s);
5947 return (SV *) 0; /* Failed */
5948 }
5949 sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len);
5950 /* 5.10.0 and earlier seem to need this */
5951 SvRMAGICAL_on(sv);
5952
5953 Safefree(s);
5954
5955 TRACEME(("ok (retrieve_lvstring at 0x%" UVxf ")", PTR2UV(sv)));
5956 return sv;
5957 #else
5958 VSTRING_CROAK();
5959 return Nullsv;
5960 #endif
5961 }
5962
5963 /*
5964 * retrieve_integer
5965 *
5966 * Retrieve defined integer.
5967 * Layout is SX_INTEGER <data>, whith SX_INTEGER already read.
5968 */
retrieve_integer(pTHX_ stcxt_t * cxt,const char * cname)5969 static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname)
5970 {
5971 SV *sv;
5972 HV *stash;
5973 IV iv;
5974
5975 TRACEME(("retrieve_integer (#%d)", (int)cxt->tagnum));
5976
5977 READ(&iv, sizeof(iv));
5978 sv = newSViv(iv);
5979 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
5980 SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
5981
5982 TRACEME(("integer %" IVdf, iv));
5983 TRACEME(("ok (retrieve_integer at 0x%" UVxf ")", PTR2UV(sv)));
5984
5985 return sv;
5986 }
5987
5988 /*
5989 * retrieve_lobject
5990 *
5991 * Retrieve overlong scalar, array or hash.
5992 * Layout is SX_LOBJECT type U64_len ...
5993 */
retrieve_lobject(pTHX_ stcxt_t * cxt,const char * cname)5994 static SV *retrieve_lobject(pTHX_ stcxt_t *cxt, const char *cname)
5995 {
5996 int type;
5997 #ifdef HAS_U64
5998 UV len;
5999 SV *sv;
6000 int hash_flags = 0;
6001 #endif
6002
6003 TRACEME(("retrieve_lobject (#%d)", (int)cxt->tagnum));
6004
6005 GETMARK(type);
6006 TRACEME(("object type %d", type));
6007 #ifdef HAS_U64
6008
6009 if (type == SX_FLAG_HASH) {
6010 /* we write the flags immediately after the op. I could have
6011 changed the writer, but this may allow someone to recover
6012 data they're already frozen, though such a very large hash
6013 seems unlikely.
6014 */
6015 GETMARK(hash_flags);
6016 }
6017 else if (type == SX_HOOK) {
6018 return retrieve_hook_common(aTHX_ cxt, cname, TRUE);
6019 }
6020
6021 READ_U64(len);
6022 TRACEME(("wlen %" UVuf, len));
6023 switch (type) {
6024 case SX_OBJECT:
6025 {
6026 /* not a large object, just a large index */
6027 SV **svh = av_fetch(cxt->aseen, len, FALSE);
6028 if (!svh)
6029 CROAK(("Object #%" UVuf " should have been retrieved already",
6030 len));
6031 sv = *svh;
6032 TRACEME(("had retrieved #%" UVuf " at 0x%" UVxf, len, PTR2UV(sv)));
6033 SvREFCNT_inc(sv);
6034 }
6035 break;
6036 case SX_LSCALAR:
6037 sv = get_lstring(aTHX_ cxt, len, 0, cname);
6038 break;
6039 case SX_LUTF8STR:
6040 sv = get_lstring(aTHX_ cxt, len, 1, cname);
6041 break;
6042 case SX_ARRAY:
6043 sv = get_larray(aTHX_ cxt, len, cname);
6044 break;
6045 /* <5.12 you could store larger hashes, but cannot iterate over them.
6046 So we reject them, it's a bug. */
6047 case SX_FLAG_HASH:
6048 sv = get_lhash(aTHX_ cxt, len, hash_flags, cname);
6049 break;
6050 case SX_HASH:
6051 sv = get_lhash(aTHX_ cxt, len, 0, cname);
6052 break;
6053 default:
6054 CROAK(("Unexpected type %d in retrieve_lobject\n", type));
6055 }
6056
6057 TRACEME(("ok (retrieve_lobject at 0x%" UVxf ")", PTR2UV(sv)));
6058 return sv;
6059 #else
6060 PERL_UNUSED_ARG(cname);
6061
6062 /* previously this (brokenly) checked the length value and only failed if
6063 the length was over 4G.
6064 Since this op should only occur with objects over 4GB (or 2GB) we can just
6065 reject it.
6066 */
6067 CROAK(("Invalid large object op for this 32bit system"));
6068 #endif
6069 }
6070
6071 /*
6072 * retrieve_netint
6073 *
6074 * Retrieve defined integer in network order.
6075 * Layout is SX_NETINT <data>, whith SX_NETINT already read.
6076 */
retrieve_netint(pTHX_ stcxt_t * cxt,const char * cname)6077 static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname)
6078 {
6079 SV *sv;
6080 HV *stash;
6081 I32 iv;
6082
6083 TRACEME(("retrieve_netint (#%d)", (int)cxt->tagnum));
6084
6085 READ_I32(iv);
6086 #ifdef HAS_NTOHL
6087 sv = newSViv((int) ntohl(iv));
6088 TRACEME(("network integer %d", (int) ntohl(iv)));
6089 #else
6090 sv = newSViv(iv);
6091 TRACEME(("network integer (as-is) %d", iv));
6092 #endif
6093 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6094 SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
6095
6096 TRACEME(("ok (retrieve_netint at 0x%" UVxf ")", PTR2UV(sv)));
6097
6098 return sv;
6099 }
6100
6101 /*
6102 * retrieve_double
6103 *
6104 * Retrieve defined double.
6105 * Layout is SX_DOUBLE <data>, whith SX_DOUBLE already read.
6106 */
retrieve_double(pTHX_ stcxt_t * cxt,const char * cname)6107 static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname)
6108 {
6109 SV *sv;
6110 HV *stash;
6111 NV nv;
6112
6113 TRACEME(("retrieve_double (#%d)", (int)cxt->tagnum));
6114
6115 READ(&nv, sizeof(nv));
6116 sv = newSVnv(nv);
6117 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6118 SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
6119
6120 TRACEME(("double %" NVff, nv));
6121 TRACEME(("ok (retrieve_double at 0x%" UVxf ")", PTR2UV(sv)));
6122
6123 return sv;
6124 }
6125
6126 /*
6127 * retrieve_byte
6128 *
6129 * Retrieve defined byte (small integer within the [-128, +127] range).
6130 * Layout is SX_BYTE <data>, whith SX_BYTE already read.
6131 */
retrieve_byte(pTHX_ stcxt_t * cxt,const char * cname)6132 static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname)
6133 {
6134 SV *sv;
6135 HV *stash;
6136 int siv;
6137 #ifdef _MSC_VER
6138 /* MSVC 2017 doesn't handle the AIX workaround well */
6139 int tmp;
6140 #else
6141 signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */
6142 #endif
6143
6144 TRACEME(("retrieve_byte (#%d)", (int)cxt->tagnum));
6145
6146 GETMARK(siv);
6147 TRACEME(("small integer read as %d", (unsigned char) siv));
6148 tmp = (unsigned char) siv - 128;
6149 sv = newSViv(tmp);
6150 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6151 SEEN_NN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */
6152
6153 TRACEME(("byte %d", tmp));
6154 TRACEME(("ok (retrieve_byte at 0x%" UVxf ")", PTR2UV(sv)));
6155
6156 return sv;
6157 }
6158
6159 /*
6160 * retrieve_undef
6161 *
6162 * Return the undefined value.
6163 */
retrieve_undef(pTHX_ stcxt_t * cxt,const char * cname)6164 static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname)
6165 {
6166 SV *sv;
6167 HV *stash;
6168
6169 TRACEME(("retrieve_undef"));
6170
6171 sv = newSV(0);
6172 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6173 SEEN_NN(sv, stash, 0);
6174
6175 return sv;
6176 }
6177
6178 /*
6179 * retrieve_sv_undef
6180 *
6181 * Return the immortal undefined value.
6182 */
retrieve_sv_undef(pTHX_ stcxt_t * cxt,const char * cname)6183 static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname)
6184 {
6185 SV *sv = &PL_sv_undef;
6186 HV *stash;
6187
6188 TRACEME(("retrieve_sv_undef"));
6189
6190 /* Special case PL_sv_undef, as av_fetch uses it internally to mark
6191 deleted elements, and will return NULL (fetch failed) whenever it
6192 is fetched. */
6193 if (cxt->where_is_undef == UNSET_NTAG_T) {
6194 cxt->where_is_undef = cxt->tagnum;
6195 }
6196 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6197 SEEN_NN(sv, stash, 1);
6198 return sv;
6199 }
6200
6201 /*
6202 * retrieve_sv_yes
6203 *
6204 * Return the immortal yes value.
6205 */
retrieve_sv_yes(pTHX_ stcxt_t * cxt,const char * cname)6206 static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname)
6207 {
6208 SV *sv = &PL_sv_yes;
6209 HV *stash;
6210
6211 TRACEME(("retrieve_sv_yes"));
6212
6213 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6214 SEEN_NN(sv, stash, 1);
6215 return sv;
6216 }
6217
6218 /*
6219 * retrieve_sv_no
6220 *
6221 * Return the immortal no value.
6222 */
retrieve_sv_no(pTHX_ stcxt_t * cxt,const char * cname)6223 static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname)
6224 {
6225 SV *sv = &PL_sv_no;
6226 HV *stash;
6227
6228 TRACEME(("retrieve_sv_no"));
6229
6230 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6231 SEEN_NN(sv, stash, 1);
6232 return sv;
6233 }
6234
6235 /*
6236 * retrieve_svundef_elem
6237 *
6238 * Return &PL_sv_placeholder, representing &PL_sv_undef in an array. This
6239 * is a bit of a hack, but we already use SX_SV_UNDEF to mean a nonexistent
6240 * element, for historical reasons.
6241 */
retrieve_svundef_elem(pTHX_ stcxt_t * cxt,const char * cname)6242 static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname)
6243 {
6244 TRACEME(("retrieve_svundef_elem"));
6245
6246 /* SEEN reads the contents of its SV argument, which we are not
6247 supposed to do with &PL_sv_placeholder. */
6248 SEEN_NN(&PL_sv_undef, cname, 1);
6249
6250 return &PL_sv_placeholder;
6251 }
6252
6253 /*
6254 * retrieve_array
6255 *
6256 * Retrieve a whole array.
6257 * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
6258 * Each item is stored as <object>.
6259 *
6260 * When we come here, SX_ARRAY has been read already.
6261 */
retrieve_array(pTHX_ stcxt_t * cxt,const char * cname)6262 static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname)
6263 {
6264 I32 len, i;
6265 AV *av;
6266 SV *sv;
6267 HV *stash;
6268 bool seen_null = FALSE;
6269
6270 TRACEME(("retrieve_array (#%d)", (int)cxt->tagnum));
6271
6272 /*
6273 * Read length, and allocate array, then pre-extend it.
6274 */
6275
6276 RLEN(len);
6277 TRACEME(("size = %d", (int)len));
6278 av = newAV();
6279 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6280 SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */
6281 if (len)
6282 av_extend(av, len);
6283 else
6284 return (SV *) av; /* No data follow if array is empty */
6285
6286 /*
6287 * Now get each item in turn...
6288 */
6289
6290 for (i = 0; i < len; i++) {
6291 TRACEME(("(#%d) item", (int)i));
6292 sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
6293 if (!sv)
6294 return (SV *) 0;
6295 if (sv == &PL_sv_undef) {
6296 seen_null = TRUE;
6297 continue;
6298 }
6299 if (sv == &PL_sv_placeholder)
6300 sv = &PL_sv_undef;
6301 if (av_store(av, i, sv) == 0)
6302 return (SV *) 0;
6303 }
6304 if (seen_null) av_fill(av, len-1);
6305
6306 TRACEME(("ok (retrieve_array at 0x%" UVxf ")", PTR2UV(av)));
6307
6308 return (SV *) av;
6309 }
6310
6311 #ifdef HAS_U64
6312
6313 /* internal method with len already read */
6314
get_larray(pTHX_ stcxt_t * cxt,UV len,const char * cname)6315 static SV *get_larray(pTHX_ stcxt_t *cxt, UV len, const char *cname)
6316 {
6317 UV i;
6318 AV *av;
6319 SV *sv;
6320 HV *stash;
6321 bool seen_null = FALSE;
6322
6323 TRACEME(("get_larray (#%d) %lu", (int)cxt->tagnum, (unsigned long)len));
6324
6325 /*
6326 * allocate array, then pre-extend it.
6327 */
6328
6329 av = newAV();
6330 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6331 SEEN_NN(av, stash, 0); /* Will return if array not allocated nicely */
6332 assert(len);
6333 av_extend(av, len);
6334
6335 /*
6336 * Now get each item in turn...
6337 */
6338
6339 for (i = 0; i < len; i++) {
6340 TRACEME(("(#%d) item", (int)i));
6341 sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
6342 if (!sv)
6343 return (SV *) 0;
6344 if (sv == &PL_sv_undef) {
6345 seen_null = TRUE;
6346 continue;
6347 }
6348 if (sv == &PL_sv_placeholder)
6349 sv = &PL_sv_undef;
6350 if (av_store(av, i, sv) == 0)
6351 return (SV *) 0;
6352 }
6353 if (seen_null) av_fill(av, len-1);
6354
6355 TRACEME(("ok (get_larray at 0x%" UVxf ")", PTR2UV(av)));
6356
6357 return (SV *) av;
6358 }
6359
6360 /*
6361 * get_lhash
6362 *
6363 * Retrieve a overlong hash table.
6364 * <len> is already read. What follows is each key/value pair, in random order.
6365 * Keys are stored as <length> <data>, the <data> section being omitted
6366 * if length is 0.
6367 * Values are stored as <object>.
6368 *
6369 */
get_lhash(pTHX_ stcxt_t * cxt,UV len,int hash_flags,const char * cname)6370 static SV *get_lhash(pTHX_ stcxt_t *cxt, UV len, int hash_flags, const char *cname)
6371 {
6372 UV size;
6373 UV i;
6374 HV *hv;
6375 SV *sv;
6376 HV *stash;
6377
6378 TRACEME(("get_lhash (#%d)", (int)cxt->tagnum));
6379
6380 #ifdef HAS_RESTRICTED_HASHES
6381 PERL_UNUSED_ARG(hash_flags);
6382 #else
6383 if (hash_flags & SHV_RESTRICTED) {
6384 if (cxt->derestrict < 0)
6385 cxt->derestrict = (SvTRUE
6386 (get_sv("Storable::downgrade_restricted", GV_ADD))
6387 ? 1 : 0);
6388 if (cxt->derestrict == 0)
6389 RESTRICTED_HASH_CROAK();
6390 }
6391 #endif
6392
6393 TRACEME(("size = %lu", (unsigned long)len));
6394 hv = newHV();
6395 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6396 SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */
6397 if (len == 0)
6398 return (SV *) hv; /* No data follow if table empty */
6399 TRACEME(("split %lu", (unsigned long)len+1));
6400 hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */
6401
6402 /*
6403 * Now get each key/value pair in turn...
6404 */
6405
6406 for (i = 0; i < len; i++) {
6407 /*
6408 * Get value first.
6409 */
6410
6411 TRACEME(("(#%d) value", (int)i));
6412 sv = retrieve(aTHX_ cxt, 0);
6413 if (!sv)
6414 return (SV *) 0;
6415
6416 /*
6417 * Get key.
6418 * Since we're reading into kbuf, we must ensure we're not
6419 * recursing between the read and the hv_store() where it's used.
6420 * Hence the key comes after the value.
6421 */
6422
6423 RLEN(size); /* Get key size */
6424 KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
6425 if (size)
6426 READ(kbuf, size);
6427 kbuf[size] = '\0'; /* Mark string end, just in case */
6428 TRACEME(("(#%d) key '%s'", (int)i, kbuf));
6429
6430 /*
6431 * Enter key/value pair into hash table.
6432 */
6433
6434 if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0)
6435 return (SV *) 0;
6436 }
6437
6438 TRACEME(("ok (get_lhash at 0x%" UVxf ")", PTR2UV(hv)));
6439 return (SV *) hv;
6440 }
6441 #endif
6442
6443 /*
6444 * retrieve_hash
6445 *
6446 * Retrieve a whole hash table.
6447 * Layout is SX_HASH <size> followed by each key/value pair, in random order.
6448 * Keys are stored as <length> <data>, the <data> section being omitted
6449 * if length is 0.
6450 * Values are stored as <object>.
6451 *
6452 * When we come here, SX_HASH has been read already.
6453 */
retrieve_hash(pTHX_ stcxt_t * cxt,const char * cname)6454 static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
6455 {
6456 I32 len;
6457 I32 size;
6458 I32 i;
6459 HV *hv;
6460 SV *sv;
6461 HV *stash;
6462
6463 TRACEME(("retrieve_hash (#%d)", (int)cxt->tagnum));
6464
6465 /*
6466 * Read length, allocate table.
6467 */
6468
6469 RLEN(len);
6470 TRACEME(("size = %d", (int)len));
6471 hv = newHV();
6472 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6473 SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */
6474 if (len == 0)
6475 return (SV *) hv; /* No data follow if table empty */
6476 TRACEME(("split %d", (int)len+1));
6477 hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */
6478
6479 /*
6480 * Now get each key/value pair in turn...
6481 */
6482
6483 for (i = 0; i < len; i++) {
6484 /*
6485 * Get value first.
6486 */
6487
6488 TRACEME(("(#%d) value", (int)i));
6489 sv = retrieve(aTHX_ cxt, 0);
6490 if (!sv)
6491 return (SV *) 0;
6492
6493 /*
6494 * Get key.
6495 * Since we're reading into kbuf, we must ensure we're not
6496 * recursing between the read and the hv_store() where it's used.
6497 * Hence the key comes after the value.
6498 */
6499
6500 RLEN(size); /* Get key size */
6501 KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
6502 if (size)
6503 READ(kbuf, size);
6504 kbuf[size] = '\0'; /* Mark string end, just in case */
6505 TRACEME(("(#%d) key '%s'", (int)i, kbuf));
6506
6507 /*
6508 * Enter key/value pair into hash table.
6509 */
6510
6511 if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0)
6512 return (SV *) 0;
6513 }
6514
6515 TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv)));
6516
6517 return (SV *) hv;
6518 }
6519
6520 /*
6521 * retrieve_hash
6522 *
6523 * Retrieve a whole hash table.
6524 * Layout is SX_HASH <size> followed by each key/value pair, in random order.
6525 * Keys are stored as <length> <data>, the <data> section being omitted
6526 * if length is 0.
6527 * Values are stored as <object>.
6528 *
6529 * When we come here, SX_HASH has been read already.
6530 */
retrieve_flag_hash(pTHX_ stcxt_t * cxt,const char * cname)6531 static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname)
6532 {
6533 dVAR;
6534 I32 len;
6535 I32 size;
6536 I32 i;
6537 HV *hv;
6538 SV *sv;
6539 HV *stash;
6540 int hash_flags;
6541
6542 GETMARK(hash_flags);
6543 TRACEME(("retrieve_flag_hash (#%d)", (int)cxt->tagnum));
6544 /*
6545 * Read length, allocate table.
6546 */
6547
6548 #ifndef HAS_RESTRICTED_HASHES
6549 if (hash_flags & SHV_RESTRICTED) {
6550 if (cxt->derestrict < 0)
6551 cxt->derestrict = (SvTRUE
6552 (get_sv("Storable::downgrade_restricted", GV_ADD))
6553 ? 1 : 0);
6554 if (cxt->derestrict == 0)
6555 RESTRICTED_HASH_CROAK();
6556 }
6557 #endif
6558
6559 RLEN(len);
6560 TRACEME(("size = %d, flags = %d", (int)len, hash_flags));
6561 hv = newHV();
6562 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6563 SEEN_NN(hv, stash, 0); /* Will return if table not allocated properly */
6564 if (len == 0)
6565 return (SV *) hv; /* No data follow if table empty */
6566 TRACEME(("split %d", (int)len+1));
6567 hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */
6568
6569 /*
6570 * Now get each key/value pair in turn...
6571 */
6572
6573 for (i = 0; i < len; i++) {
6574 int flags;
6575 int store_flags = 0;
6576 /*
6577 * Get value first.
6578 */
6579
6580 TRACEME(("(#%d) value", (int)i));
6581 sv = retrieve(aTHX_ cxt, 0);
6582 if (!sv)
6583 return (SV *) 0;
6584
6585 GETMARK(flags);
6586 #ifdef HAS_RESTRICTED_HASHES
6587 if ((hash_flags & SHV_RESTRICTED) && (flags & SHV_K_LOCKED))
6588 SvREADONLY_on(sv);
6589 #endif
6590
6591 if (flags & SHV_K_ISSV) {
6592 /* XXX you can't set a placeholder with an SV key.
6593 Then again, you can't get an SV key.
6594 Without messing around beyond what the API is supposed to do.
6595 */
6596 SV *keysv;
6597 TRACEME(("(#%d) keysv, flags=%d", (int)i, flags));
6598 keysv = retrieve(aTHX_ cxt, 0);
6599 if (!keysv)
6600 return (SV *) 0;
6601
6602 if (!hv_store_ent(hv, keysv, sv, 0))
6603 return (SV *) 0;
6604 } else {
6605 /*
6606 * Get key.
6607 * Since we're reading into kbuf, we must ensure we're not
6608 * recursing between the read and the hv_store() where it's used.
6609 * Hence the key comes after the value.
6610 */
6611
6612 if (flags & SHV_K_PLACEHOLDER) {
6613 SvREFCNT_dec (sv);
6614 sv = &PL_sv_placeholder;
6615 store_flags |= HVhek_PLACEHOLD;
6616 }
6617 if (flags & SHV_K_UTF8) {
6618 #ifdef HAS_UTF8_HASHES
6619 store_flags |= HVhek_UTF8;
6620 #else
6621 if (cxt->use_bytes < 0)
6622 cxt->use_bytes
6623 = (SvTRUE(get_sv("Storable::drop_utf8", GV_ADD))
6624 ? 1 : 0);
6625 if (cxt->use_bytes == 0)
6626 UTF8_CROAK();
6627 #endif
6628 }
6629 #ifdef HAS_UTF8_HASHES
6630 if (flags & SHV_K_WASUTF8)
6631 store_flags |= HVhek_WASUTF8;
6632 #endif
6633
6634 RLEN(size); /* Get key size */
6635 KBUFCHK((STRLEN)size);/* Grow hash key read pool if needed */
6636 if (size)
6637 READ(kbuf, size);
6638 kbuf[size] = '\0'; /* Mark string end, just in case */
6639 TRACEME(("(#%d) key '%s' flags %X store_flags %X", (int)i, kbuf,
6640 flags, store_flags));
6641
6642 /*
6643 * Enter key/value pair into hash table.
6644 */
6645
6646 #ifdef HAS_RESTRICTED_HASHES
6647 if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0)
6648 return (SV *) 0;
6649 #else
6650 if (!(store_flags & HVhek_PLACEHOLD))
6651 if (hv_store(hv, kbuf, size, sv, 0) == 0)
6652 return (SV *) 0;
6653 #endif
6654 }
6655 }
6656 #ifdef HAS_RESTRICTED_HASHES
6657 if (hash_flags & SHV_RESTRICTED)
6658 SvREADONLY_on(hv);
6659 #endif
6660
6661 TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv)));
6662
6663 return (SV *) hv;
6664 }
6665
6666 /*
6667 * retrieve_code
6668 *
6669 * Return a code reference.
6670 */
retrieve_code(pTHX_ stcxt_t * cxt,const char * cname)6671 static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
6672 {
6673 #if PERL_VERSION < 6
6674 CROAK(("retrieve_code does not work with perl 5.005 or less\n"));
6675 #else
6676 dSP;
6677 I32 type, count;
6678 IV tagnum;
6679 SV *cv;
6680 SV *sv, *text, *sub, *errsv;
6681 HV *stash;
6682
6683 TRACEME(("retrieve_code (#%d)", (int)cxt->tagnum));
6684
6685 /*
6686 * Insert dummy SV in the aseen array so that we don't screw
6687 * up the tag numbers. We would just make the internal
6688 * scalar an untagged item in the stream, but
6689 * retrieve_scalar() calls SEEN(). So we just increase the
6690 * tag number.
6691 */
6692 tagnum = cxt->tagnum;
6693 sv = newSViv(0);
6694 stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
6695 SEEN_NN(sv, stash, 0);
6696
6697 /*
6698 * Retrieve the source of the code reference
6699 * as a small or large scalar
6700 */
6701
6702 GETMARK(type);
6703 switch (type) {
6704 case SX_SCALAR:
6705 text = retrieve_scalar(aTHX_ cxt, cname);
6706 break;
6707 case SX_LSCALAR:
6708 text = retrieve_lscalar(aTHX_ cxt, cname);
6709 break;
6710 case SX_UTF8STR:
6711 text = retrieve_utf8str(aTHX_ cxt, cname);
6712 break;
6713 case SX_LUTF8STR:
6714 text = retrieve_lutf8str(aTHX_ cxt, cname);
6715 break;
6716 default:
6717 CROAK(("Unexpected type %d in retrieve_code\n", (int)type));
6718 }
6719
6720 if (!text) {
6721 CROAK(("Unable to retrieve code\n"));
6722 }
6723
6724 /*
6725 * prepend "sub " to the source
6726 */
6727
6728 sub = newSVpvs("sub ");
6729 if (SvUTF8(text))
6730 SvUTF8_on(sub);
6731 sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
6732 SvREFCNT_dec(text);
6733
6734 /*
6735 * evaluate the source to a code reference and use the CV value
6736 */
6737
6738 if (cxt->eval == NULL) {
6739 cxt->eval = get_sv("Storable::Eval", GV_ADD);
6740 SvREFCNT_inc(cxt->eval);
6741 }
6742 if (!SvTRUE(cxt->eval)) {
6743 if (cxt->forgive_me == 0 ||
6744 (cxt->forgive_me < 0 &&
6745 !(cxt->forgive_me = SvTRUE
6746 (get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
6747 ) {
6748 CROAK(("Can't eval, please set $Storable::Eval to a true value"));
6749 } else {
6750 sv = newSVsv(sub);
6751 /* fix up the dummy entry... */
6752 av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
6753 return sv;
6754 }
6755 }
6756
6757 ENTER;
6758 SAVETMPS;
6759
6760 errsv = get_sv("@", GV_ADD);
6761 SvPVCLEAR(errsv); /* clear $@ */
6762 if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) {
6763 PUSHMARK(sp);
6764 XPUSHs(sv_2mortal(newSVsv(sub)));
6765 PUTBACK;
6766 count = call_sv(cxt->eval, G_SCALAR);
6767 if (count != 1)
6768 CROAK(("Unexpected return value from $Storable::Eval callback\n"));
6769 } else {
6770 eval_sv(sub, G_SCALAR);
6771 }
6772 SPAGAIN;
6773 cv = POPs;
6774 PUTBACK;
6775
6776 if (SvTRUE(errsv)) {
6777 CROAK(("code %s caused an error: %s",
6778 SvPV_nolen(sub), SvPV_nolen(errsv)));
6779 }
6780
6781 if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
6782 sv = SvRV(cv);
6783 } else {
6784 CROAK(("code %s did not evaluate to a subroutine reference\n",
6785 SvPV_nolen(sub)));
6786 }
6787
6788 SvREFCNT_inc(sv); /* XXX seems to be necessary */
6789 SvREFCNT_dec(sub);
6790
6791 FREETMPS;
6792 LEAVE;
6793 /* fix up the dummy entry... */
6794 av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv));
6795
6796 return sv;
6797 #endif
6798 }
6799
retrieve_regexp(pTHX_ stcxt_t * cxt,const char * cname)6800 static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) {
6801 #if PERL_VERSION >= 8
6802 int op_flags;
6803 U32 re_len;
6804 STRLEN flags_len;
6805 SV *re;
6806 SV *flags;
6807 SV *re_ref;
6808 SV *sv;
6809 dSP;
6810 I32 count;
6811
6812 PERL_UNUSED_ARG(cname);
6813
6814 ENTER;
6815 SAVETMPS;
6816
6817 GETMARK(op_flags);
6818 if (op_flags & SHR_U32_RE_LEN) {
6819 RLEN(re_len);
6820 }
6821 else
6822 GETMARK(re_len);
6823
6824 re = sv_2mortal(NEWSV(10002, re_len ? re_len : 1));
6825 READ(SvPVX(re), re_len);
6826 SvCUR_set(re, re_len);
6827 *SvEND(re) = '\0';
6828 SvPOK_only(re);
6829
6830 GETMARK(flags_len);
6831 flags = sv_2mortal(NEWSV(10002, flags_len ? flags_len : 1));
6832 READ(SvPVX(flags), flags_len);
6833 SvCUR_set(flags, flags_len);
6834 *SvEND(flags) = '\0';
6835 SvPOK_only(flags);
6836
6837 PUSHMARK(SP);
6838
6839 XPUSHs(re);
6840 XPUSHs(flags);
6841
6842 PUTBACK;
6843
6844 count = call_pv("Storable::_make_re", G_SCALAR);
6845
6846 SPAGAIN;
6847
6848 if (count != 1)
6849 CROAK(("Bad count %d calling _make_re", count));
6850
6851 re_ref = POPs;
6852
6853 PUTBACK;
6854
6855 if (!SvROK(re_ref))
6856 CROAK(("_make_re didn't return a reference"));
6857
6858 sv = SvRV(re_ref);
6859 SvREFCNT_inc(sv);
6860
6861 FREETMPS;
6862 LEAVE;
6863
6864 return sv;
6865 #else
6866 CROAK(("retrieve_regexp does not work with 5.6 or earlier"));
6867 #endif
6868 }
6869
6870 /*
6871 * old_retrieve_array
6872 *
6873 * Retrieve a whole array in pre-0.6 binary format.
6874 *
6875 * Layout is SX_ARRAY <size> followed by each item, in increasing index order.
6876 * Each item is stored as SX_ITEM <object> or SX_IT_UNDEF for "holes".
6877 *
6878 * When we come here, SX_ARRAY has been read already.
6879 */
old_retrieve_array(pTHX_ stcxt_t * cxt,const char * cname)6880 static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname)
6881 {
6882 I32 len;
6883 I32 i;
6884 AV *av;
6885 SV *sv;
6886 int c;
6887
6888 PERL_UNUSED_ARG(cname);
6889 TRACEME(("old_retrieve_array (#%d)", (int)cxt->tagnum));
6890
6891 /*
6892 * Read length, and allocate array, then pre-extend it.
6893 */
6894
6895 RLEN(len);
6896 TRACEME(("size = %d", (int)len));
6897 av = newAV();
6898 SEEN0_NN(av, 0); /* Will return if array not allocated nicely */
6899 if (len)
6900 av_extend(av, len);
6901 else
6902 return (SV *) av; /* No data follow if array is empty */
6903
6904 /*
6905 * Now get each item in turn...
6906 */
6907
6908 for (i = 0; i < len; i++) {
6909 GETMARK(c);
6910 if (c == SX_IT_UNDEF) {
6911 TRACEME(("(#%d) undef item", (int)i));
6912 continue; /* av_extend() already filled us with undef */
6913 }
6914 if (c != SX_ITEM)
6915 (void) retrieve_other(aTHX_ cxt, 0);/* Will croak out */
6916 TRACEME(("(#%d) item", (int)i));
6917 sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */
6918 if (!sv)
6919 return (SV *) 0;
6920 if (av_store(av, i, sv) == 0)
6921 return (SV *) 0;
6922 }
6923
6924 TRACEME(("ok (old_retrieve_array at 0x%" UVxf ")", PTR2UV(av)));
6925
6926 return (SV *) av;
6927 }
6928
6929 /*
6930 * old_retrieve_hash
6931 *
6932 * Retrieve a whole hash table in pre-0.6 binary format.
6933 *
6934 * Layout is SX_HASH <size> followed by each key/value pair, in random order.
6935 * Keys are stored as SX_KEY <length> <data>, the <data> section being omitted
6936 * if length is 0.
6937 * Values are stored as SX_VALUE <object> or SX_VL_UNDEF for "holes".
6938 *
6939 * When we come here, SX_HASH has been read already.
6940 */
old_retrieve_hash(pTHX_ stcxt_t * cxt,const char * cname)6941 static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
6942 {
6943 I32 len;
6944 I32 size;
6945 I32 i;
6946 HV *hv;
6947 SV *sv = (SV *) 0;
6948 int c;
6949 SV *sv_h_undef = (SV *) 0; /* hv_store() bug */
6950
6951 PERL_UNUSED_ARG(cname);
6952 TRACEME(("old_retrieve_hash (#%d)", (int)cxt->tagnum));
6953
6954 /*
6955 * Read length, allocate table.
6956 */
6957
6958 RLEN(len);
6959 TRACEME(("size = %d", (int)len));
6960 hv = newHV();
6961 SEEN0_NN(hv, 0); /* Will return if table not allocated properly */
6962 if (len == 0)
6963 return (SV *) hv; /* No data follow if table empty */
6964 TRACEME(("split %d", (int)len+1));
6965 hv_ksplit(hv, len+1); /* pre-extend hash to save multiple splits */
6966
6967 /*
6968 * Now get each key/value pair in turn...
6969 */
6970
6971 for (i = 0; i < len; i++) {
6972 /*
6973 * Get value first.
6974 */
6975
6976 GETMARK(c);
6977 if (c == SX_VL_UNDEF) {
6978 TRACEME(("(#%d) undef value", (int)i));
6979 /*
6980 * Due to a bug in hv_store(), it's not possible to pass
6981 * &PL_sv_undef to hv_store() as a value, otherwise the
6982 * associated key will not be creatable any more. -- RAM, 14/01/97
6983 */
6984 if (!sv_h_undef)
6985 sv_h_undef = newSVsv(&PL_sv_undef);
6986 sv = SvREFCNT_inc(sv_h_undef);
6987 } else if (c == SX_VALUE) {
6988 TRACEME(("(#%d) value", (int)i));
6989 sv = retrieve(aTHX_ cxt, 0);
6990 if (!sv)
6991 return (SV *) 0;
6992 } else
6993 (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
6994
6995 /*
6996 * Get key.
6997 * Since we're reading into kbuf, we must ensure we're not
6998 * recursing between the read and the hv_store() where it's used.
6999 * Hence the key comes after the value.
7000 */
7001
7002 GETMARK(c);
7003 if (c != SX_KEY)
7004 (void) retrieve_other(aTHX_ cxt, 0); /* Will croak out */
7005 RLEN(size); /* Get key size */
7006 KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */
7007 if (size)
7008 READ(kbuf, size);
7009 kbuf[size] = '\0'; /* Mark string end, just in case */
7010 TRACEME(("(#%d) key '%s'", (int)i, kbuf));
7011
7012 /*
7013 * Enter key/value pair into hash table.
7014 */
7015
7016 if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0)
7017 return (SV *) 0;
7018 }
7019
7020 TRACEME(("ok (retrieve_hash at 0x%" UVxf ")", PTR2UV(hv)));
7021
7022 return (SV *) hv;
7023 }
7024
7025 /***
7026 *** Retrieval engine.
7027 ***/
7028
7029 /*
7030 * magic_check
7031 *
7032 * Make sure the stored data we're trying to retrieve has been produced
7033 * on an ILP compatible system with the same byteorder. It croaks out in
7034 * case an error is detected. [ILP = integer-long-pointer sizes]
7035 * Returns null if error is detected, &PL_sv_undef otherwise.
7036 *
7037 * Note that there's no byte ordering info emitted when network order was
7038 * used at store time.
7039 */
magic_check(pTHX_ stcxt_t * cxt)7040 static SV *magic_check(pTHX_ stcxt_t *cxt)
7041 {
7042 /* The worst case for a malicious header would be old magic (which is
7043 longer), major, minor, byteorder length byte of 255, 255 bytes of
7044 garbage, sizeof int, long, pointer, NV.
7045 So the worse of that we can read is 255 bytes of garbage plus 4.
7046 Err, I am assuming 8 bit bytes here. Please file a bug report if you're
7047 compiling perl on a system with chars that are larger than 8 bits.
7048 (Even Crays aren't *that* perverse).
7049 */
7050 unsigned char buf[4 + 255];
7051 unsigned char *current;
7052 int c;
7053 int length;
7054 int use_network_order;
7055 int use_NV_size;
7056 int old_magic = 0;
7057 int version_major;
7058 int version_minor = 0;
7059
7060 TRACEME(("magic_check"));
7061
7062 /*
7063 * The "magic number" is only for files, not when freezing in memory.
7064 */
7065
7066 if (cxt->fio) {
7067 /* This includes the '\0' at the end. I want to read the extra byte,
7068 which is usually going to be the major version number. */
7069 STRLEN len = sizeof(magicstr);
7070 STRLEN old_len;
7071
7072 READ(buf, (SSize_t)(len)); /* Not null-terminated */
7073
7074 /* Point at the byte after the byte we read. */
7075 current = buf + --len; /* Do the -- outside of macros. */
7076
7077 if (memNE(buf, magicstr, len)) {
7078 /*
7079 * Try to read more bytes to check for the old magic number, which
7080 * was longer.
7081 */
7082
7083 TRACEME(("trying for old magic number"));
7084
7085 old_len = sizeof(old_magicstr) - 1;
7086 READ(current + 1, (SSize_t)(old_len - len));
7087
7088 if (memNE(buf, old_magicstr, old_len))
7089 CROAK(("File is not a perl storable"));
7090 old_magic++;
7091 current = buf + old_len;
7092 }
7093 use_network_order = *current;
7094 } else {
7095 GETMARK(use_network_order);
7096 }
7097
7098 /*
7099 * Starting with 0.6, the "use_network_order" byte flag is also used to
7100 * indicate the version number of the binary, and therefore governs the
7101 * setting of sv_retrieve_vtbl. See magic_write().
7102 */
7103 if (old_magic && use_network_order > 1) {
7104 /* 0.1 dump - use_network_order is really byte order length */
7105 version_major = -1;
7106 }
7107 else {
7108 version_major = use_network_order >> 1;
7109 }
7110 cxt->retrieve_vtbl = (SV*(**)(pTHX_ stcxt_t *cxt, const char *cname)) (version_major > 0 ? sv_retrieve : sv_old_retrieve);
7111
7112 TRACEME(("magic_check: netorder = 0x%x", use_network_order));
7113
7114
7115 /*
7116 * Starting with 0.7 (binary major 2), a full byte is dedicated to the
7117 * minor version of the protocol. See magic_write().
7118 */
7119
7120 if (version_major > 1)
7121 GETMARK(version_minor);
7122
7123 cxt->ver_major = version_major;
7124 cxt->ver_minor = version_minor;
7125
7126 TRACEME(("binary image version is %d.%d", version_major, version_minor));
7127
7128 /*
7129 * Inter-operability sanity check: we can't retrieve something stored
7130 * using a format more recent than ours, because we have no way to
7131 * know what has changed, and letting retrieval go would mean a probable
7132 * failure reporting a "corrupted" storable file.
7133 */
7134
7135 if (
7136 version_major > STORABLE_BIN_MAJOR ||
7137 (version_major == STORABLE_BIN_MAJOR &&
7138 version_minor > STORABLE_BIN_MINOR)
7139 ) {
7140 int croak_now = 1;
7141 TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR,
7142 STORABLE_BIN_MINOR));
7143
7144 if (version_major == STORABLE_BIN_MAJOR) {
7145 TRACEME(("cxt->accept_future_minor is %d",
7146 cxt->accept_future_minor));
7147 if (cxt->accept_future_minor < 0)
7148 cxt->accept_future_minor
7149 = (SvTRUE(get_sv("Storable::accept_future_minor",
7150 GV_ADD))
7151 ? 1 : 0);
7152 if (cxt->accept_future_minor == 1)
7153 croak_now = 0; /* Don't croak yet. */
7154 }
7155 if (croak_now) {
7156 CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)",
7157 version_major, version_minor,
7158 STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR));
7159 }
7160 }
7161
7162 /*
7163 * If they stored using network order, there's no byte ordering
7164 * information to check.
7165 */
7166
7167 if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */
7168 return &PL_sv_undef; /* No byte ordering info */
7169
7170 /* In C truth is 1, falsehood is 0. Very convenient. */
7171 use_NV_size = version_major >= 2 && version_minor >= 2;
7172
7173 if (version_major >= 0) {
7174 GETMARK(c);
7175 }
7176 else {
7177 c = use_network_order;
7178 }
7179 length = c + 3 + use_NV_size;
7180 READ(buf, length); /* Not null-terminated */
7181
7182 TRACEME(("byte order '%.*s' %d", c, buf, c));
7183
7184 #ifdef USE_56_INTERWORK_KLUDGE
7185 /* No point in caching this in the context as we only need it once per
7186 retrieve, and we need to recheck it each read. */
7187 if (SvTRUE(get_sv("Storable::interwork_56_64bit", GV_ADD))) {
7188 if ((c != (sizeof (byteorderstr_56) - 1))
7189 || memNE(buf, byteorderstr_56, c))
7190 CROAK(("Byte order is not compatible"));
7191 } else
7192 #endif
7193 {
7194 if ((c != (sizeof (byteorderstr) - 1))
7195 || memNE(buf, byteorderstr, c))
7196 CROAK(("Byte order is not compatible"));
7197 }
7198
7199 current = buf + c;
7200
7201 /* sizeof(int) */
7202 if ((int) *current++ != sizeof(int))
7203 CROAK(("Integer size is not compatible"));
7204
7205 /* sizeof(long) */
7206 if ((int) *current++ != sizeof(long))
7207 CROAK(("Long integer size is not compatible"));
7208
7209 /* sizeof(char *) */
7210 if ((int) *current != sizeof(char *))
7211 CROAK(("Pointer size is not compatible"));
7212
7213 if (use_NV_size) {
7214 /* sizeof(NV) */
7215 if ((int) *++current != sizeof(NV))
7216 CROAK(("Double size is not compatible"));
7217 }
7218
7219 return &PL_sv_undef; /* OK */
7220 }
7221
7222 /*
7223 * retrieve
7224 *
7225 * Recursively retrieve objects from the specified file and return their
7226 * root SV (which may be an AV or an HV for what we care).
7227 * Returns null if there is a problem.
7228 */
retrieve(pTHX_ stcxt_t * cxt,const char * cname)7229 static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname)
7230 {
7231 int type;
7232 SV **svh;
7233 SV *sv;
7234
7235 TRACEME(("retrieve"));
7236
7237 /*
7238 * Grab address tag which identifies the object if we are retrieving
7239 * an older format. Since the new binary format counts objects and no
7240 * longer explicitly tags them, we must keep track of the correspondence
7241 * ourselves.
7242 *
7243 * The following section will disappear one day when the old format is
7244 * no longer supported, hence the final "goto" in the "if" block.
7245 */
7246
7247 if (cxt->hseen) { /* Retrieving old binary */
7248 stag_t tag;
7249 if (cxt->netorder) {
7250 I32 nettag;
7251 READ(&nettag, sizeof(I32)); /* Ordered sequence of I32 */
7252 tag = (stag_t) nettag;
7253 } else
7254 READ(&tag, sizeof(stag_t)); /* Original address of the SV */
7255
7256 GETMARK(type);
7257 if (type == SX_OBJECT) {
7258 I32 tagn;
7259 svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE);
7260 if (!svh)
7261 CROAK(("Old tag 0x%" UVxf " should have been mapped already",
7262 (UV) tag));
7263 tagn = SvIV(*svh); /* Mapped tag number computed earlier below */
7264
7265 /*
7266 * The following code is common with the SX_OBJECT case below.
7267 */
7268
7269 svh = av_fetch(cxt->aseen, tagn, FALSE);
7270 if (!svh)
7271 CROAK(("Object #%" IVdf " should have been retrieved already",
7272 (IV) tagn));
7273 sv = *svh;
7274 TRACEME(("has retrieved #%d at 0x%" UVxf, (int)tagn, PTR2UV(sv)));
7275 SvREFCNT_inc(sv); /* One more reference to this same sv */
7276 return sv; /* The SV pointer where object was retrieved */
7277 }
7278
7279 /*
7280 * Map new object, but don't increase tagnum. This will be done
7281 * by each of the retrieve_* functions when they call SEEN().
7282 *
7283 * The mapping associates the "tag" initially present with a unique
7284 * tag number. See test for SX_OBJECT above to see how this is perused.
7285 */
7286
7287 if (!hv_store(cxt->hseen, (char *) &tag, sizeof(tag),
7288 newSViv(cxt->tagnum), 0))
7289 return (SV *) 0;
7290
7291 goto first_time;
7292 }
7293
7294 /*
7295 * Regular post-0.6 binary format.
7296 */
7297
7298 GETMARK(type);
7299
7300 TRACEME(("retrieve type = %d", type));
7301
7302 /*
7303 * Are we dealing with an object we should have already retrieved?
7304 */
7305
7306 if (type == SX_OBJECT) {
7307 I32 tag;
7308 READ_I32(tag);
7309 tag = ntohl(tag);
7310 #ifndef HAS_U64
7311 /* A 32-bit system can't have over 2**31 objects anyway */
7312 if (tag < 0)
7313 CROAK(("Object #%" IVdf " out of range", (IV)tag));
7314 #endif
7315 /* Older versions of Storable on with 64-bit support on 64-bit
7316 systems can produce values above the 2G boundary (or wrapped above
7317 the 4G boundary, which we can't do much about), treat those as
7318 unsigned.
7319 This same commit stores tag ids over the 2G boundary as long tags
7320 since older Storables will mis-handle them as short tags.
7321 */
7322 svh = av_fetch(cxt->aseen, (U32)tag, FALSE);
7323 if (!svh)
7324 CROAK(("Object #%" IVdf " should have been retrieved already",
7325 (IV) tag));
7326 sv = *svh;
7327 TRACEME(("had retrieved #%d at 0x%" UVxf, (int)tag, PTR2UV(sv)));
7328 SvREFCNT_inc(sv); /* One more reference to this same sv */
7329 return sv; /* The SV pointer where object was retrieved */
7330 } else if (type >= SX_LAST && cxt->ver_minor > STORABLE_BIN_MINOR) {
7331 if (cxt->accept_future_minor < 0)
7332 cxt->accept_future_minor
7333 = (SvTRUE(get_sv("Storable::accept_future_minor",
7334 GV_ADD))
7335 ? 1 : 0);
7336 if (cxt->accept_future_minor == 1) {
7337 CROAK(("Storable binary image v%d.%d contains data of type %d. "
7338 "This Storable is v%d.%d and can only handle data types up to %d",
7339 cxt->ver_major, cxt->ver_minor, type,
7340 STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_LAST - 1));
7341 }
7342 }
7343
7344 first_time: /* Will disappear when support for old format is dropped */
7345
7346 /*
7347 * Okay, first time through for this one.
7348 */
7349
7350 sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname);
7351 if (!sv)
7352 return (SV *) 0; /* Failed */
7353
7354 /*
7355 * Old binary formats (pre-0.7).
7356 *
7357 * Final notifications, ended by SX_STORED may now follow.
7358 * Currently, the only pertinent notification to apply on the
7359 * freshly retrieved object is either:
7360 * SX_CLASS <char-len> <classname> for short classnames.
7361 * SX_LG_CLASS <int-len> <classname> for larger one (rare!).
7362 * Class name is then read into the key buffer pool used by
7363 * hash table key retrieval.
7364 */
7365
7366 if (cxt->ver_major < 2) {
7367 while ((type = GETCHAR()) != SX_STORED) {
7368 I32 len;
7369 HV* stash;
7370 switch (type) {
7371 case SX_CLASS:
7372 GETMARK(len); /* Length coded on a single char */
7373 break;
7374 case SX_LG_CLASS: /* Length coded on a regular integer */
7375 RLEN(len);
7376 break;
7377 case EOF:
7378 default:
7379 return (SV *) 0; /* Failed */
7380 }
7381 KBUFCHK((STRLEN)len); /* Grow buffer as necessary */
7382 if (len)
7383 READ(kbuf, len);
7384 kbuf[len] = '\0'; /* Mark string end */
7385 stash = gv_stashpvn(kbuf, len, GV_ADD);
7386 BLESS(sv, stash);
7387 }
7388 }
7389
7390 TRACEME(("ok (retrieved 0x%" UVxf ", refcnt=%d, %s)", PTR2UV(sv),
7391 (int)SvREFCNT(sv) - 1, sv_reftype(sv, FALSE)));
7392
7393 return sv; /* Ok */
7394 }
7395
7396 /*
7397 * do_retrieve
7398 *
7399 * Retrieve data held in file and return the root object.
7400 * Common routine for pretrieve and mretrieve.
7401 */
do_retrieve(pTHX_ PerlIO * f,SV * in,int optype,int flags)7402 static SV *do_retrieve(
7403 pTHX_
7404 PerlIO *f,
7405 SV *in,
7406 int optype,
7407 int flags)
7408 {
7409 dSTCXT;
7410 SV *sv;
7411 int is_tainted; /* Is input source tainted? */
7412 int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */
7413
7414 TRACEMED(("do_retrieve (optype = 0x%x, flags=0x%x)",
7415 (unsigned)optype, (unsigned)flags));
7416
7417 optype |= ST_RETRIEVE;
7418 cxt->flags = flags;
7419
7420 /*
7421 * Sanity assertions for retrieve dispatch tables.
7422 */
7423
7424 ASSERT(sizeof(sv_old_retrieve) == sizeof(sv_retrieve),
7425 ("old and new retrieve dispatch table have same size"));
7426 ASSERT(sv_old_retrieve[(int)SX_LAST] == retrieve_other,
7427 ("SX_LAST entry correctly initialized in old dispatch table"));
7428 ASSERT(sv_retrieve[(int)SX_LAST] == retrieve_other,
7429 ("SX_LAST entry correctly initialized in new dispatch table"));
7430
7431 /*
7432 * Workaround for CROAK leak: if they enter with a "dirty" context,
7433 * free up memory for them now.
7434 */
7435
7436 assert(cxt);
7437 if (cxt->s_dirty)
7438 clean_context(aTHX_ cxt);
7439
7440 /*
7441 * Now that STORABLE_xxx hooks exist, it is possible that they try to
7442 * re-enter retrieve() via the hooks.
7443 */
7444
7445 if (cxt->entry) {
7446 cxt = allocate_context(aTHX_ cxt);
7447 cxt->flags = flags;
7448 }
7449 INIT_TRACEME;
7450
7451 cxt->entry++;
7452
7453 ASSERT(cxt->entry == 1, ("starting new recursion"));
7454 ASSERT(!cxt->s_dirty, ("clean context"));
7455
7456 /*
7457 * Prepare context.
7458 *
7459 * Data is loaded into the memory buffer when f is NULL, unless 'in' is
7460 * also NULL, in which case we're expecting the data to already lie
7461 * in the buffer (dclone case).
7462 */
7463
7464 KBUFINIT(); /* Allocate hash key reading pool once */
7465
7466 if (!f && in) {
7467 #ifdef SvUTF8_on
7468 if (SvUTF8(in)) {
7469 STRLEN length;
7470 const char *orig = SvPV(in, length);
7471 char *asbytes;
7472 /* This is quite deliberate. I want the UTF8 routines
7473 to encounter the '\0' which perl adds at the end
7474 of all scalars, so that any new string also has
7475 this.
7476 */
7477 STRLEN klen_tmp = length + 1;
7478 bool is_utf8 = TRUE;
7479
7480 /* Just casting the &klen to (STRLEN) won't work
7481 well if STRLEN and I32 are of different widths.
7482 --jhi */
7483 asbytes = (char*)bytes_from_utf8((U8*)orig,
7484 &klen_tmp,
7485 &is_utf8);
7486 if (is_utf8) {
7487 CROAK(("Frozen string corrupt - contains characters outside 0-255"));
7488 }
7489 if (asbytes != orig) {
7490 /* String has been converted.
7491 There is no need to keep any reference to
7492 the old string. */
7493 in = sv_newmortal();
7494 /* We donate the SV the malloc()ed string
7495 bytes_from_utf8 returned us. */
7496 SvUPGRADE(in, SVt_PV);
7497 SvPOK_on(in);
7498 SvPV_set(in, asbytes);
7499 SvLEN_set(in, klen_tmp);
7500 SvCUR_set(in, klen_tmp - 1);
7501 }
7502 }
7503 #endif
7504 MBUF_SAVE_AND_LOAD(in);
7505 }
7506
7507 /*
7508 * Magic number verifications.
7509 *
7510 * This needs to be done before calling init_retrieve_context()
7511 * since the format indication in the file are necessary to conduct
7512 * some of the initializations.
7513 */
7514
7515 cxt->fio = f; /* Where I/O are performed */
7516
7517 if (!magic_check(aTHX_ cxt))
7518 CROAK(("Magic number checking on storable %s failed",
7519 cxt->fio ? "file" : "string"));
7520
7521 TRACEME(("data stored in %s format",
7522 cxt->netorder ? "net order" : "native"));
7523
7524 /*
7525 * Check whether input source is tainted, so that we don't wrongly
7526 * taint perfectly good values...
7527 *
7528 * We assume file input is always tainted. If both 'f' and 'in' are
7529 * NULL, then we come from dclone, and tainted is already filled in
7530 * the context. That's a kludge, but the whole dclone() thing is
7531 * already quite a kludge anyway! -- RAM, 15/09/2000.
7532 */
7533
7534 is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted);
7535 TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted"));
7536 init_retrieve_context(aTHX_ cxt, optype, is_tainted);
7537
7538 ASSERT(is_retrieving(aTHX), ("within retrieve operation"));
7539
7540 sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */
7541
7542 /*
7543 * Final cleanup.
7544 */
7545
7546 if (!f && in)
7547 MBUF_RESTORE();
7548
7549 pre_06_fmt = cxt->hseen != NULL; /* Before we clean context */
7550
7551 /*
7552 * The "root" context is never freed.
7553 */
7554
7555 clean_retrieve_context(aTHX_ cxt);
7556 if (cxt->prev) /* This context was stacked */
7557 free_context(aTHX_ cxt); /* It was not the "root" context */
7558
7559 /*
7560 * Prepare returned value.
7561 */
7562
7563 if (!sv) {
7564 TRACEMED(("retrieve ERROR"));
7565 #if (PATCHLEVEL <= 4)
7566 /* perl 5.00405 seems to screw up at this point with an
7567 'attempt to modify a read only value' error reported in the
7568 eval { $self = pretrieve(*FILE) } in _retrieve.
7569 I can't see what the cause of this error is, but I suspect a
7570 bug in 5.004, as it seems to be capable of issuing spurious
7571 errors or core dumping with matches on $@. I'm not going to
7572 spend time on what could be a fruitless search for the cause,
7573 so here's a bodge. If you're running 5.004 and don't like
7574 this inefficiency, either upgrade to a newer perl, or you are
7575 welcome to find the problem and send in a patch.
7576 */
7577 return newSV(0);
7578 #else
7579 return &PL_sv_undef; /* Something went wrong, return undef */
7580 #endif
7581 }
7582
7583 TRACEMED(("retrieve got %s(0x%" UVxf ")",
7584 sv_reftype(sv, FALSE), PTR2UV(sv)));
7585
7586 /*
7587 * Backward compatibility with Storable-0.5@9 (which we know we
7588 * are retrieving if hseen is non-null): don't create an extra RV
7589 * for objects since we special-cased it at store time.
7590 *
7591 * Build a reference to the SV returned by pretrieve even if it is
7592 * already one and not a scalar, for consistency reasons.
7593 */
7594
7595 if (pre_06_fmt) { /* Was not handling overloading by then */
7596 SV *rv;
7597 TRACEMED(("fixing for old formats -- pre 0.6"));
7598 if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) {
7599 TRACEME(("ended do_retrieve() with an object -- pre 0.6"));
7600 return sv;
7601 }
7602 }
7603
7604 /*
7605 * If reference is overloaded, restore behaviour.
7606 *
7607 * NB: minor glitch here: normally, overloaded refs are stored specially
7608 * so that we can croak when behaviour cannot be re-installed, and also
7609 * avoid testing for overloading magic at each reference retrieval.
7610 *
7611 * Unfortunately, the root reference is implicitly stored, so we must
7612 * check for possible overloading now. Furthermore, if we don't restore
7613 * overloading, we cannot croak as if the original ref was, because we
7614 * have no way to determine whether it was an overloaded ref or not in
7615 * the first place.
7616 *
7617 * It's a pity that overloading magic is attached to the rv, and not to
7618 * the underlying sv as blessing is.
7619 */
7620
7621 if (SvOBJECT(sv)) {
7622 HV *stash = (HV *) SvSTASH(sv);
7623 SV *rv = newRV_noinc(sv);
7624 if (stash && Gv_AMG(stash)) {
7625 SvAMAGIC_on(rv);
7626 TRACEMED(("restored overloading on root reference"));
7627 }
7628 TRACEMED(("ended do_retrieve() with an object"));
7629 return rv;
7630 }
7631
7632 TRACEMED(("regular do_retrieve() end"));
7633
7634 return newRV_noinc(sv);
7635 }
7636
7637 /*
7638 * pretrieve
7639 *
7640 * Retrieve data held in file and return the root object, undef on error.
7641 */
pretrieve(pTHX_ PerlIO * f,IV flag)7642 static SV *pretrieve(pTHX_ PerlIO *f, IV flag)
7643 {
7644 TRACEMED(("pretrieve"));
7645 return do_retrieve(aTHX_ f, Nullsv, 0, (int)flag);
7646 }
7647
7648 /*
7649 * mretrieve
7650 *
7651 * Retrieve data held in scalar and return the root object, undef on error.
7652 */
mretrieve(pTHX_ SV * sv,IV flag)7653 static SV *mretrieve(pTHX_ SV *sv, IV flag)
7654 {
7655 TRACEMED(("mretrieve"));
7656 return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0, (int)flag);
7657 }
7658
7659 /***
7660 *** Deep cloning
7661 ***/
7662
7663 /*
7664 * dclone
7665 *
7666 * Deep clone: returns a fresh copy of the original referenced SV tree.
7667 *
7668 * This is achieved by storing the object in memory and restoring from
7669 * there. Not that efficient, but it should be faster than doing it from
7670 * pure perl anyway.
7671 */
dclone(pTHX_ SV * sv)7672 static SV *dclone(pTHX_ SV *sv)
7673 {
7674 dSTCXT;
7675 STRLEN size;
7676 stcxt_t *real_context;
7677 SV *out;
7678
7679 TRACEMED(("dclone"));
7680
7681 /*
7682 * Workaround for CROAK leak: if they enter with a "dirty" context,
7683 * free up memory for them now.
7684 */
7685
7686 assert(cxt);
7687 if (cxt->s_dirty)
7688 clean_context(aTHX_ cxt);
7689
7690 /*
7691 * Tied elements seem to need special handling.
7692 */
7693
7694 if ((SvTYPE(sv) == SVt_PVLV
7695 #if PERL_VERSION < 8
7696 || SvTYPE(sv) == SVt_PVMG
7697 #endif
7698 ) && (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG)) ==
7699 (SVs_GMG|SVs_SMG|SVs_RMG) &&
7700 mg_find(sv, 'p')) {
7701 mg_get(sv);
7702 }
7703
7704 /*
7705 * do_store() optimizes for dclone by not freeing its context, should
7706 * we need to allocate one because we're deep cloning from a hook.
7707 */
7708
7709 if (!do_store(aTHX_ (PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0))
7710 return &PL_sv_undef; /* Error during store */
7711
7712 /*
7713 * Because of the above optimization, we have to refresh the context,
7714 * since a new one could have been allocated and stacked by do_store().
7715 */
7716
7717 { dSTCXT; real_context = cxt; } /* Sub-block needed for macro */
7718 cxt = real_context; /* And we need this temporary... */
7719
7720 /*
7721 * Now, 'cxt' may refer to a new context.
7722 */
7723
7724 assert(cxt);
7725 ASSERT(!cxt->s_dirty, ("clean context"));
7726 ASSERT(!cxt->entry, ("entry will not cause new context allocation"));
7727
7728 size = MBUF_SIZE();
7729 TRACEME(("dclone stored %ld bytes", (long)size));
7730 MBUF_INIT(size);
7731
7732 /*
7733 * Since we're passing do_retrieve() both a NULL file and sv, we need
7734 * to pre-compute the taintedness of the input by setting cxt->tainted
7735 * to whatever state our own input string was. -- RAM, 15/09/2000
7736 *
7737 * do_retrieve() will free non-root context.
7738 */
7739
7740 cxt->s_tainted = SvTAINTED(sv);
7741 out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE, FLAG_BLESS_OK | FLAG_TIE_OK);
7742
7743 TRACEMED(("dclone returns 0x%" UVxf, PTR2UV(out)));
7744
7745 return out;
7746 }
7747
7748 /***
7749 *** Glue with perl.
7750 ***/
7751
7752 /*
7753 * The Perl IO GV object distinguishes between input and output for sockets
7754 * but not for plain files. To allow Storable to transparently work on
7755 * plain files and sockets transparently, we have to ask xsubpp to fetch the
7756 * right object for us. Hence the OutputStream and InputStream declarations.
7757 *
7758 * Before perl 5.004_05, those entries in the standard typemap are not
7759 * defined in perl include files, so we do that here.
7760 */
7761
7762 #ifndef OutputStream
7763 #define OutputStream PerlIO *
7764 #define InputStream PerlIO *
7765 #endif /* !OutputStream */
7766
7767 static int
storable_free(pTHX_ SV * sv,MAGIC * mg)7768 storable_free(pTHX_ SV *sv, MAGIC* mg) {
7769 stcxt_t *cxt = (stcxt_t *)SvPVX(sv);
7770
7771 PERL_UNUSED_ARG(mg);
7772 #ifdef USE_PTR_TABLE
7773 if (cxt->pseen)
7774 ptr_table_free(cxt->pseen);
7775 #endif
7776 if (kbuf)
7777 Safefree(kbuf);
7778 if (!cxt->membuf_ro && mbase)
7779 Safefree(mbase);
7780 if (cxt->membuf_ro && (cxt->msaved).arena)
7781 Safefree((cxt->msaved).arena);
7782 return 0;
7783 }
7784
7785 MODULE = Storable PACKAGE = Storable
7786
7787 PROTOTYPES: ENABLE
7788
7789 BOOT:
7790 {
7791 HV *stash = gv_stashpvn("Storable", 8, GV_ADD);
7792 newCONSTSUB(stash, "BIN_MAJOR", newSViv(STORABLE_BIN_MAJOR));
7793 newCONSTSUB(stash, "BIN_MINOR", newSViv(STORABLE_BIN_MINOR));
7794 newCONSTSUB(stash, "BIN_WRITE_MINOR", newSViv(STORABLE_BIN_WRITE_MINOR));
7795
7796 init_perinterp(aTHX);
7797 gv_fetchpv("Storable::drop_utf8", GV_ADDMULTI, SVt_PV);
7798 #ifdef DEBUGME
7799 /* Only disable the used only once warning if we are in debugging mode. */
7800 gv_fetchpv("Storable::DEBUGME", GV_ADDMULTI, SVt_PV);
7801 #endif
7802 #ifdef USE_56_INTERWORK_KLUDGE
7803 gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV);
7804 #endif
7805 }
7806
7807 void
7808 init_perinterp()
7809 CODE:
7810 init_perinterp(aTHX);
7811
7812 # pstore
7813 #
7814 # Store the transitive data closure of given object to disk.
7815 # Returns undef on error, a true value otherwise.
7816
7817 # net_pstore
7818 #
7819 # Same as pstore(), but network order is used for integers and doubles are
7820 # emitted as strings.
7821
7822 SV *
7823 pstore(f,obj)
7824 OutputStream f
7825 SV* obj
7826 ALIAS:
7827 net_pstore = 1
7828 PPCODE:
7829 RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef;
7830 /* do_store() can reallocate the stack, so need a sequence point to ensure
7831 that ST(0) knows about it. Hence using two statements. */
7832 ST(0) = RETVAL;
7833 XSRETURN(1);
7834
7835 # mstore
7836 #
7837 # Store the transitive data closure of given object to memory.
7838 # Returns undef on error, a scalar value containing the data otherwise.
7839
7840 # net_mstore
7841 #
7842 # Same as mstore(), but network order is used for integers and doubles are
7843 # emitted as strings.
7844
7845 SV *
7846 mstore(obj)
7847 SV* obj
7848 ALIAS:
7849 net_mstore = 1
7850 CODE:
7851 RETVAL = &PL_sv_undef;
7852 if (!do_store(aTHX_ (PerlIO*) 0, obj, 0, ix, &RETVAL))
7853 RETVAL = &PL_sv_undef;
7854 OUTPUT:
7855 RETVAL
7856
7857 SV *
7858 pretrieve(f, flag = 6)
7859 InputStream f
7860 IV flag
7861 CODE:
7862 RETVAL = pretrieve(aTHX_ f, flag);
7863 OUTPUT:
7864 RETVAL
7865
7866 SV *
7867 mretrieve(sv, flag = 6)
7868 SV* sv
7869 IV flag
7870 CODE:
7871 RETVAL = mretrieve(aTHX_ sv, flag);
7872 OUTPUT:
7873 RETVAL
7874
7875 SV *
7876 dclone(sv)
7877 SV* sv
7878 CODE:
7879 RETVAL = dclone(aTHX_ sv);
7880 OUTPUT:
7881 RETVAL
7882
7883 void
7884 last_op_in_netorder()
7885 ALIAS:
7886 is_storing = ST_STORE
7887 is_retrieving = ST_RETRIEVE
7888 PREINIT:
7889 bool result;
7890 CODE:
7891 if (ix) {
7892 dSTCXT;
7893 assert(cxt);
7894 result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE;
7895 } else {
7896 result = !!last_op_in_netorder(aTHX);
7897 }
7898 ST(0) = boolSV(result);
7899
7900
7901 IV
7902 stack_depth()
7903 CODE:
7904 RETVAL = SvIV(get_sv("Storable::recursion_limit", GV_ADD));
7905 OUTPUT:
7906 RETVAL
7907
7908 IV
7909 stack_depth_hash()
7910 CODE:
7911 RETVAL = SvIV(get_sv("Storable::recursion_limit_hash", GV_ADD));
7912 OUTPUT:
7913 RETVAL
7914