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