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