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