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