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