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