1 /* hv.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * I sit beside the fire and think 13 * of all that I have seen. 14 * --Bilbo 15 * 16 * [p.278 of _The Lord of the Rings_, II/iii: "The Ring Goes South"] 17 */ 18 19 /* 20 =head1 Hash Manipulation Functions 21 22 A HV structure represents a Perl hash. It consists mainly of an array 23 of pointers, each of which points to a linked list of HE structures. The 24 array is indexed by the hash function of the key, so each linked list 25 represents all the hash entries with the same hash value. Each HE contains 26 a pointer to the actual value, plus a pointer to a HEK structure which 27 holds the key and hash value. 28 29 =cut 30 31 */ 32 33 #include "EXTERN.h" 34 #define PERL_IN_HV_C 35 #define PERL_HASH_INTERNAL_ACCESS 36 #include "perl.h" 37 38 #define HV_MAX_LENGTH_BEFORE_SPLIT 14 39 40 static const char S_strtab_error[] 41 = "Cannot modify shared string table in hv_%s"; 42 43 STATIC void 44 S_more_he(pTHX) 45 { 46 dVAR; 47 /* We could generate this at compile time via (another) auxiliary C 48 program? */ 49 const size_t arena_size = Perl_malloc_good_size(PERL_ARENA_SIZE); 50 HE* he = (HE*) Perl_get_arena(aTHX_ arena_size, HE_SVSLOT); 51 HE * const heend = &he[arena_size / sizeof(HE) - 1]; 52 53 PL_body_roots[HE_SVSLOT] = he; 54 while (he < heend) { 55 HeNEXT(he) = (HE*)(he + 1); 56 he++; 57 } 58 HeNEXT(he) = 0; 59 } 60 61 #ifdef PURIFY 62 63 #define new_HE() (HE*)safemalloc(sizeof(HE)) 64 #define del_HE(p) safefree((char*)p) 65 66 #else 67 68 STATIC HE* 69 S_new_he(pTHX) 70 { 71 dVAR; 72 HE* he; 73 void ** const root = &PL_body_roots[HE_SVSLOT]; 74 75 if (!*root) 76 S_more_he(aTHX); 77 he = (HE*) *root; 78 assert(he); 79 *root = HeNEXT(he); 80 return he; 81 } 82 83 #define new_HE() new_he() 84 #define del_HE(p) \ 85 STMT_START { \ 86 HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \ 87 PL_body_roots[HE_SVSLOT] = p; \ 88 } STMT_END 89 90 91 92 #endif 93 94 STATIC HEK * 95 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) 96 { 97 const int flags_masked = flags & HVhek_MASK; 98 char *k; 99 register HEK *hek; 100 101 PERL_ARGS_ASSERT_SAVE_HEK_FLAGS; 102 103 Newx(k, HEK_BASESIZE + len + 2, char); 104 hek = (HEK*)k; 105 Copy(str, HEK_KEY(hek), len, char); 106 HEK_KEY(hek)[len] = 0; 107 HEK_LEN(hek) = len; 108 HEK_HASH(hek) = hash; 109 HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED; 110 111 if (flags & HVhek_FREEKEY) 112 Safefree(str); 113 return hek; 114 } 115 116 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent 117 * for tied hashes */ 118 119 void 120 Perl_free_tied_hv_pool(pTHX) 121 { 122 dVAR; 123 HE *he = PL_hv_fetch_ent_mh; 124 while (he) { 125 HE * const ohe = he; 126 Safefree(HeKEY_hek(he)); 127 he = HeNEXT(he); 128 del_HE(ohe); 129 } 130 PL_hv_fetch_ent_mh = NULL; 131 } 132 133 #if defined(USE_ITHREADS) 134 HEK * 135 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param) 136 { 137 HEK *shared; 138 139 PERL_ARGS_ASSERT_HEK_DUP; 140 PERL_UNUSED_ARG(param); 141 142 if (!source) 143 return NULL; 144 145 shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); 146 if (shared) { 147 /* We already shared this hash key. */ 148 (void)share_hek_hek(shared); 149 } 150 else { 151 shared 152 = share_hek_flags(HEK_KEY(source), HEK_LEN(source), 153 HEK_HASH(source), HEK_FLAGS(source)); 154 ptr_table_store(PL_ptr_table, source, shared); 155 } 156 return shared; 157 } 158 159 HE * 160 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) 161 { 162 HE *ret; 163 164 PERL_ARGS_ASSERT_HE_DUP; 165 166 if (!e) 167 return NULL; 168 /* look for it in the table first */ 169 ret = (HE*)ptr_table_fetch(PL_ptr_table, e); 170 if (ret) 171 return ret; 172 173 /* create anew and remember what it is */ 174 ret = new_HE(); 175 ptr_table_store(PL_ptr_table, e, ret); 176 177 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param); 178 if (HeKLEN(e) == HEf_SVKEY) { 179 char *k; 180 Newx(k, HEK_BASESIZE + sizeof(const SV *), char); 181 HeKEY_hek(ret) = (HEK*)k; 182 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param)); 183 } 184 else if (shared) { 185 /* This is hek_dup inlined, which seems to be important for speed 186 reasons. */ 187 HEK * const source = HeKEY_hek(e); 188 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); 189 190 if (shared) { 191 /* We already shared this hash key. */ 192 (void)share_hek_hek(shared); 193 } 194 else { 195 shared 196 = share_hek_flags(HEK_KEY(source), HEK_LEN(source), 197 HEK_HASH(source), HEK_FLAGS(source)); 198 ptr_table_store(PL_ptr_table, source, shared); 199 } 200 HeKEY_hek(ret) = shared; 201 } 202 else 203 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), 204 HeKFLAGS(e)); 205 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param)); 206 return ret; 207 } 208 #endif /* USE_ITHREADS */ 209 210 static void 211 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, 212 const char *msg) 213 { 214 SV * const sv = sv_newmortal(); 215 216 PERL_ARGS_ASSERT_HV_NOTALLOWED; 217 218 if (!(flags & HVhek_FREEKEY)) { 219 sv_setpvn(sv, key, klen); 220 } 221 else { 222 /* Need to free saved eventually assign to mortal SV */ 223 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */ 224 sv_usepvn(sv, (char *) key, klen); 225 } 226 if (flags & HVhek_UTF8) { 227 SvUTF8_on(sv); 228 } 229 Perl_croak(aTHX_ msg, SVfARG(sv)); 230 } 231 232 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot 233 * contains an SV* */ 234 235 /* 236 =for apidoc hv_store 237 238 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is 239 the length of the key. The C<hash> parameter is the precomputed hash 240 value; if it is zero then Perl will compute it. The return value will be 241 NULL if the operation failed or if the value did not need to be actually 242 stored within the hash (as in the case of tied hashes). Otherwise it can 243 be dereferenced to get the original C<SV*>. Note that the caller is 244 responsible for suitably incrementing the reference count of C<val> before 245 the call, and decrementing it if the function returned NULL. Effectively 246 a successful hv_store takes ownership of one reference to C<val>. This is 247 usually what you want; a newly created SV has a reference count of one, so 248 if all your code does is create SVs then store them in a hash, hv_store 249 will own the only reference to the new SV, and your code doesn't need to do 250 anything further to tidy up. hv_store is not implemented as a call to 251 hv_store_ent, and does not create a temporary SV for the key, so if your 252 key data is not already in SV form then use hv_store in preference to 253 hv_store_ent. 254 255 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more 256 information on how to use this function on tied hashes. 257 258 =for apidoc hv_store_ent 259 260 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash> 261 parameter is the precomputed hash value; if it is zero then Perl will 262 compute it. The return value is the new hash entry so created. It will be 263 NULL if the operation failed or if the value did not need to be actually 264 stored within the hash (as in the case of tied hashes). Otherwise the 265 contents of the return value can be accessed using the C<He?> macros 266 described here. Note that the caller is responsible for suitably 267 incrementing the reference count of C<val> before the call, and 268 decrementing it if the function returned NULL. Effectively a successful 269 hv_store_ent takes ownership of one reference to C<val>. This is 270 usually what you want; a newly created SV has a reference count of one, so 271 if all your code does is create SVs then store them in a hash, hv_store 272 will own the only reference to the new SV, and your code doesn't need to do 273 anything further to tidy up. Note that hv_store_ent only reads the C<key>; 274 unlike C<val> it does not take ownership of it, so maintaining the correct 275 reference count on C<key> is entirely the caller's responsibility. hv_store 276 is not implemented as a call to hv_store_ent, and does not create a temporary 277 SV for the key, so if your key data is not already in SV form then use 278 hv_store in preference to hv_store_ent. 279 280 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more 281 information on how to use this function on tied hashes. 282 283 =for apidoc hv_exists 284 285 Returns a boolean indicating whether the specified hash key exists. The 286 C<klen> is the length of the key. 287 288 =for apidoc hv_fetch 289 290 Returns the SV which corresponds to the specified key in the hash. The 291 C<klen> is the length of the key. If C<lval> is set then the fetch will be 292 part of a store. Check that the return value is non-null before 293 dereferencing it to an C<SV*>. 294 295 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more 296 information on how to use this function on tied hashes. 297 298 =for apidoc hv_exists_ent 299 300 Returns a boolean indicating whether the specified hash key exists. C<hash> 301 can be a valid precomputed hash value, or 0 to ask for it to be 302 computed. 303 304 =cut 305 */ 306 307 /* returns an HE * structure with the all fields set */ 308 /* note that hent_val will be a mortal sv for MAGICAL hashes */ 309 /* 310 =for apidoc hv_fetch_ent 311 312 Returns the hash entry which corresponds to the specified key in the hash. 313 C<hash> must be a valid precomputed hash number for the given C<key>, or 0 314 if you want the function to compute it. IF C<lval> is set then the fetch 315 will be part of a store. Make sure the return value is non-null before 316 accessing it. The return value when C<tb> is a tied hash is a pointer to a 317 static location, so be sure to make a copy of the structure if you need to 318 store it somewhere. 319 320 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more 321 information on how to use this function on tied hashes. 322 323 =cut 324 */ 325 326 /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */ 327 void * 328 Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, 329 const int action, SV *val, const U32 hash) 330 { 331 STRLEN klen; 332 int flags; 333 334 PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN; 335 336 if (klen_i32 < 0) { 337 klen = -klen_i32; 338 flags = HVhek_UTF8; 339 } else { 340 klen = klen_i32; 341 flags = 0; 342 } 343 return hv_common(hv, NULL, key, klen, flags, action, val, hash); 344 } 345 346 void * 347 Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 348 int flags, int action, SV *val, register U32 hash) 349 { 350 dVAR; 351 XPVHV* xhv; 352 HE *entry; 353 HE **oentry; 354 SV *sv; 355 bool is_utf8; 356 int masked_flags; 357 const int return_svp = action & HV_FETCH_JUST_SV; 358 359 if (!hv) 360 return NULL; 361 if (SvTYPE(hv) == SVTYPEMASK) 362 return NULL; 363 364 assert(SvTYPE(hv) == SVt_PVHV); 365 366 if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) { 367 MAGIC* mg; 368 if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) { 369 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 370 if (uf->uf_set == NULL) { 371 SV* obj = mg->mg_obj; 372 373 if (!keysv) { 374 keysv = newSVpvn_flags(key, klen, SVs_TEMP | 375 ((flags & HVhek_UTF8) 376 ? SVf_UTF8 : 0)); 377 } 378 379 mg->mg_obj = keysv; /* pass key */ 380 uf->uf_index = action; /* pass action */ 381 magic_getuvar(MUTABLE_SV(hv), mg); 382 keysv = mg->mg_obj; /* may have changed */ 383 mg->mg_obj = obj; 384 385 /* If the key may have changed, then we need to invalidate 386 any passed-in computed hash value. */ 387 hash = 0; 388 } 389 } 390 } 391 if (keysv) { 392 if (flags & HVhek_FREEKEY) 393 Safefree(key); 394 key = SvPV_const(keysv, klen); 395 is_utf8 = (SvUTF8(keysv) != 0); 396 if (SvIsCOW_shared_hash(keysv)) { 397 flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0); 398 } else { 399 flags = 0; 400 } 401 } else { 402 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); 403 } 404 405 if (action & HV_DELETE) { 406 return (void *) hv_delete_common(hv, keysv, key, klen, 407 flags | (is_utf8 ? HVhek_UTF8 : 0), 408 action, hash); 409 } 410 411 xhv = (XPVHV*)SvANY(hv); 412 if (SvMAGICAL(hv)) { 413 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) { 414 if (mg_find((const SV *)hv, PERL_MAGIC_tied) 415 || SvGMAGICAL((const SV *)hv)) 416 { 417 /* FIXME should be able to skimp on the HE/HEK here when 418 HV_FETCH_JUST_SV is true. */ 419 if (!keysv) { 420 keysv = newSVpvn_utf8(key, klen, is_utf8); 421 } else { 422 keysv = newSVsv(keysv); 423 } 424 sv = sv_newmortal(); 425 mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY); 426 427 /* grab a fake HE/HEK pair from the pool or make a new one */ 428 entry = PL_hv_fetch_ent_mh; 429 if (entry) 430 PL_hv_fetch_ent_mh = HeNEXT(entry); 431 else { 432 char *k; 433 entry = new_HE(); 434 Newx(k, HEK_BASESIZE + sizeof(const SV *), char); 435 HeKEY_hek(entry) = (HEK*)k; 436 } 437 HeNEXT(entry) = NULL; 438 HeSVKEY_set(entry, keysv); 439 HeVAL(entry) = sv; 440 sv_upgrade(sv, SVt_PVLV); 441 LvTYPE(sv) = 'T'; 442 /* so we can free entry when freeing sv */ 443 LvTARG(sv) = MUTABLE_SV(entry); 444 445 /* XXX remove at some point? */ 446 if (flags & HVhek_FREEKEY) 447 Safefree(key); 448 449 if (return_svp) { 450 return entry ? (void *) &HeVAL(entry) : NULL; 451 } 452 return (void *) entry; 453 } 454 #ifdef ENV_IS_CASELESS 455 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { 456 U32 i; 457 for (i = 0; i < klen; ++i) 458 if (isLOWER(key[i])) { 459 /* Would be nice if we had a routine to do the 460 copy and upercase in a single pass through. */ 461 const char * const nkey = strupr(savepvn(key,klen)); 462 /* Note that this fetch is for nkey (the uppercased 463 key) whereas the store is for key (the original) */ 464 void *result = hv_common(hv, NULL, nkey, klen, 465 HVhek_FREEKEY, /* free nkey */ 466 0 /* non-LVAL fetch */ 467 | HV_DISABLE_UVAR_XKEY 468 | return_svp, 469 NULL /* no value */, 470 0 /* compute hash */); 471 if (!result && (action & HV_FETCH_LVALUE)) { 472 /* This call will free key if necessary. 473 Do it this way to encourage compiler to tail 474 call optimise. */ 475 result = hv_common(hv, keysv, key, klen, flags, 476 HV_FETCH_ISSTORE 477 | HV_DISABLE_UVAR_XKEY 478 | return_svp, 479 newSV(0), hash); 480 } else { 481 if (flags & HVhek_FREEKEY) 482 Safefree(key); 483 } 484 return result; 485 } 486 } 487 #endif 488 } /* ISFETCH */ 489 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { 490 if (mg_find((const SV *)hv, PERL_MAGIC_tied) 491 || SvGMAGICAL((const SV *)hv)) { 492 /* I don't understand why hv_exists_ent has svret and sv, 493 whereas hv_exists only had one. */ 494 SV * const svret = sv_newmortal(); 495 sv = sv_newmortal(); 496 497 if (keysv || is_utf8) { 498 if (!keysv) { 499 keysv = newSVpvn_utf8(key, klen, TRUE); 500 } else { 501 keysv = newSVsv(keysv); 502 } 503 mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY); 504 } else { 505 mg_copy(MUTABLE_SV(hv), sv, key, klen); 506 } 507 if (flags & HVhek_FREEKEY) 508 Safefree(key); 509 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem)); 510 /* This cast somewhat evil, but I'm merely using NULL/ 511 not NULL to return the boolean exists. 512 And I know hv is not NULL. */ 513 return SvTRUE(svret) ? (void *)hv : NULL; 514 } 515 #ifdef ENV_IS_CASELESS 516 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { 517 /* XXX This code isn't UTF8 clean. */ 518 char * const keysave = (char * const)key; 519 /* Will need to free this, so set FREEKEY flag. */ 520 key = savepvn(key,klen); 521 key = (const char*)strupr((char*)key); 522 is_utf8 = FALSE; 523 hash = 0; 524 keysv = 0; 525 526 if (flags & HVhek_FREEKEY) { 527 Safefree(keysave); 528 } 529 flags |= HVhek_FREEKEY; 530 } 531 #endif 532 } /* ISEXISTS */ 533 else if (action & HV_FETCH_ISSTORE) { 534 bool needs_copy; 535 bool needs_store; 536 hv_magic_check (hv, &needs_copy, &needs_store); 537 if (needs_copy) { 538 const bool save_taint = PL_tainted; 539 if (keysv || is_utf8) { 540 if (!keysv) { 541 keysv = newSVpvn_utf8(key, klen, TRUE); 542 } 543 if (PL_tainting) 544 PL_tainted = SvTAINTED(keysv); 545 keysv = sv_2mortal(newSVsv(keysv)); 546 mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY); 547 } else { 548 mg_copy(MUTABLE_SV(hv), val, key, klen); 549 } 550 551 TAINT_IF(save_taint); 552 if (!needs_store) { 553 if (flags & HVhek_FREEKEY) 554 Safefree(key); 555 return NULL; 556 } 557 #ifdef ENV_IS_CASELESS 558 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { 559 /* XXX This code isn't UTF8 clean. */ 560 const char *keysave = key; 561 /* Will need to free this, so set FREEKEY flag. */ 562 key = savepvn(key,klen); 563 key = (const char*)strupr((char*)key); 564 is_utf8 = FALSE; 565 hash = 0; 566 keysv = 0; 567 568 if (flags & HVhek_FREEKEY) { 569 Safefree(keysave); 570 } 571 flags |= HVhek_FREEKEY; 572 } 573 #endif 574 } 575 } /* ISSTORE */ 576 } /* SvMAGICAL */ 577 578 if (!HvARRAY(hv)) { 579 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) 580 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ 581 || (SvRMAGICAL((const SV *)hv) 582 && mg_find((const SV *)hv, PERL_MAGIC_env)) 583 #endif 584 ) { 585 char *array; 586 Newxz(array, 587 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), 588 char); 589 HvARRAY(hv) = (HE**)array; 590 } 591 #ifdef DYNAMIC_ENV_FETCH 592 else if (action & HV_FETCH_ISEXISTS) { 593 /* for an %ENV exists, if we do an insert it's by a recursive 594 store call, so avoid creating HvARRAY(hv) right now. */ 595 } 596 #endif 597 else { 598 /* XXX remove at some point? */ 599 if (flags & HVhek_FREEKEY) 600 Safefree(key); 601 602 return NULL; 603 } 604 } 605 606 if (is_utf8 & !(flags & HVhek_KEYCANONICAL)) { 607 char * const keysave = (char *)key; 608 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); 609 if (is_utf8) 610 flags |= HVhek_UTF8; 611 else 612 flags &= ~HVhek_UTF8; 613 if (key != keysave) { 614 if (flags & HVhek_FREEKEY) 615 Safefree(keysave); 616 flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 617 /* If the caller calculated a hash, it was on the sequence of 618 octets that are the UTF-8 form. We've now changed the sequence 619 of octets stored to that of the equivalent byte representation, 620 so the hash we need is different. */ 621 hash = 0; 622 } 623 } 624 625 if (HvREHASH(hv)) { 626 PERL_HASH_INTERNAL(hash, key, klen); 627 /* We don't have a pointer to the hv, so we have to replicate the 628 flag into every HEK, so that hv_iterkeysv can see it. */ 629 /* And yes, you do need this even though you are not "storing" because 630 you can flip the flags below if doing an lval lookup. (And that 631 was put in to give the semantics Andreas was expecting.) */ 632 flags |= HVhek_REHASH; 633 } else if (!hash) { 634 if (keysv && (SvIsCOW_shared_hash(keysv))) { 635 hash = SvSHARED_HASH(keysv); 636 } else { 637 PERL_HASH(hash, key, klen); 638 } 639 } 640 641 masked_flags = (flags & HVhek_MASK); 642 643 #ifdef DYNAMIC_ENV_FETCH 644 if (!HvARRAY(hv)) entry = NULL; 645 else 646 #endif 647 { 648 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; 649 } 650 for (; entry; entry = HeNEXT(entry)) { 651 if (HeHASH(entry) != hash) /* strings can't be equal */ 652 continue; 653 if (HeKLEN(entry) != (I32)klen) 654 continue; 655 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 656 continue; 657 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) 658 continue; 659 660 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) { 661 if (HeKFLAGS(entry) != masked_flags) { 662 /* We match if HVhek_UTF8 bit in our flags and hash key's 663 match. But if entry was set previously with HVhek_WASUTF8 664 and key now doesn't (or vice versa) then we should change 665 the key's flag, as this is assignment. */ 666 if (HvSHAREKEYS(hv)) { 667 /* Need to swap the key we have for a key with the flags we 668 need. As keys are shared we can't just write to the 669 flag, so we share the new one, unshare the old one. */ 670 HEK * const new_hek = share_hek_flags(key, klen, hash, 671 masked_flags); 672 unshare_hek (HeKEY_hek(entry)); 673 HeKEY_hek(entry) = new_hek; 674 } 675 else if (hv == PL_strtab) { 676 /* PL_strtab is usually the only hash without HvSHAREKEYS, 677 so putting this test here is cheap */ 678 if (flags & HVhek_FREEKEY) 679 Safefree(key); 680 Perl_croak(aTHX_ S_strtab_error, 681 action & HV_FETCH_LVALUE ? "fetch" : "store"); 682 } 683 else 684 HeKFLAGS(entry) = masked_flags; 685 if (masked_flags & HVhek_ENABLEHVKFLAGS) 686 HvHASKFLAGS_on(hv); 687 } 688 if (HeVAL(entry) == &PL_sv_placeholder) { 689 /* yes, can store into placeholder slot */ 690 if (action & HV_FETCH_LVALUE) { 691 if (SvMAGICAL(hv)) { 692 /* This preserves behaviour with the old hv_fetch 693 implementation which at this point would bail out 694 with a break; (at "if we find a placeholder, we 695 pretend we haven't found anything") 696 697 That break mean that if a placeholder were found, it 698 caused a call into hv_store, which in turn would 699 check magic, and if there is no magic end up pretty 700 much back at this point (in hv_store's code). */ 701 break; 702 } 703 /* LVAL fetch which actaully needs a store. */ 704 val = newSV(0); 705 HvPLACEHOLDERS(hv)--; 706 } else { 707 /* store */ 708 if (val != &PL_sv_placeholder) 709 HvPLACEHOLDERS(hv)--; 710 } 711 HeVAL(entry) = val; 712 } else if (action & HV_FETCH_ISSTORE) { 713 SvREFCNT_dec(HeVAL(entry)); 714 HeVAL(entry) = val; 715 } 716 } else if (HeVAL(entry) == &PL_sv_placeholder) { 717 /* if we find a placeholder, we pretend we haven't found 718 anything */ 719 break; 720 } 721 if (flags & HVhek_FREEKEY) 722 Safefree(key); 723 if (return_svp) { 724 return entry ? (void *) &HeVAL(entry) : NULL; 725 } 726 return entry; 727 } 728 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ 729 if (!(action & HV_FETCH_ISSTORE) 730 && SvRMAGICAL((const SV *)hv) 731 && mg_find((const SV *)hv, PERL_MAGIC_env)) { 732 unsigned long len; 733 const char * const env = PerlEnv_ENVgetenv_len(key,&len); 734 if (env) { 735 sv = newSVpvn(env,len); 736 SvTAINTED_on(sv); 737 return hv_common(hv, keysv, key, klen, flags, 738 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, 739 sv, hash); 740 } 741 } 742 #endif 743 744 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { 745 hv_notallowed(flags, key, klen, 746 "Attempt to access disallowed key '%"SVf"' in" 747 " a restricted hash"); 748 } 749 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) { 750 /* Not doing some form of store, so return failure. */ 751 if (flags & HVhek_FREEKEY) 752 Safefree(key); 753 return NULL; 754 } 755 if (action & HV_FETCH_LVALUE) { 756 val = newSV(0); 757 if (SvMAGICAL(hv)) { 758 /* At this point the old hv_fetch code would call to hv_store, 759 which in turn might do some tied magic. So we need to make that 760 magic check happen. */ 761 /* gonna assign to this, so it better be there */ 762 /* If a fetch-as-store fails on the fetch, then the action is to 763 recurse once into "hv_store". If we didn't do this, then that 764 recursive call would call the key conversion routine again. 765 However, as we replace the original key with the converted 766 key, this would result in a double conversion, which would show 767 up as a bug if the conversion routine is not idempotent. */ 768 return hv_common(hv, keysv, key, klen, flags, 769 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, 770 val, hash); 771 /* XXX Surely that could leak if the fetch-was-store fails? 772 Just like the hv_fetch. */ 773 } 774 } 775 776 /* Welcome to hv_store... */ 777 778 if (!HvARRAY(hv)) { 779 /* Not sure if we can get here. I think the only case of oentry being 780 NULL is for %ENV with dynamic env fetch. But that should disappear 781 with magic in the previous code. */ 782 char *array; 783 Newxz(array, 784 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), 785 char); 786 HvARRAY(hv) = (HE**)array; 787 } 788 789 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max]; 790 791 entry = new_HE(); 792 /* share_hek_flags will do the free for us. This might be considered 793 bad API design. */ 794 if (HvSHAREKEYS(hv)) 795 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); 796 else if (hv == PL_strtab) { 797 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting 798 this test here is cheap */ 799 if (flags & HVhek_FREEKEY) 800 Safefree(key); 801 Perl_croak(aTHX_ S_strtab_error, 802 action & HV_FETCH_LVALUE ? "fetch" : "store"); 803 } 804 else /* gotta do the real thing */ 805 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); 806 HeVAL(entry) = val; 807 HeNEXT(entry) = *oentry; 808 *oentry = entry; 809 810 if (val == &PL_sv_placeholder) 811 HvPLACEHOLDERS(hv)++; 812 if (masked_flags & HVhek_ENABLEHVKFLAGS) 813 HvHASKFLAGS_on(hv); 814 815 { 816 const HE *counter = HeNEXT(entry); 817 818 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ 819 if (!counter) { /* initial entry? */ 820 xhv->xhv_fill++; /* HvFILL(hv)++ */ 821 } else if (xhv->xhv_keys > (IV)xhv->xhv_max) { 822 hsplit(hv); 823 } else if(!HvREHASH(hv)) { 824 U32 n_links = 1; 825 826 while ((counter = HeNEXT(counter))) 827 n_links++; 828 829 if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) { 830 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit 831 bucket splits on a rehashed hash, as we're not going to 832 split it again, and if someone is lucky (evil) enough to 833 get all the keys in one list they could exhaust our memory 834 as we repeatedly double the number of buckets on every 835 entry. Linear search feels a less worse thing to do. */ 836 hsplit(hv); 837 } 838 } 839 } 840 841 if (return_svp) { 842 return entry ? (void *) &HeVAL(entry) : NULL; 843 } 844 return (void *) entry; 845 } 846 847 STATIC void 848 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store) 849 { 850 const MAGIC *mg = SvMAGIC(hv); 851 852 PERL_ARGS_ASSERT_HV_MAGIC_CHECK; 853 854 *needs_copy = FALSE; 855 *needs_store = TRUE; 856 while (mg) { 857 if (isUPPER(mg->mg_type)) { 858 *needs_copy = TRUE; 859 if (mg->mg_type == PERL_MAGIC_tied) { 860 *needs_store = FALSE; 861 return; /* We've set all there is to set. */ 862 } 863 } 864 mg = mg->mg_moremagic; 865 } 866 } 867 868 /* 869 =for apidoc hv_scalar 870 871 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied. 872 873 =cut 874 */ 875 876 SV * 877 Perl_hv_scalar(pTHX_ HV *hv) 878 { 879 SV *sv; 880 881 PERL_ARGS_ASSERT_HV_SCALAR; 882 883 if (SvRMAGICAL(hv)) { 884 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied); 885 if (mg) 886 return magic_scalarpack(hv, mg); 887 } 888 889 sv = sv_newmortal(); 890 if (HvFILL((const HV *)hv)) 891 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", 892 (long)HvFILL(hv), (long)HvMAX(hv) + 1); 893 else 894 sv_setiv(sv, 0); 895 896 return sv; 897 } 898 899 /* 900 =for apidoc hv_delete 901 902 Deletes a key/value pair in the hash. The value SV is removed from the 903 hash and returned to the caller. The C<klen> is the length of the key. 904 The C<flags> value will normally be zero; if set to G_DISCARD then NULL 905 will be returned. 906 907 =for apidoc hv_delete_ent 908 909 Deletes a key/value pair in the hash. The value SV is removed from the 910 hash and returned to the caller. The C<flags> value will normally be zero; 911 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid 912 precomputed hash value, or 0 to ask for it to be computed. 913 914 =cut 915 */ 916 917 STATIC SV * 918 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 919 int k_flags, I32 d_flags, U32 hash) 920 { 921 dVAR; 922 register XPVHV* xhv; 923 register HE *entry; 924 register HE **oentry; 925 HE *const *first_entry; 926 bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE; 927 int masked_flags; 928 929 if (SvRMAGICAL(hv)) { 930 bool needs_copy; 931 bool needs_store; 932 hv_magic_check (hv, &needs_copy, &needs_store); 933 934 if (needs_copy) { 935 SV *sv; 936 entry = (HE *) hv_common(hv, keysv, key, klen, 937 k_flags & ~HVhek_FREEKEY, 938 HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY, 939 NULL, hash); 940 sv = entry ? HeVAL(entry) : NULL; 941 if (sv) { 942 if (SvMAGICAL(sv)) { 943 mg_clear(sv); 944 } 945 if (!needs_store) { 946 if (mg_find(sv, PERL_MAGIC_tiedelem)) { 947 /* No longer an element */ 948 sv_unmagic(sv, PERL_MAGIC_tiedelem); 949 return sv; 950 } 951 return NULL; /* element cannot be deleted */ 952 } 953 #ifdef ENV_IS_CASELESS 954 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { 955 /* XXX This code isn't UTF8 clean. */ 956 keysv = newSVpvn_flags(key, klen, SVs_TEMP); 957 if (k_flags & HVhek_FREEKEY) { 958 Safefree(key); 959 } 960 key = strupr(SvPVX(keysv)); 961 is_utf8 = 0; 962 k_flags = 0; 963 hash = 0; 964 } 965 #endif 966 } 967 } 968 } 969 xhv = (XPVHV*)SvANY(hv); 970 if (!HvARRAY(hv)) 971 return NULL; 972 973 if (is_utf8) { 974 const char * const keysave = key; 975 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); 976 977 if (is_utf8) 978 k_flags |= HVhek_UTF8; 979 else 980 k_flags &= ~HVhek_UTF8; 981 if (key != keysave) { 982 if (k_flags & HVhek_FREEKEY) { 983 /* This shouldn't happen if our caller does what we expect, 984 but strictly the API allows it. */ 985 Safefree(keysave); 986 } 987 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 988 } 989 HvHASKFLAGS_on(MUTABLE_SV(hv)); 990 } 991 992 if (HvREHASH(hv)) { 993 PERL_HASH_INTERNAL(hash, key, klen); 994 } else if (!hash) { 995 if (keysv && (SvIsCOW_shared_hash(keysv))) { 996 hash = SvSHARED_HASH(keysv); 997 } else { 998 PERL_HASH(hash, key, klen); 999 } 1000 } 1001 1002 masked_flags = (k_flags & HVhek_MASK); 1003 1004 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; 1005 entry = *oentry; 1006 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { 1007 SV *sv; 1008 if (HeHASH(entry) != hash) /* strings can't be equal */ 1009 continue; 1010 if (HeKLEN(entry) != (I32)klen) 1011 continue; 1012 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 1013 continue; 1014 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) 1015 continue; 1016 1017 if (hv == PL_strtab) { 1018 if (k_flags & HVhek_FREEKEY) 1019 Safefree(key); 1020 Perl_croak(aTHX_ S_strtab_error, "delete"); 1021 } 1022 1023 /* if placeholder is here, it's already been deleted.... */ 1024 if (HeVAL(entry) == &PL_sv_placeholder) { 1025 if (k_flags & HVhek_FREEKEY) 1026 Safefree(key); 1027 return NULL; 1028 } 1029 if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { 1030 hv_notallowed(k_flags, key, klen, 1031 "Attempt to delete readonly key '%"SVf"' from" 1032 " a restricted hash"); 1033 } 1034 if (k_flags & HVhek_FREEKEY) 1035 Safefree(key); 1036 1037 if (d_flags & G_DISCARD) 1038 sv = NULL; 1039 else { 1040 sv = sv_2mortal(HeVAL(entry)); 1041 HeVAL(entry) = &PL_sv_placeholder; 1042 } 1043 1044 /* 1045 * If a restricted hash, rather than really deleting the entry, put 1046 * a placeholder there. This marks the key as being "approved", so 1047 * we can still access via not-really-existing key without raising 1048 * an error. 1049 */ 1050 if (SvREADONLY(hv)) { 1051 SvREFCNT_dec(HeVAL(entry)); 1052 HeVAL(entry) = &PL_sv_placeholder; 1053 /* We'll be saving this slot, so the number of allocated keys 1054 * doesn't go down, but the number placeholders goes up */ 1055 HvPLACEHOLDERS(hv)++; 1056 } else { 1057 *oentry = HeNEXT(entry); 1058 if(!*first_entry) { 1059 xhv->xhv_fill--; /* HvFILL(hv)-- */ 1060 } 1061 if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) 1062 HvLAZYDEL_on(hv); 1063 else 1064 hv_free_ent(hv, entry); 1065 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ 1066 if (xhv->xhv_keys == 0) 1067 HvHASKFLAGS_off(hv); 1068 } 1069 return sv; 1070 } 1071 if (SvREADONLY(hv)) { 1072 hv_notallowed(k_flags, key, klen, 1073 "Attempt to delete disallowed key '%"SVf"' from" 1074 " a restricted hash"); 1075 } 1076 1077 if (k_flags & HVhek_FREEKEY) 1078 Safefree(key); 1079 return NULL; 1080 } 1081 1082 STATIC void 1083 S_hsplit(pTHX_ HV *hv) 1084 { 1085 dVAR; 1086 register XPVHV* const xhv = (XPVHV*)SvANY(hv); 1087 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ 1088 register I32 newsize = oldsize * 2; 1089 register I32 i; 1090 char *a = (char*) HvARRAY(hv); 1091 register HE **aep; 1092 register HE **oentry; 1093 int longest_chain = 0; 1094 int was_shared; 1095 1096 PERL_ARGS_ASSERT_HSPLIT; 1097 1098 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n", 1099 (void*)hv, (int) oldsize);*/ 1100 1101 if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) { 1102 /* Can make this clear any placeholders first for non-restricted hashes, 1103 even though Storable rebuilds restricted hashes by putting in all the 1104 placeholders (first) before turning on the readonly flag, because 1105 Storable always pre-splits the hash. */ 1106 hv_clear_placeholders(hv); 1107 } 1108 1109 PL_nomemok = TRUE; 1110 #if defined(STRANGE_MALLOC) || defined(MYMALLOC) 1111 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) 1112 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); 1113 if (!a) { 1114 PL_nomemok = FALSE; 1115 return; 1116 } 1117 if (SvOOK(hv)) { 1118 Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); 1119 } 1120 #else 1121 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) 1122 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); 1123 if (!a) { 1124 PL_nomemok = FALSE; 1125 return; 1126 } 1127 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char); 1128 if (SvOOK(hv)) { 1129 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); 1130 } 1131 if (oldsize >= 64) { 1132 offer_nice_chunk(HvARRAY(hv), 1133 PERL_HV_ARRAY_ALLOC_BYTES(oldsize) 1134 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0)); 1135 } 1136 else 1137 Safefree(HvARRAY(hv)); 1138 #endif 1139 1140 PL_nomemok = FALSE; 1141 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ 1142 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ 1143 HvARRAY(hv) = (HE**) a; 1144 aep = (HE**)a; 1145 1146 for (i=0; i<oldsize; i++,aep++) { 1147 int left_length = 0; 1148 int right_length = 0; 1149 register HE *entry; 1150 register HE **bep; 1151 1152 if (!*aep) /* non-existent */ 1153 continue; 1154 bep = aep+oldsize; 1155 for (oentry = aep, entry = *aep; entry; entry = *oentry) { 1156 if ((HeHASH(entry) & newsize) != (U32)i) { 1157 *oentry = HeNEXT(entry); 1158 HeNEXT(entry) = *bep; 1159 if (!*bep) 1160 xhv->xhv_fill++; /* HvFILL(hv)++ */ 1161 *bep = entry; 1162 right_length++; 1163 continue; 1164 } 1165 else { 1166 oentry = &HeNEXT(entry); 1167 left_length++; 1168 } 1169 } 1170 if (!*aep) /* everything moved */ 1171 xhv->xhv_fill--; /* HvFILL(hv)-- */ 1172 /* I think we don't actually need to keep track of the longest length, 1173 merely flag if anything is too long. But for the moment while 1174 developing this code I'll track it. */ 1175 if (left_length > longest_chain) 1176 longest_chain = left_length; 1177 if (right_length > longest_chain) 1178 longest_chain = right_length; 1179 } 1180 1181 1182 /* Pick your policy for "hashing isn't working" here: */ 1183 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */ 1184 || HvREHASH(hv)) { 1185 return; 1186 } 1187 1188 if (hv == PL_strtab) { 1189 /* Urg. Someone is doing something nasty to the string table. 1190 Can't win. */ 1191 return; 1192 } 1193 1194 /* Awooga. Awooga. Pathological data. */ 1195 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv, 1196 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/ 1197 1198 ++newsize; 1199 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) 1200 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); 1201 if (SvOOK(hv)) { 1202 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); 1203 } 1204 1205 was_shared = HvSHAREKEYS(hv); 1206 1207 xhv->xhv_fill = 0; 1208 HvSHAREKEYS_off(hv); 1209 HvREHASH_on(hv); 1210 1211 aep = HvARRAY(hv); 1212 1213 for (i=0; i<newsize; i++,aep++) { 1214 register HE *entry = *aep; 1215 while (entry) { 1216 /* We're going to trash this HE's next pointer when we chain it 1217 into the new hash below, so store where we go next. */ 1218 HE * const next = HeNEXT(entry); 1219 UV hash; 1220 HE **bep; 1221 1222 /* Rehash it */ 1223 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry)); 1224 1225 if (was_shared) { 1226 /* Unshare it. */ 1227 HEK * const new_hek 1228 = save_hek_flags(HeKEY(entry), HeKLEN(entry), 1229 hash, HeKFLAGS(entry)); 1230 unshare_hek (HeKEY_hek(entry)); 1231 HeKEY_hek(entry) = new_hek; 1232 } else { 1233 /* Not shared, so simply write the new hash in. */ 1234 HeHASH(entry) = hash; 1235 } 1236 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/ 1237 HEK_REHASH_on(HeKEY_hek(entry)); 1238 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/ 1239 1240 /* Copy oentry to the correct new chain. */ 1241 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max); 1242 if (!*bep) 1243 xhv->xhv_fill++; /* HvFILL(hv)++ */ 1244 HeNEXT(entry) = *bep; 1245 *bep = entry; 1246 1247 entry = next; 1248 } 1249 } 1250 Safefree (HvARRAY(hv)); 1251 HvARRAY(hv) = (HE **)a; 1252 } 1253 1254 void 1255 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) 1256 { 1257 dVAR; 1258 register XPVHV* xhv = (XPVHV*)SvANY(hv); 1259 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ 1260 register I32 newsize; 1261 register I32 i; 1262 register char *a; 1263 register HE **aep; 1264 register HE *entry; 1265 register HE **oentry; 1266 1267 PERL_ARGS_ASSERT_HV_KSPLIT; 1268 1269 newsize = (I32) newmax; /* possible truncation here */ 1270 if (newsize != newmax || newmax <= oldsize) 1271 return; 1272 while ((newsize & (1 + ~newsize)) != newsize) { 1273 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */ 1274 } 1275 if (newsize < newmax) 1276 newsize *= 2; 1277 if (newsize < newmax) 1278 return; /* overflow detection */ 1279 1280 a = (char *) HvARRAY(hv); 1281 if (a) { 1282 PL_nomemok = TRUE; 1283 #if defined(STRANGE_MALLOC) || defined(MYMALLOC) 1284 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) 1285 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); 1286 if (!a) { 1287 PL_nomemok = FALSE; 1288 return; 1289 } 1290 if (SvOOK(hv)) { 1291 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); 1292 } 1293 #else 1294 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize) 1295 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char); 1296 if (!a) { 1297 PL_nomemok = FALSE; 1298 return; 1299 } 1300 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char); 1301 if (SvOOK(hv)) { 1302 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux); 1303 } 1304 if (oldsize >= 64) { 1305 offer_nice_chunk(HvARRAY(hv), 1306 PERL_HV_ARRAY_ALLOC_BYTES(oldsize) 1307 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0)); 1308 } 1309 else 1310 Safefree(HvARRAY(hv)); 1311 #endif 1312 PL_nomemok = FALSE; 1313 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ 1314 } 1315 else { 1316 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); 1317 } 1318 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ 1319 HvARRAY(hv) = (HE **) a; 1320 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */ 1321 return; 1322 1323 aep = (HE**)a; 1324 for (i=0; i<oldsize; i++,aep++) { 1325 if (!*aep) /* non-existent */ 1326 continue; 1327 for (oentry = aep, entry = *aep; entry; entry = *oentry) { 1328 register I32 j = (HeHASH(entry) & newsize); 1329 1330 if (j != i) { 1331 j -= i; 1332 *oentry = HeNEXT(entry); 1333 if (!(HeNEXT(entry) = aep[j])) 1334 xhv->xhv_fill++; /* HvFILL(hv)++ */ 1335 aep[j] = entry; 1336 continue; 1337 } 1338 else 1339 oentry = &HeNEXT(entry); 1340 } 1341 if (!*aep) /* everything moved */ 1342 xhv->xhv_fill--; /* HvFILL(hv)-- */ 1343 } 1344 } 1345 1346 HV * 1347 Perl_newHVhv(pTHX_ HV *ohv) 1348 { 1349 HV * const hv = newHV(); 1350 STRLEN hv_max, hv_fill; 1351 1352 if (!ohv || (hv_fill = HvFILL(ohv)) == 0) 1353 return hv; 1354 hv_max = HvMAX(ohv); 1355 1356 if (!SvMAGICAL((const SV *)ohv)) { 1357 /* It's an ordinary hash, so copy it fast. AMS 20010804 */ 1358 STRLEN i; 1359 const bool shared = !!HvSHAREKEYS(ohv); 1360 HE **ents, ** const oents = (HE **)HvARRAY(ohv); 1361 char *a; 1362 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); 1363 ents = (HE**)a; 1364 1365 /* In each bucket... */ 1366 for (i = 0; i <= hv_max; i++) { 1367 HE *prev = NULL; 1368 HE *oent = oents[i]; 1369 1370 if (!oent) { 1371 ents[i] = NULL; 1372 continue; 1373 } 1374 1375 /* Copy the linked list of entries. */ 1376 for (; oent; oent = HeNEXT(oent)) { 1377 const U32 hash = HeHASH(oent); 1378 const char * const key = HeKEY(oent); 1379 const STRLEN len = HeKLEN(oent); 1380 const int flags = HeKFLAGS(oent); 1381 HE * const ent = new_HE(); 1382 1383 HeVAL(ent) = newSVsv(HeVAL(oent)); 1384 HeKEY_hek(ent) 1385 = shared ? share_hek_flags(key, len, hash, flags) 1386 : save_hek_flags(key, len, hash, flags); 1387 if (prev) 1388 HeNEXT(prev) = ent; 1389 else 1390 ents[i] = ent; 1391 prev = ent; 1392 HeNEXT(ent) = NULL; 1393 } 1394 } 1395 1396 HvMAX(hv) = hv_max; 1397 HvFILL(hv) = hv_fill; 1398 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); 1399 HvARRAY(hv) = ents; 1400 } /* not magical */ 1401 else { 1402 /* Iterate over ohv, copying keys and values one at a time. */ 1403 HE *entry; 1404 const I32 riter = HvRITER_get(ohv); 1405 HE * const eiter = HvEITER_get(ohv); 1406 1407 /* Can we use fewer buckets? (hv_max is always 2^n-1) */ 1408 while (hv_max && hv_max + 1 >= hv_fill * 2) 1409 hv_max = hv_max / 2; 1410 HvMAX(hv) = hv_max; 1411 1412 hv_iterinit(ohv); 1413 while ((entry = hv_iternext_flags(ohv, 0))) { 1414 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), 1415 newSVsv(HeVAL(entry)), HeHASH(entry), 1416 HeKFLAGS(entry)); 1417 } 1418 HvRITER_set(ohv, riter); 1419 HvEITER_set(ohv, eiter); 1420 } 1421 1422 return hv; 1423 } 1424 1425 /* A rather specialised version of newHVhv for copying %^H, ensuring all the 1426 magic stays on it. */ 1427 HV * 1428 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) 1429 { 1430 HV * const hv = newHV(); 1431 STRLEN hv_fill; 1432 1433 if (ohv && (hv_fill = HvFILL(ohv))) { 1434 STRLEN hv_max = HvMAX(ohv); 1435 HE *entry; 1436 const I32 riter = HvRITER_get(ohv); 1437 HE * const eiter = HvEITER_get(ohv); 1438 1439 while (hv_max && hv_max + 1 >= hv_fill * 2) 1440 hv_max = hv_max / 2; 1441 HvMAX(hv) = hv_max; 1442 1443 hv_iterinit(ohv); 1444 while ((entry = hv_iternext_flags(ohv, 0))) { 1445 SV *const sv = newSVsv(HeVAL(entry)); 1446 SV *heksv = newSVhek(HeKEY_hek(entry)); 1447 sv_magic(sv, NULL, PERL_MAGIC_hintselem, 1448 (char *)heksv, HEf_SVKEY); 1449 SvREFCNT_dec(heksv); 1450 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), 1451 sv, HeHASH(entry), HeKFLAGS(entry)); 1452 } 1453 HvRITER_set(ohv, riter); 1454 HvEITER_set(ohv, eiter); 1455 } 1456 hv_magic(hv, NULL, PERL_MAGIC_hints); 1457 return hv; 1458 } 1459 1460 void 1461 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) 1462 { 1463 dVAR; 1464 SV *val; 1465 1466 PERL_ARGS_ASSERT_HV_FREE_ENT; 1467 1468 if (!entry) 1469 return; 1470 val = HeVAL(entry); 1471 if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv)) 1472 mro_method_changed_in(hv); /* deletion of method from stash */ 1473 SvREFCNT_dec(val); 1474 if (HeKLEN(entry) == HEf_SVKEY) { 1475 SvREFCNT_dec(HeKEY_sv(entry)); 1476 Safefree(HeKEY_hek(entry)); 1477 } 1478 else if (HvSHAREKEYS(hv)) 1479 unshare_hek(HeKEY_hek(entry)); 1480 else 1481 Safefree(HeKEY_hek(entry)); 1482 del_HE(entry); 1483 } 1484 1485 void 1486 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) 1487 { 1488 dVAR; 1489 1490 PERL_ARGS_ASSERT_HV_DELAYFREE_ENT; 1491 1492 if (!entry) 1493 return; 1494 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */ 1495 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */ 1496 if (HeKLEN(entry) == HEf_SVKEY) { 1497 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry))); 1498 } 1499 hv_free_ent(hv, entry); 1500 } 1501 1502 /* 1503 =for apidoc hv_clear 1504 1505 Clears a hash, making it empty. 1506 1507 =cut 1508 */ 1509 1510 void 1511 Perl_hv_clear(pTHX_ HV *hv) 1512 { 1513 dVAR; 1514 register XPVHV* xhv; 1515 if (!hv) 1516 return; 1517 1518 DEBUG_A(Perl_hv_assert(aTHX_ hv)); 1519 1520 xhv = (XPVHV*)SvANY(hv); 1521 1522 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) { 1523 /* restricted hash: convert all keys to placeholders */ 1524 STRLEN i; 1525 for (i = 0; i <= xhv->xhv_max; i++) { 1526 HE *entry = (HvARRAY(hv))[i]; 1527 for (; entry; entry = HeNEXT(entry)) { 1528 /* not already placeholder */ 1529 if (HeVAL(entry) != &PL_sv_placeholder) { 1530 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) { 1531 SV* const keysv = hv_iterkeysv(entry); 1532 Perl_croak(aTHX_ 1533 "Attempt to delete readonly key '%"SVf"' from a restricted hash", 1534 (void*)keysv); 1535 } 1536 SvREFCNT_dec(HeVAL(entry)); 1537 HeVAL(entry) = &PL_sv_placeholder; 1538 HvPLACEHOLDERS(hv)++; 1539 } 1540 } 1541 } 1542 goto reset; 1543 } 1544 1545 hfreeentries(hv); 1546 HvPLACEHOLDERS_set(hv, 0); 1547 if (HvARRAY(hv)) 1548 Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*); 1549 1550 if (SvRMAGICAL(hv)) 1551 mg_clear(MUTABLE_SV(hv)); 1552 1553 HvHASKFLAGS_off(hv); 1554 HvREHASH_off(hv); 1555 reset: 1556 if (SvOOK(hv)) { 1557 if(HvNAME_get(hv)) 1558 mro_isa_changed_in(hv); 1559 HvEITER_set(hv, NULL); 1560 } 1561 } 1562 1563 /* 1564 =for apidoc hv_clear_placeholders 1565 1566 Clears any placeholders from a hash. If a restricted hash has any of its keys 1567 marked as readonly and the key is subsequently deleted, the key is not actually 1568 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags 1569 it so it will be ignored by future operations such as iterating over the hash, 1570 but will still allow the hash to have a value reassigned to the key at some 1571 future point. This function clears any such placeholder keys from the hash. 1572 See Hash::Util::lock_keys() for an example of its use. 1573 1574 =cut 1575 */ 1576 1577 void 1578 Perl_hv_clear_placeholders(pTHX_ HV *hv) 1579 { 1580 dVAR; 1581 const U32 items = (U32)HvPLACEHOLDERS_get(hv); 1582 1583 PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS; 1584 1585 if (items) 1586 clear_placeholders(hv, items); 1587 } 1588 1589 static void 1590 S_clear_placeholders(pTHX_ HV *hv, U32 items) 1591 { 1592 dVAR; 1593 I32 i; 1594 1595 PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS; 1596 1597 if (items == 0) 1598 return; 1599 1600 i = HvMAX(hv); 1601 do { 1602 /* Loop down the linked list heads */ 1603 bool first = TRUE; 1604 HE **oentry = &(HvARRAY(hv))[i]; 1605 HE *entry; 1606 1607 while ((entry = *oentry)) { 1608 if (HeVAL(entry) == &PL_sv_placeholder) { 1609 *oentry = HeNEXT(entry); 1610 if (first && !*oentry) 1611 HvFILL(hv)--; /* This linked list is now empty. */ 1612 if (entry == HvEITER_get(hv)) 1613 HvLAZYDEL_on(hv); 1614 else 1615 hv_free_ent(hv, entry); 1616 1617 if (--items == 0) { 1618 /* Finished. */ 1619 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv); 1620 if (HvKEYS(hv) == 0) 1621 HvHASKFLAGS_off(hv); 1622 HvPLACEHOLDERS_set(hv, 0); 1623 return; 1624 } 1625 } else { 1626 oentry = &HeNEXT(entry); 1627 first = FALSE; 1628 } 1629 } 1630 } while (--i >= 0); 1631 /* You can't get here, hence assertion should always fail. */ 1632 assert (items == 0); 1633 assert (0); 1634 } 1635 1636 STATIC void 1637 S_hfreeentries(pTHX_ HV *hv) 1638 { 1639 /* This is the array that we're going to restore */ 1640 HE **const orig_array = HvARRAY(hv); 1641 HEK *name; 1642 int attempts = 100; 1643 1644 PERL_ARGS_ASSERT_HFREEENTRIES; 1645 1646 if (!orig_array) 1647 return; 1648 1649 if (SvOOK(hv)) { 1650 /* If the hash is actually a symbol table with a name, look after the 1651 name. */ 1652 struct xpvhv_aux *iter = HvAUX(hv); 1653 1654 name = iter->xhv_name; 1655 iter->xhv_name = NULL; 1656 } else { 1657 name = NULL; 1658 } 1659 1660 /* orig_array remains unchanged throughout the loop. If after freeing all 1661 the entries it turns out that one of the little blighters has triggered 1662 an action that has caused HvARRAY to be re-allocated, then we set 1663 array to the new HvARRAY, and try again. */ 1664 1665 while (1) { 1666 /* This is the one we're going to try to empty. First time round 1667 it's the original array. (Hopefully there will only be 1 time 1668 round) */ 1669 HE ** const array = HvARRAY(hv); 1670 I32 i = HvMAX(hv); 1671 1672 /* Because we have taken xhv_name out, the only allocated pointer 1673 in the aux structure that might exist is the backreference array. 1674 */ 1675 1676 if (SvOOK(hv)) { 1677 HE *entry; 1678 struct mro_meta *meta; 1679 struct xpvhv_aux *iter = HvAUX(hv); 1680 /* If there are weak references to this HV, we need to avoid 1681 freeing them up here. In particular we need to keep the AV 1682 visible as what we're deleting might well have weak references 1683 back to this HV, so the for loop below may well trigger 1684 the removal of backreferences from this array. */ 1685 1686 if (iter->xhv_backreferences) { 1687 /* So donate them to regular backref magic to keep them safe. 1688 The sv_magic will increase the reference count of the AV, 1689 so we need to drop it first. */ 1690 SvREFCNT_dec(iter->xhv_backreferences); 1691 if (AvFILLp(iter->xhv_backreferences) == -1) { 1692 /* Turns out that the array is empty. Just free it. */ 1693 SvREFCNT_dec(iter->xhv_backreferences); 1694 1695 } else { 1696 sv_magic(MUTABLE_SV(hv), 1697 MUTABLE_SV(iter->xhv_backreferences), 1698 PERL_MAGIC_backref, NULL, 0); 1699 } 1700 iter->xhv_backreferences = NULL; 1701 } 1702 1703 entry = iter->xhv_eiter; /* HvEITER(hv) */ 1704 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ 1705 HvLAZYDEL_off(hv); 1706 hv_free_ent(hv, entry); 1707 } 1708 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ 1709 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 1710 1711 if((meta = iter->xhv_mro_meta)) { 1712 if (meta->mro_linear_dfs) { 1713 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs)); 1714 meta->mro_linear_dfs = NULL; 1715 /* This is just acting as a shortcut pointer. */ 1716 meta->mro_linear_c3 = NULL; 1717 } else if (meta->mro_linear_c3) { 1718 /* Only the current MRO is stored, so this owns the data. 1719 */ 1720 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3)); 1721 meta->mro_linear_c3 = NULL; 1722 } 1723 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod); 1724 SvREFCNT_dec(meta->isa); 1725 Safefree(meta); 1726 iter->xhv_mro_meta = NULL; 1727 } 1728 1729 /* There are now no allocated pointers in the aux structure. */ 1730 1731 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */ 1732 /* What aux structure? */ 1733 } 1734 1735 /* make everyone else think the array is empty, so that the destructors 1736 * called for freed entries can't recusively mess with us */ 1737 HvARRAY(hv) = NULL; 1738 HvFILL(hv) = 0; 1739 ((XPVHV*) SvANY(hv))->xhv_keys = 0; 1740 1741 1742 do { 1743 /* Loop down the linked list heads */ 1744 HE *entry = array[i]; 1745 1746 while (entry) { 1747 register HE * const oentry = entry; 1748 entry = HeNEXT(entry); 1749 hv_free_ent(hv, oentry); 1750 } 1751 } while (--i >= 0); 1752 1753 /* As there are no allocated pointers in the aux structure, it's now 1754 safe to free the array we just cleaned up, if it's not the one we're 1755 going to put back. */ 1756 if (array != orig_array) { 1757 Safefree(array); 1758 } 1759 1760 if (!HvARRAY(hv)) { 1761 /* Good. No-one added anything this time round. */ 1762 break; 1763 } 1764 1765 if (SvOOK(hv)) { 1766 /* Someone attempted to iterate or set the hash name while we had 1767 the array set to 0. We'll catch backferences on the next time 1768 round the while loop. */ 1769 assert(HvARRAY(hv)); 1770 1771 if (HvAUX(hv)->xhv_name) { 1772 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0); 1773 } 1774 } 1775 1776 if (--attempts == 0) { 1777 Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries"); 1778 } 1779 } 1780 1781 HvARRAY(hv) = orig_array; 1782 1783 /* If the hash was actually a symbol table, put the name back. */ 1784 if (name) { 1785 /* We have restored the original array. If name is non-NULL, then 1786 the original array had an aux structure at the end. So this is 1787 valid: */ 1788 SvFLAGS(hv) |= SVf_OOK; 1789 HvAUX(hv)->xhv_name = name; 1790 } 1791 } 1792 1793 /* 1794 =for apidoc hv_undef 1795 1796 Undefines the hash. 1797 1798 =cut 1799 */ 1800 1801 void 1802 Perl_hv_undef(pTHX_ HV *hv) 1803 { 1804 dVAR; 1805 register XPVHV* xhv; 1806 const char *name; 1807 1808 if (!hv) 1809 return; 1810 DEBUG_A(Perl_hv_assert(aTHX_ hv)); 1811 xhv = (XPVHV*)SvANY(hv); 1812 1813 if ((name = HvNAME_get(hv)) && !PL_dirty) 1814 mro_isa_changed_in(hv); 1815 1816 hfreeentries(hv); 1817 if (name) { 1818 if (PL_stashcache) 1819 (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); 1820 hv_name_set(hv, NULL, 0, 0); 1821 } 1822 SvFLAGS(hv) &= ~SVf_OOK; 1823 Safefree(HvARRAY(hv)); 1824 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */ 1825 HvARRAY(hv) = 0; 1826 HvPLACEHOLDERS_set(hv, 0); 1827 1828 if (SvRMAGICAL(hv)) 1829 mg_clear(MUTABLE_SV(hv)); 1830 } 1831 1832 static struct xpvhv_aux* 1833 S_hv_auxinit(HV *hv) { 1834 struct xpvhv_aux *iter; 1835 char *array; 1836 1837 PERL_ARGS_ASSERT_HV_AUXINIT; 1838 1839 if (!HvARRAY(hv)) { 1840 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) 1841 + sizeof(struct xpvhv_aux), char); 1842 } else { 1843 array = (char *) HvARRAY(hv); 1844 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) 1845 + sizeof(struct xpvhv_aux), char); 1846 } 1847 HvARRAY(hv) = (HE**) array; 1848 /* SvOOK_on(hv) attacks the IV flags. */ 1849 SvFLAGS(hv) |= SVf_OOK; 1850 iter = HvAUX(hv); 1851 1852 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ 1853 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 1854 iter->xhv_name = 0; 1855 iter->xhv_backreferences = 0; 1856 iter->xhv_mro_meta = NULL; 1857 return iter; 1858 } 1859 1860 /* 1861 =for apidoc hv_iterinit 1862 1863 Prepares a starting point to traverse a hash table. Returns the number of 1864 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is 1865 currently only meaningful for hashes without tie magic. 1866 1867 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of 1868 hash buckets that happen to be in use. If you still need that esoteric 1869 value, you can get it through the macro C<HvFILL(tb)>. 1870 1871 1872 =cut 1873 */ 1874 1875 I32 1876 Perl_hv_iterinit(pTHX_ HV *hv) 1877 { 1878 PERL_ARGS_ASSERT_HV_ITERINIT; 1879 1880 /* FIXME: Are we not NULL, or do we croak? Place bets now! */ 1881 1882 if (!hv) 1883 Perl_croak(aTHX_ "Bad hash"); 1884 1885 if (SvOOK(hv)) { 1886 struct xpvhv_aux * const iter = HvAUX(hv); 1887 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */ 1888 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ 1889 HvLAZYDEL_off(hv); 1890 hv_free_ent(hv, entry); 1891 } 1892 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ 1893 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 1894 } else { 1895 hv_auxinit(hv); 1896 } 1897 1898 /* used to be xhv->xhv_fill before 5.004_65 */ 1899 return HvTOTALKEYS(hv); 1900 } 1901 1902 I32 * 1903 Perl_hv_riter_p(pTHX_ HV *hv) { 1904 struct xpvhv_aux *iter; 1905 1906 PERL_ARGS_ASSERT_HV_RITER_P; 1907 1908 if (!hv) 1909 Perl_croak(aTHX_ "Bad hash"); 1910 1911 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); 1912 return &(iter->xhv_riter); 1913 } 1914 1915 HE ** 1916 Perl_hv_eiter_p(pTHX_ HV *hv) { 1917 struct xpvhv_aux *iter; 1918 1919 PERL_ARGS_ASSERT_HV_EITER_P; 1920 1921 if (!hv) 1922 Perl_croak(aTHX_ "Bad hash"); 1923 1924 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); 1925 return &(iter->xhv_eiter); 1926 } 1927 1928 void 1929 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { 1930 struct xpvhv_aux *iter; 1931 1932 PERL_ARGS_ASSERT_HV_RITER_SET; 1933 1934 if (!hv) 1935 Perl_croak(aTHX_ "Bad hash"); 1936 1937 if (SvOOK(hv)) { 1938 iter = HvAUX(hv); 1939 } else { 1940 if (riter == -1) 1941 return; 1942 1943 iter = hv_auxinit(hv); 1944 } 1945 iter->xhv_riter = riter; 1946 } 1947 1948 void 1949 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { 1950 struct xpvhv_aux *iter; 1951 1952 PERL_ARGS_ASSERT_HV_EITER_SET; 1953 1954 if (!hv) 1955 Perl_croak(aTHX_ "Bad hash"); 1956 1957 if (SvOOK(hv)) { 1958 iter = HvAUX(hv); 1959 } else { 1960 /* 0 is the default so don't go malloc()ing a new structure just to 1961 hold 0. */ 1962 if (!eiter) 1963 return; 1964 1965 iter = hv_auxinit(hv); 1966 } 1967 iter->xhv_eiter = eiter; 1968 } 1969 1970 void 1971 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) 1972 { 1973 dVAR; 1974 struct xpvhv_aux *iter; 1975 U32 hash; 1976 1977 PERL_ARGS_ASSERT_HV_NAME_SET; 1978 PERL_UNUSED_ARG(flags); 1979 1980 if (len > I32_MAX) 1981 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); 1982 1983 if (SvOOK(hv)) { 1984 iter = HvAUX(hv); 1985 if (iter->xhv_name) { 1986 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0); 1987 } 1988 } else { 1989 if (name == 0) 1990 return; 1991 1992 iter = hv_auxinit(hv); 1993 } 1994 PERL_HASH(hash, name, len); 1995 iter->xhv_name = name ? share_hek(name, len, hash) : NULL; 1996 } 1997 1998 AV ** 1999 Perl_hv_backreferences_p(pTHX_ HV *hv) { 2000 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); 2001 2002 PERL_ARGS_ASSERT_HV_BACKREFERENCES_P; 2003 PERL_UNUSED_CONTEXT; 2004 2005 return &(iter->xhv_backreferences); 2006 } 2007 2008 void 2009 Perl_hv_kill_backrefs(pTHX_ HV *hv) { 2010 AV *av; 2011 2012 PERL_ARGS_ASSERT_HV_KILL_BACKREFS; 2013 2014 if (!SvOOK(hv)) 2015 return; 2016 2017 av = HvAUX(hv)->xhv_backreferences; 2018 2019 if (av) { 2020 HvAUX(hv)->xhv_backreferences = 0; 2021 Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av); 2022 SvREFCNT_dec(av); 2023 } 2024 } 2025 2026 /* 2027 hv_iternext is implemented as a macro in hv.h 2028 2029 =for apidoc hv_iternext 2030 2031 Returns entries from a hash iterator. See C<hv_iterinit>. 2032 2033 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the 2034 iterator currently points to, without losing your place or invalidating your 2035 iterator. Note that in this case the current entry is deleted from the hash 2036 with your iterator holding the last reference to it. Your iterator is flagged 2037 to free the entry on the next call to C<hv_iternext>, so you must not discard 2038 your iterator immediately else the entry will leak - call C<hv_iternext> to 2039 trigger the resource deallocation. 2040 2041 =for apidoc hv_iternext_flags 2042 2043 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>. 2044 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is 2045 set the placeholders keys (for restricted hashes) will be returned in addition 2046 to normal keys. By default placeholders are automatically skipped over. 2047 Currently a placeholder is implemented with a value that is 2048 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and 2049 restricted hashes may change, and the implementation currently is 2050 insufficiently abstracted for any change to be tidy. 2051 2052 =cut 2053 */ 2054 2055 HE * 2056 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) 2057 { 2058 dVAR; 2059 register XPVHV* xhv; 2060 register HE *entry; 2061 HE *oldentry; 2062 MAGIC* mg; 2063 struct xpvhv_aux *iter; 2064 2065 PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS; 2066 2067 if (!hv) 2068 Perl_croak(aTHX_ "Bad hash"); 2069 2070 xhv = (XPVHV*)SvANY(hv); 2071 2072 if (!SvOOK(hv)) { 2073 /* Too many things (well, pp_each at least) merrily assume that you can 2074 call iv_iternext without calling hv_iterinit, so we'll have to deal 2075 with it. */ 2076 hv_iterinit(hv); 2077 } 2078 iter = HvAUX(hv); 2079 2080 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ 2081 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) { 2082 if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) { 2083 SV * const key = sv_newmortal(); 2084 if (entry) { 2085 sv_setsv(key, HeSVKEY_force(entry)); 2086 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ 2087 } 2088 else { 2089 char *k; 2090 HEK *hek; 2091 2092 /* one HE per MAGICAL hash */ 2093 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ 2094 Zero(entry, 1, HE); 2095 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char); 2096 hek = (HEK*)k; 2097 HeKEY_hek(entry) = hek; 2098 HeKLEN(entry) = HEf_SVKEY; 2099 } 2100 magic_nextpack(MUTABLE_SV(hv),mg,key); 2101 if (SvOK(key)) { 2102 /* force key to stay around until next time */ 2103 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); 2104 return entry; /* beware, hent_val is not set */ 2105 } 2106 if (HeVAL(entry)) 2107 SvREFCNT_dec(HeVAL(entry)); 2108 Safefree(HeKEY_hek(entry)); 2109 del_HE(entry); 2110 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 2111 return NULL; 2112 } 2113 } 2114 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */ 2115 if (!entry && SvRMAGICAL((const SV *)hv) 2116 && mg_find((const SV *)hv, PERL_MAGIC_env)) { 2117 prime_env_iter(); 2118 #ifdef VMS 2119 /* The prime_env_iter() on VMS just loaded up new hash values 2120 * so the iteration count needs to be reset back to the beginning 2121 */ 2122 hv_iterinit(hv); 2123 iter = HvAUX(hv); 2124 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ 2125 #endif 2126 } 2127 #endif 2128 2129 /* hv_iterint now ensures this. */ 2130 assert (HvARRAY(hv)); 2131 2132 /* At start of hash, entry is NULL. */ 2133 if (entry) 2134 { 2135 entry = HeNEXT(entry); 2136 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { 2137 /* 2138 * Skip past any placeholders -- don't want to include them in 2139 * any iteration. 2140 */ 2141 while (entry && HeVAL(entry) == &PL_sv_placeholder) { 2142 entry = HeNEXT(entry); 2143 } 2144 } 2145 } 2146 while (!entry) { 2147 /* OK. Come to the end of the current list. Grab the next one. */ 2148 2149 iter->xhv_riter++; /* HvRITER(hv)++ */ 2150 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { 2151 /* There is no next one. End of the hash. */ 2152 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ 2153 break; 2154 } 2155 entry = (HvARRAY(hv))[iter->xhv_riter]; 2156 2157 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { 2158 /* If we have an entry, but it's a placeholder, don't count it. 2159 Try the next. */ 2160 while (entry && HeVAL(entry) == &PL_sv_placeholder) 2161 entry = HeNEXT(entry); 2162 } 2163 /* Will loop again if this linked list starts NULL 2164 (for HV_ITERNEXT_WANTPLACEHOLDERS) 2165 or if we run through it and find only placeholders. */ 2166 } 2167 2168 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ 2169 HvLAZYDEL_off(hv); 2170 hv_free_ent(hv, oldentry); 2171 } 2172 2173 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry)) 2174 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/ 2175 2176 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */ 2177 return entry; 2178 } 2179 2180 /* 2181 =for apidoc hv_iterkey 2182 2183 Returns the key from the current position of the hash iterator. See 2184 C<hv_iterinit>. 2185 2186 =cut 2187 */ 2188 2189 char * 2190 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen) 2191 { 2192 PERL_ARGS_ASSERT_HV_ITERKEY; 2193 2194 if (HeKLEN(entry) == HEf_SVKEY) { 2195 STRLEN len; 2196 char * const p = SvPV(HeKEY_sv(entry), len); 2197 *retlen = len; 2198 return p; 2199 } 2200 else { 2201 *retlen = HeKLEN(entry); 2202 return HeKEY(entry); 2203 } 2204 } 2205 2206 /* unlike hv_iterval(), this always returns a mortal copy of the key */ 2207 /* 2208 =for apidoc hv_iterkeysv 2209 2210 Returns the key as an C<SV*> from the current position of the hash 2211 iterator. The return value will always be a mortal copy of the key. Also 2212 see C<hv_iterinit>. 2213 2214 =cut 2215 */ 2216 2217 SV * 2218 Perl_hv_iterkeysv(pTHX_ register HE *entry) 2219 { 2220 PERL_ARGS_ASSERT_HV_ITERKEYSV; 2221 2222 return sv_2mortal(newSVhek(HeKEY_hek(entry))); 2223 } 2224 2225 /* 2226 =for apidoc hv_iterval 2227 2228 Returns the value from the current position of the hash iterator. See 2229 C<hv_iterkey>. 2230 2231 =cut 2232 */ 2233 2234 SV * 2235 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry) 2236 { 2237 PERL_ARGS_ASSERT_HV_ITERVAL; 2238 2239 if (SvRMAGICAL(hv)) { 2240 if (mg_find((const SV *)hv, PERL_MAGIC_tied)) { 2241 SV* const sv = sv_newmortal(); 2242 if (HeKLEN(entry) == HEf_SVKEY) 2243 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY); 2244 else 2245 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry)); 2246 return sv; 2247 } 2248 } 2249 return HeVAL(entry); 2250 } 2251 2252 /* 2253 =for apidoc hv_iternextsv 2254 2255 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one 2256 operation. 2257 2258 =cut 2259 */ 2260 2261 SV * 2262 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) 2263 { 2264 HE * const he = hv_iternext_flags(hv, 0); 2265 2266 PERL_ARGS_ASSERT_HV_ITERNEXTSV; 2267 2268 if (!he) 2269 return NULL; 2270 *key = hv_iterkey(he, retlen); 2271 return hv_iterval(hv, he); 2272 } 2273 2274 /* 2275 2276 Now a macro in hv.h 2277 2278 =for apidoc hv_magic 2279 2280 Adds magic to a hash. See C<sv_magic>. 2281 2282 =cut 2283 */ 2284 2285 /* possibly free a shared string if no one has access to it 2286 * len and hash must both be valid for str. 2287 */ 2288 void 2289 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) 2290 { 2291 unshare_hek_or_pvn (NULL, str, len, hash); 2292 } 2293 2294 2295 void 2296 Perl_unshare_hek(pTHX_ HEK *hek) 2297 { 2298 assert(hek); 2299 unshare_hek_or_pvn(hek, NULL, 0, 0); 2300 } 2301 2302 /* possibly free a shared string if no one has access to it 2303 hek if non-NULL takes priority over the other 3, else str, len and hash 2304 are used. If so, len and hash must both be valid for str. 2305 */ 2306 STATIC void 2307 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) 2308 { 2309 dVAR; 2310 register XPVHV* xhv; 2311 HE *entry; 2312 register HE **oentry; 2313 HE **first; 2314 bool is_utf8 = FALSE; 2315 int k_flags = 0; 2316 const char * const save = str; 2317 struct shared_he *he = NULL; 2318 2319 if (hek) { 2320 /* Find the shared he which is just before us in memory. */ 2321 he = (struct shared_he *)(((char *)hek) 2322 - STRUCT_OFFSET(struct shared_he, 2323 shared_he_hek)); 2324 2325 /* Assert that the caller passed us a genuine (or at least consistent) 2326 shared hek */ 2327 assert (he->shared_he_he.hent_hek == hek); 2328 2329 LOCK_STRTAB_MUTEX; 2330 if (he->shared_he_he.he_valu.hent_refcount - 1) { 2331 --he->shared_he_he.he_valu.hent_refcount; 2332 UNLOCK_STRTAB_MUTEX; 2333 return; 2334 } 2335 UNLOCK_STRTAB_MUTEX; 2336 2337 hash = HEK_HASH(hek); 2338 } else if (len < 0) { 2339 STRLEN tmplen = -len; 2340 is_utf8 = TRUE; 2341 /* See the note in hv_fetch(). --jhi */ 2342 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); 2343 len = tmplen; 2344 if (is_utf8) 2345 k_flags = HVhek_UTF8; 2346 if (str != save) 2347 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 2348 } 2349 2350 /* what follows was the moral equivalent of: 2351 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { 2352 if (--*Svp == NULL) 2353 hv_delete(PL_strtab, str, len, G_DISCARD, hash); 2354 } */ 2355 xhv = (XPVHV*)SvANY(PL_strtab); 2356 /* assert(xhv_array != 0) */ 2357 LOCK_STRTAB_MUTEX; 2358 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; 2359 if (he) { 2360 const HE *const he_he = &(he->shared_he_he); 2361 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { 2362 if (entry == he_he) 2363 break; 2364 } 2365 } else { 2366 const int flags_masked = k_flags & HVhek_MASK; 2367 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { 2368 if (HeHASH(entry) != hash) /* strings can't be equal */ 2369 continue; 2370 if (HeKLEN(entry) != len) 2371 continue; 2372 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ 2373 continue; 2374 if (HeKFLAGS(entry) != flags_masked) 2375 continue; 2376 break; 2377 } 2378 } 2379 2380 if (entry) { 2381 if (--entry->he_valu.hent_refcount == 0) { 2382 *oentry = HeNEXT(entry); 2383 if (!*first) { 2384 /* There are now no entries in our slot. */ 2385 xhv->xhv_fill--; /* HvFILL(hv)-- */ 2386 } 2387 Safefree(entry); 2388 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ 2389 } 2390 } 2391 2392 UNLOCK_STRTAB_MUTEX; 2393 if (!entry && ckWARN_d(WARN_INTERNAL)) 2394 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 2395 "Attempt to free non-existent shared string '%s'%s" 2396 pTHX__FORMAT, 2397 hek ? HEK_KEY(hek) : str, 2398 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); 2399 if (k_flags & HVhek_FREEKEY) 2400 Safefree(str); 2401 } 2402 2403 /* get a (constant) string ptr from the global string table 2404 * string will get added if it is not already there. 2405 * len and hash must both be valid for str. 2406 */ 2407 HEK * 2408 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) 2409 { 2410 bool is_utf8 = FALSE; 2411 int flags = 0; 2412 const char * const save = str; 2413 2414 PERL_ARGS_ASSERT_SHARE_HEK; 2415 2416 if (len < 0) { 2417 STRLEN tmplen = -len; 2418 is_utf8 = TRUE; 2419 /* See the note in hv_fetch(). --jhi */ 2420 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); 2421 len = tmplen; 2422 /* If we were able to downgrade here, then than means that we were passed 2423 in a key which only had chars 0-255, but was utf8 encoded. */ 2424 if (is_utf8) 2425 flags = HVhek_UTF8; 2426 /* If we found we were able to downgrade the string to bytes, then 2427 we should flag that it needs upgrading on keys or each. Also flag 2428 that we need share_hek_flags to free the string. */ 2429 if (str != save) 2430 flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 2431 } 2432 2433 return share_hek_flags (str, len, hash, flags); 2434 } 2435 2436 STATIC HEK * 2437 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) 2438 { 2439 dVAR; 2440 register HE *entry; 2441 const int flags_masked = flags & HVhek_MASK; 2442 const U32 hindex = hash & (I32) HvMAX(PL_strtab); 2443 register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab); 2444 2445 PERL_ARGS_ASSERT_SHARE_HEK_FLAGS; 2446 2447 /* what follows is the moral equivalent of: 2448 2449 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) 2450 hv_store(PL_strtab, str, len, NULL, hash); 2451 2452 Can't rehash the shared string table, so not sure if it's worth 2453 counting the number of entries in the linked list 2454 */ 2455 2456 /* assert(xhv_array != 0) */ 2457 LOCK_STRTAB_MUTEX; 2458 entry = (HvARRAY(PL_strtab))[hindex]; 2459 for (;entry; entry = HeNEXT(entry)) { 2460 if (HeHASH(entry) != hash) /* strings can't be equal */ 2461 continue; 2462 if (HeKLEN(entry) != len) 2463 continue; 2464 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ 2465 continue; 2466 if (HeKFLAGS(entry) != flags_masked) 2467 continue; 2468 break; 2469 } 2470 2471 if (!entry) { 2472 /* What used to be head of the list. 2473 If this is NULL, then we're the first entry for this slot, which 2474 means we need to increate fill. */ 2475 struct shared_he *new_entry; 2476 HEK *hek; 2477 char *k; 2478 HE **const head = &HvARRAY(PL_strtab)[hindex]; 2479 HE *const next = *head; 2480 2481 /* We don't actually store a HE from the arena and a regular HEK. 2482 Instead we allocate one chunk of memory big enough for both, 2483 and put the HEK straight after the HE. This way we can find the 2484 HEK directly from the HE. 2485 */ 2486 2487 Newx(k, STRUCT_OFFSET(struct shared_he, 2488 shared_he_hek.hek_key[0]) + len + 2, char); 2489 new_entry = (struct shared_he *)k; 2490 entry = &(new_entry->shared_he_he); 2491 hek = &(new_entry->shared_he_hek); 2492 2493 Copy(str, HEK_KEY(hek), len, char); 2494 HEK_KEY(hek)[len] = 0; 2495 HEK_LEN(hek) = len; 2496 HEK_HASH(hek) = hash; 2497 HEK_FLAGS(hek) = (unsigned char)flags_masked; 2498 2499 /* Still "point" to the HEK, so that other code need not know what 2500 we're up to. */ 2501 HeKEY_hek(entry) = hek; 2502 entry->he_valu.hent_refcount = 0; 2503 HeNEXT(entry) = next; 2504 *head = entry; 2505 2506 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ 2507 if (!next) { /* initial entry? */ 2508 xhv->xhv_fill++; /* HvFILL(hv)++ */ 2509 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { 2510 hsplit(PL_strtab); 2511 } 2512 } 2513 2514 ++entry->he_valu.hent_refcount; 2515 UNLOCK_STRTAB_MUTEX; 2516 2517 if (flags & HVhek_FREEKEY) 2518 Safefree(str); 2519 2520 return HeKEY_hek(entry); 2521 } 2522 2523 I32 * 2524 Perl_hv_placeholders_p(pTHX_ HV *hv) 2525 { 2526 dVAR; 2527 MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); 2528 2529 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P; 2530 2531 if (!mg) { 2532 mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0); 2533 2534 if (!mg) { 2535 Perl_die(aTHX_ "panic: hv_placeholders_p"); 2536 } 2537 } 2538 return &(mg->mg_len); 2539 } 2540 2541 2542 I32 2543 Perl_hv_placeholders_get(pTHX_ HV *hv) 2544 { 2545 dVAR; 2546 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash); 2547 2548 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET; 2549 2550 return mg ? mg->mg_len : 0; 2551 } 2552 2553 void 2554 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) 2555 { 2556 dVAR; 2557 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); 2558 2559 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET; 2560 2561 if (mg) { 2562 mg->mg_len = ph; 2563 } else if (ph) { 2564 if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph)) 2565 Perl_die(aTHX_ "panic: hv_placeholders_set"); 2566 } 2567 /* else we don't need to add magic to record 0 placeholders. */ 2568 } 2569 2570 STATIC SV * 2571 S_refcounted_he_value(pTHX_ const struct refcounted_he *he) 2572 { 2573 dVAR; 2574 SV *value; 2575 2576 PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE; 2577 2578 switch(he->refcounted_he_data[0] & HVrhek_typemask) { 2579 case HVrhek_undef: 2580 value = newSV(0); 2581 break; 2582 case HVrhek_delete: 2583 value = &PL_sv_placeholder; 2584 break; 2585 case HVrhek_IV: 2586 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv); 2587 break; 2588 case HVrhek_UV: 2589 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv); 2590 break; 2591 case HVrhek_PV: 2592 case HVrhek_PV_UTF8: 2593 /* Create a string SV that directly points to the bytes in our 2594 structure. */ 2595 value = newSV_type(SVt_PV); 2596 SvPV_set(value, (char *) he->refcounted_he_data + 1); 2597 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len); 2598 /* This stops anything trying to free it */ 2599 SvLEN_set(value, 0); 2600 SvPOK_on(value); 2601 SvREADONLY_on(value); 2602 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8) 2603 SvUTF8_on(value); 2604 break; 2605 default: 2606 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x", 2607 he->refcounted_he_data[0]); 2608 } 2609 return value; 2610 } 2611 2612 /* 2613 =for apidoc refcounted_he_chain_2hv 2614 2615 Generates and returns a C<HV *> by walking up the tree starting at the passed 2616 in C<struct refcounted_he *>. 2617 2618 =cut 2619 */ 2620 HV * 2621 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) 2622 { 2623 dVAR; 2624 HV *hv = newHV(); 2625 U32 placeholders = 0; 2626 /* We could chase the chain once to get an idea of the number of keys, 2627 and call ksplit. But for now we'll make a potentially inefficient 2628 hash with only 8 entries in its array. */ 2629 const U32 max = HvMAX(hv); 2630 2631 if (!HvARRAY(hv)) { 2632 char *array; 2633 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); 2634 HvARRAY(hv) = (HE**)array; 2635 } 2636 2637 while (chain) { 2638 #ifdef USE_ITHREADS 2639 U32 hash = chain->refcounted_he_hash; 2640 #else 2641 U32 hash = HEK_HASH(chain->refcounted_he_hek); 2642 #endif 2643 HE **oentry = &((HvARRAY(hv))[hash & max]); 2644 HE *entry = *oentry; 2645 SV *value; 2646 2647 for (; entry; entry = HeNEXT(entry)) { 2648 if (HeHASH(entry) == hash) { 2649 /* We might have a duplicate key here. If so, entry is older 2650 than the key we've already put in the hash, so if they are 2651 the same, skip adding entry. */ 2652 #ifdef USE_ITHREADS 2653 const STRLEN klen = HeKLEN(entry); 2654 const char *const key = HeKEY(entry); 2655 if (klen == chain->refcounted_he_keylen 2656 && (!!HeKUTF8(entry) 2657 == !!(chain->refcounted_he_data[0] & HVhek_UTF8)) 2658 && memEQ(key, REF_HE_KEY(chain), klen)) 2659 goto next_please; 2660 #else 2661 if (HeKEY_hek(entry) == chain->refcounted_he_hek) 2662 goto next_please; 2663 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek) 2664 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek) 2665 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek), 2666 HeKLEN(entry))) 2667 goto next_please; 2668 #endif 2669 } 2670 } 2671 assert (!entry); 2672 entry = new_HE(); 2673 2674 #ifdef USE_ITHREADS 2675 HeKEY_hek(entry) 2676 = share_hek_flags(REF_HE_KEY(chain), 2677 chain->refcounted_he_keylen, 2678 chain->refcounted_he_hash, 2679 (chain->refcounted_he_data[0] 2680 & (HVhek_UTF8|HVhek_WASUTF8))); 2681 #else 2682 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); 2683 #endif 2684 value = refcounted_he_value(chain); 2685 if (value == &PL_sv_placeholder) 2686 placeholders++; 2687 HeVAL(entry) = value; 2688 2689 /* Link it into the chain. */ 2690 HeNEXT(entry) = *oentry; 2691 if (!HeNEXT(entry)) { 2692 /* initial entry. */ 2693 HvFILL(hv)++; 2694 } 2695 *oentry = entry; 2696 2697 HvTOTALKEYS(hv)++; 2698 2699 next_please: 2700 chain = chain->refcounted_he_next; 2701 } 2702 2703 if (placeholders) { 2704 clear_placeholders(hv, placeholders); 2705 HvTOTALKEYS(hv) -= placeholders; 2706 } 2707 2708 /* We could check in the loop to see if we encounter any keys with key 2709 flags, but it's probably not worth it, as this per-hash flag is only 2710 really meant as an optimisation for things like Storable. */ 2711 HvHASKFLAGS_on(hv); 2712 DEBUG_A(Perl_hv_assert(aTHX_ hv)); 2713 2714 return hv; 2715 } 2716 2717 SV * 2718 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, 2719 const char *key, STRLEN klen, int flags, U32 hash) 2720 { 2721 dVAR; 2722 /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness 2723 of your key has to exactly match that which is stored. */ 2724 SV *value = &PL_sv_placeholder; 2725 2726 if (chain) { 2727 /* No point in doing any of this if there's nothing to find. */ 2728 bool is_utf8; 2729 2730 if (keysv) { 2731 if (flags & HVhek_FREEKEY) 2732 Safefree(key); 2733 key = SvPV_const(keysv, klen); 2734 flags = 0; 2735 is_utf8 = (SvUTF8(keysv) != 0); 2736 } else { 2737 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); 2738 } 2739 2740 if (!hash) { 2741 if (keysv && (SvIsCOW_shared_hash(keysv))) { 2742 hash = SvSHARED_HASH(keysv); 2743 } else { 2744 PERL_HASH(hash, key, klen); 2745 } 2746 } 2747 2748 for (; chain; chain = chain->refcounted_he_next) { 2749 #ifdef USE_ITHREADS 2750 if (hash != chain->refcounted_he_hash) 2751 continue; 2752 if (klen != chain->refcounted_he_keylen) 2753 continue; 2754 if (memNE(REF_HE_KEY(chain),key,klen)) 2755 continue; 2756 if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8)) 2757 continue; 2758 #else 2759 if (hash != HEK_HASH(chain->refcounted_he_hek)) 2760 continue; 2761 if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek)) 2762 continue; 2763 if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen)) 2764 continue; 2765 if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek)) 2766 continue; 2767 #endif 2768 2769 value = sv_2mortal(refcounted_he_value(chain)); 2770 break; 2771 } 2772 } 2773 2774 if (flags & HVhek_FREEKEY) 2775 Safefree(key); 2776 2777 return value; 2778 } 2779 2780 /* 2781 =for apidoc refcounted_he_new 2782 2783 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is 2784 stored in a compact form, all references remain the property of the caller. 2785 The C<struct refcounted_he> is returned with a reference count of 1. 2786 2787 =cut 2788 */ 2789 2790 struct refcounted_he * 2791 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, 2792 SV *const key, SV *const value) { 2793 dVAR; 2794 struct refcounted_he *he; 2795 STRLEN key_len; 2796 const char *key_p = SvPV_const(key, key_len); 2797 STRLEN value_len = 0; 2798 const char *value_p = NULL; 2799 char value_type; 2800 char flags; 2801 STRLEN key_offset; 2802 U32 hash; 2803 bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; 2804 2805 if (SvPOK(value)) { 2806 value_type = HVrhek_PV; 2807 } else if (SvIOK(value)) { 2808 value_type = HVrhek_IV; 2809 } else if (value == &PL_sv_placeholder) { 2810 value_type = HVrhek_delete; 2811 } else if (!SvOK(value)) { 2812 value_type = HVrhek_undef; 2813 } else { 2814 value_type = HVrhek_PV; 2815 } 2816 2817 if (value_type == HVrhek_PV) { 2818 value_p = SvPV_const(value, value_len); 2819 key_offset = value_len + 2; 2820 } else { 2821 value_len = 0; 2822 key_offset = 1; 2823 } 2824 2825 #ifdef USE_ITHREADS 2826 he = (struct refcounted_he*) 2827 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 2828 + key_len 2829 + key_offset); 2830 #else 2831 he = (struct refcounted_he*) 2832 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 2833 + key_offset); 2834 #endif 2835 2836 2837 he->refcounted_he_next = parent; 2838 2839 if (value_type == HVrhek_PV) { 2840 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); 2841 he->refcounted_he_val.refcounted_he_u_len = value_len; 2842 /* Do it this way so that the SvUTF8() test is after the SvPV, in case 2843 the value is overloaded, and doesn't yet have the UTF-8flag set. */ 2844 if (SvUTF8(value)) 2845 value_type = HVrhek_PV_UTF8; 2846 } else if (value_type == HVrhek_IV) { 2847 if (SvUOK(value)) { 2848 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); 2849 value_type = HVrhek_UV; 2850 } else { 2851 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); 2852 } 2853 } 2854 flags = value_type; 2855 2856 if (is_utf8) { 2857 /* Hash keys are always stored normalised to (yes) ISO-8859-1. 2858 As we're going to be building hash keys from this value in future, 2859 normalise it now. */ 2860 key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8); 2861 flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8; 2862 } 2863 PERL_HASH(hash, key_p, key_len); 2864 2865 #ifdef USE_ITHREADS 2866 he->refcounted_he_hash = hash; 2867 he->refcounted_he_keylen = key_len; 2868 Copy(key_p, he->refcounted_he_data + key_offset, key_len, char); 2869 #else 2870 he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags); 2871 #endif 2872 2873 if (flags & HVhek_WASUTF8) { 2874 /* If it was downgraded from UTF-8, then the pointer returned from 2875 bytes_from_utf8 is an allocated pointer that we must free. */ 2876 Safefree(key_p); 2877 } 2878 2879 he->refcounted_he_data[0] = flags; 2880 he->refcounted_he_refcnt = 1; 2881 2882 return he; 2883 } 2884 2885 /* 2886 =for apidoc refcounted_he_free 2887 2888 Decrements the reference count of the passed in C<struct refcounted_he *> 2889 by one. If the reference count reaches zero the structure's memory is freed, 2890 and C<refcounted_he_free> iterates onto the parent node. 2891 2892 =cut 2893 */ 2894 2895 void 2896 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { 2897 dVAR; 2898 PERL_UNUSED_CONTEXT; 2899 2900 while (he) { 2901 struct refcounted_he *copy; 2902 U32 new_count; 2903 2904 HINTS_REFCNT_LOCK; 2905 new_count = --he->refcounted_he_refcnt; 2906 HINTS_REFCNT_UNLOCK; 2907 2908 if (new_count) { 2909 return; 2910 } 2911 2912 #ifndef USE_ITHREADS 2913 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); 2914 #endif 2915 copy = he; 2916 he = he->refcounted_he_next; 2917 PerlMemShared_free(copy); 2918 } 2919 } 2920 2921 /* 2922 =for apidoc hv_assert 2923 2924 Check that a hash is in an internally consistent state. 2925 2926 =cut 2927 */ 2928 2929 #ifdef DEBUGGING 2930 2931 void 2932 Perl_hv_assert(pTHX_ HV *hv) 2933 { 2934 dVAR; 2935 HE* entry; 2936 int withflags = 0; 2937 int placeholders = 0; 2938 int real = 0; 2939 int bad = 0; 2940 const I32 riter = HvRITER_get(hv); 2941 HE *eiter = HvEITER_get(hv); 2942 2943 PERL_ARGS_ASSERT_HV_ASSERT; 2944 2945 (void)hv_iterinit(hv); 2946 2947 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { 2948 /* sanity check the values */ 2949 if (HeVAL(entry) == &PL_sv_placeholder) 2950 placeholders++; 2951 else 2952 real++; 2953 /* sanity check the keys */ 2954 if (HeSVKEY(entry)) { 2955 NOOP; /* Don't know what to check on SV keys. */ 2956 } else if (HeKUTF8(entry)) { 2957 withflags++; 2958 if (HeKWASUTF8(entry)) { 2959 PerlIO_printf(Perl_debug_log, 2960 "hash key has both WASUTF8 and UTF8: '%.*s'\n", 2961 (int) HeKLEN(entry), HeKEY(entry)); 2962 bad = 1; 2963 } 2964 } else if (HeKWASUTF8(entry)) 2965 withflags++; 2966 } 2967 if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) { 2968 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n"; 2969 const int nhashkeys = HvUSEDKEYS(hv); 2970 const int nhashplaceholders = HvPLACEHOLDERS_get(hv); 2971 2972 if (nhashkeys != real) { 2973 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys ); 2974 bad = 1; 2975 } 2976 if (nhashplaceholders != placeholders) { 2977 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders ); 2978 bad = 1; 2979 } 2980 } 2981 if (withflags && ! HvHASKFLAGS(hv)) { 2982 PerlIO_printf(Perl_debug_log, 2983 "Hash has HASKFLAGS off but I count %d key(s) with flags\n", 2984 withflags); 2985 bad = 1; 2986 } 2987 if (bad) { 2988 sv_dump(MUTABLE_SV(hv)); 2989 } 2990 HvRITER_set(hv, riter); /* Restore hash iterator state */ 2991 HvEITER_set(hv, eiter); 2992 } 2993 2994 #endif 2995 2996 /* 2997 * Local variables: 2998 * c-indentation-style: bsd 2999 * c-basic-offset: 4 3000 * indent-tabs-mode: t 3001 * End: 3002 * 3003 * ex: set ts=8 sts=4 sw=4 noet: 3004 */ 3005