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 dVAR; 1350 HV * const hv = newHV(); 1351 STRLEN hv_max, hv_fill; 1352 1353 if (!ohv || (hv_fill = HvFILL(ohv)) == 0) 1354 return hv; 1355 hv_max = HvMAX(ohv); 1356 1357 if (!SvMAGICAL((const SV *)ohv)) { 1358 /* It's an ordinary hash, so copy it fast. AMS 20010804 */ 1359 STRLEN i; 1360 const bool shared = !!HvSHAREKEYS(ohv); 1361 HE **ents, ** const oents = (HE **)HvARRAY(ohv); 1362 char *a; 1363 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); 1364 ents = (HE**)a; 1365 1366 /* In each bucket... */ 1367 for (i = 0; i <= hv_max; i++) { 1368 HE *prev = NULL; 1369 HE *oent = oents[i]; 1370 1371 if (!oent) { 1372 ents[i] = NULL; 1373 continue; 1374 } 1375 1376 /* Copy the linked list of entries. */ 1377 for (; oent; oent = HeNEXT(oent)) { 1378 const U32 hash = HeHASH(oent); 1379 const char * const key = HeKEY(oent); 1380 const STRLEN len = HeKLEN(oent); 1381 const int flags = HeKFLAGS(oent); 1382 HE * const ent = new_HE(); 1383 SV *const val = HeVAL(oent); 1384 1385 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val); 1386 HeKEY_hek(ent) 1387 = shared ? share_hek_flags(key, len, hash, flags) 1388 : save_hek_flags(key, len, hash, flags); 1389 if (prev) 1390 HeNEXT(prev) = ent; 1391 else 1392 ents[i] = ent; 1393 prev = ent; 1394 HeNEXT(ent) = NULL; 1395 } 1396 } 1397 1398 HvMAX(hv) = hv_max; 1399 HvFILL(hv) = hv_fill; 1400 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); 1401 HvARRAY(hv) = ents; 1402 } /* not magical */ 1403 else { 1404 /* Iterate over ohv, copying keys and values one at a time. */ 1405 HE *entry; 1406 const I32 riter = HvRITER_get(ohv); 1407 HE * const eiter = HvEITER_get(ohv); 1408 1409 /* Can we use fewer buckets? (hv_max is always 2^n-1) */ 1410 while (hv_max && hv_max + 1 >= hv_fill * 2) 1411 hv_max = hv_max / 2; 1412 HvMAX(hv) = hv_max; 1413 1414 hv_iterinit(ohv); 1415 while ((entry = hv_iternext_flags(ohv, 0))) { 1416 SV *const val = HeVAL(entry); 1417 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), 1418 SvIMMORTAL(val) ? val : newSVsv(val), 1419 HeHASH(entry), HeKFLAGS(entry)); 1420 } 1421 HvRITER_set(ohv, riter); 1422 HvEITER_set(ohv, eiter); 1423 } 1424 1425 return hv; 1426 } 1427 1428 /* A rather specialised version of newHVhv for copying %^H, ensuring all the 1429 magic stays on it. */ 1430 HV * 1431 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) 1432 { 1433 HV * const hv = newHV(); 1434 STRLEN hv_fill; 1435 1436 if (ohv && (hv_fill = HvFILL(ohv))) { 1437 STRLEN hv_max = HvMAX(ohv); 1438 HE *entry; 1439 const I32 riter = HvRITER_get(ohv); 1440 HE * const eiter = HvEITER_get(ohv); 1441 1442 while (hv_max && hv_max + 1 >= hv_fill * 2) 1443 hv_max = hv_max / 2; 1444 HvMAX(hv) = hv_max; 1445 1446 hv_iterinit(ohv); 1447 while ((entry = hv_iternext_flags(ohv, 0))) { 1448 SV *const sv = newSVsv(HeVAL(entry)); 1449 SV *heksv = newSVhek(HeKEY_hek(entry)); 1450 sv_magic(sv, NULL, PERL_MAGIC_hintselem, 1451 (char *)heksv, HEf_SVKEY); 1452 SvREFCNT_dec(heksv); 1453 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), 1454 sv, HeHASH(entry), HeKFLAGS(entry)); 1455 } 1456 HvRITER_set(ohv, riter); 1457 HvEITER_set(ohv, eiter); 1458 } 1459 hv_magic(hv, NULL, PERL_MAGIC_hints); 1460 return hv; 1461 } 1462 1463 void 1464 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) 1465 { 1466 dVAR; 1467 SV *val; 1468 1469 PERL_ARGS_ASSERT_HV_FREE_ENT; 1470 1471 if (!entry) 1472 return; 1473 val = HeVAL(entry); 1474 if (HvNAME(hv) && anonymise_cv(HvNAME_HEK(hv), val) && GvCVu(val)) 1475 mro_method_changed_in(hv); 1476 SvREFCNT_dec(val); 1477 if (HeKLEN(entry) == HEf_SVKEY) { 1478 SvREFCNT_dec(HeKEY_sv(entry)); 1479 Safefree(HeKEY_hek(entry)); 1480 } 1481 else if (HvSHAREKEYS(hv)) 1482 unshare_hek(HeKEY_hek(entry)); 1483 else 1484 Safefree(HeKEY_hek(entry)); 1485 del_HE(entry); 1486 } 1487 1488 static I32 1489 S_anonymise_cv(pTHX_ HEK *stash, SV *val) 1490 { 1491 CV *cv; 1492 1493 PERL_ARGS_ASSERT_ANONYMISE_CV; 1494 1495 if (val && isGV(val) && isGV_with_GP(val) && (cv = GvCV(val))) { 1496 if ((SV *)CvGV(cv) == val) { 1497 GV *anongv; 1498 1499 if (stash) { 1500 SV *gvname = newSVhek(stash); 1501 sv_catpvs(gvname, "::__ANON__"); 1502 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV); 1503 SvREFCNT_dec(gvname); 1504 } else { 1505 anongv = gv_fetchpvs("__ANON__::__ANON__", GV_ADDMULTI, 1506 SVt_PVCV); 1507 } 1508 CvGV(cv) = anongv; 1509 CvANON_on(cv); 1510 return 1; 1511 } 1512 } 1513 return 0; 1514 } 1515 1516 void 1517 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) 1518 { 1519 dVAR; 1520 1521 PERL_ARGS_ASSERT_HV_DELAYFREE_ENT; 1522 1523 if (!entry) 1524 return; 1525 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */ 1526 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */ 1527 if (HeKLEN(entry) == HEf_SVKEY) { 1528 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry))); 1529 } 1530 hv_free_ent(hv, entry); 1531 } 1532 1533 /* 1534 =for apidoc hv_clear 1535 1536 Clears a hash, making it empty. 1537 1538 =cut 1539 */ 1540 1541 void 1542 Perl_hv_clear(pTHX_ HV *hv) 1543 { 1544 dVAR; 1545 register XPVHV* xhv; 1546 if (!hv) 1547 return; 1548 1549 DEBUG_A(Perl_hv_assert(aTHX_ hv)); 1550 1551 xhv = (XPVHV*)SvANY(hv); 1552 1553 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) { 1554 /* restricted hash: convert all keys to placeholders */ 1555 STRLEN i; 1556 for (i = 0; i <= xhv->xhv_max; i++) { 1557 HE *entry = (HvARRAY(hv))[i]; 1558 for (; entry; entry = HeNEXT(entry)) { 1559 /* not already placeholder */ 1560 if (HeVAL(entry) != &PL_sv_placeholder) { 1561 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) { 1562 SV* const keysv = hv_iterkeysv(entry); 1563 Perl_croak(aTHX_ 1564 "Attempt to delete readonly key '%"SVf"' from a restricted hash", 1565 (void*)keysv); 1566 } 1567 SvREFCNT_dec(HeVAL(entry)); 1568 HeVAL(entry) = &PL_sv_placeholder; 1569 HvPLACEHOLDERS(hv)++; 1570 } 1571 } 1572 } 1573 goto reset; 1574 } 1575 1576 hfreeentries(hv); 1577 HvPLACEHOLDERS_set(hv, 0); 1578 if (HvARRAY(hv)) 1579 Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*); 1580 1581 if (SvRMAGICAL(hv)) 1582 mg_clear(MUTABLE_SV(hv)); 1583 1584 HvHASKFLAGS_off(hv); 1585 HvREHASH_off(hv); 1586 reset: 1587 if (SvOOK(hv)) { 1588 if(HvNAME_get(hv)) 1589 mro_isa_changed_in(hv); 1590 HvEITER_set(hv, NULL); 1591 } 1592 } 1593 1594 /* 1595 =for apidoc hv_clear_placeholders 1596 1597 Clears any placeholders from a hash. If a restricted hash has any of its keys 1598 marked as readonly and the key is subsequently deleted, the key is not actually 1599 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags 1600 it so it will be ignored by future operations such as iterating over the hash, 1601 but will still allow the hash to have a value reassigned to the key at some 1602 future point. This function clears any such placeholder keys from the hash. 1603 See Hash::Util::lock_keys() for an example of its use. 1604 1605 =cut 1606 */ 1607 1608 void 1609 Perl_hv_clear_placeholders(pTHX_ HV *hv) 1610 { 1611 dVAR; 1612 const U32 items = (U32)HvPLACEHOLDERS_get(hv); 1613 1614 PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS; 1615 1616 if (items) 1617 clear_placeholders(hv, items); 1618 } 1619 1620 static void 1621 S_clear_placeholders(pTHX_ HV *hv, U32 items) 1622 { 1623 dVAR; 1624 I32 i; 1625 1626 PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS; 1627 1628 if (items == 0) 1629 return; 1630 1631 i = HvMAX(hv); 1632 do { 1633 /* Loop down the linked list heads */ 1634 bool first = TRUE; 1635 HE **oentry = &(HvARRAY(hv))[i]; 1636 HE *entry; 1637 1638 while ((entry = *oentry)) { 1639 if (HeVAL(entry) == &PL_sv_placeholder) { 1640 *oentry = HeNEXT(entry); 1641 if (first && !*oentry) 1642 HvFILL(hv)--; /* This linked list is now empty. */ 1643 if (entry == HvEITER_get(hv)) 1644 HvLAZYDEL_on(hv); 1645 else 1646 hv_free_ent(hv, entry); 1647 1648 if (--items == 0) { 1649 /* Finished. */ 1650 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv); 1651 if (HvKEYS(hv) == 0) 1652 HvHASKFLAGS_off(hv); 1653 HvPLACEHOLDERS_set(hv, 0); 1654 return; 1655 } 1656 } else { 1657 oentry = &HeNEXT(entry); 1658 first = FALSE; 1659 } 1660 } 1661 } while (--i >= 0); 1662 /* You can't get here, hence assertion should always fail. */ 1663 assert (items == 0); 1664 assert (0); 1665 } 1666 1667 STATIC void 1668 S_hfreeentries(pTHX_ HV *hv) 1669 { 1670 /* This is the array that we're going to restore */ 1671 HE **const orig_array = HvARRAY(hv); 1672 HEK *name; 1673 int attempts = 100; 1674 1675 PERL_ARGS_ASSERT_HFREEENTRIES; 1676 1677 if (!orig_array) 1678 return; 1679 1680 if (HvNAME(hv) && orig_array != NULL) { 1681 /* symbol table: make all the contained subs ANON */ 1682 STRLEN i; 1683 XPVHV *xhv = (XPVHV*)SvANY(hv); 1684 1685 for (i = 0; i <= xhv->xhv_max; i++) { 1686 HE *entry = (HvARRAY(hv))[i]; 1687 for (; entry; entry = HeNEXT(entry)) { 1688 SV *val = HeVAL(entry); 1689 /* we need to put the subs in the __ANON__ symtable, as 1690 * this one is being cleared. */ 1691 anonymise_cv(NULL, val); 1692 } 1693 } 1694 } 1695 1696 if (SvOOK(hv)) { 1697 /* If the hash is actually a symbol table with a name, look after the 1698 name. */ 1699 struct xpvhv_aux *iter = HvAUX(hv); 1700 1701 name = iter->xhv_name; 1702 iter->xhv_name = NULL; 1703 } else { 1704 name = NULL; 1705 } 1706 1707 /* orig_array remains unchanged throughout the loop. If after freeing all 1708 the entries it turns out that one of the little blighters has triggered 1709 an action that has caused HvARRAY to be re-allocated, then we set 1710 array to the new HvARRAY, and try again. */ 1711 1712 while (1) { 1713 /* This is the one we're going to try to empty. First time round 1714 it's the original array. (Hopefully there will only be 1 time 1715 round) */ 1716 HE ** const array = HvARRAY(hv); 1717 I32 i = HvMAX(hv); 1718 1719 /* Because we have taken xhv_name out, the only allocated pointer 1720 in the aux structure that might exist is the backreference array. 1721 */ 1722 1723 if (SvOOK(hv)) { 1724 HE *entry; 1725 struct mro_meta *meta; 1726 struct xpvhv_aux *iter = HvAUX(hv); 1727 /* If there are weak references to this HV, we need to avoid 1728 freeing them up here. In particular we need to keep the AV 1729 visible as what we're deleting might well have weak references 1730 back to this HV, so the for loop below may well trigger 1731 the removal of backreferences from this array. */ 1732 1733 if (iter->xhv_backreferences) { 1734 /* So donate them to regular backref magic to keep them safe. 1735 The sv_magic will increase the reference count of the AV, 1736 so we need to drop it first. */ 1737 SvREFCNT_dec(iter->xhv_backreferences); 1738 if (AvFILLp(iter->xhv_backreferences) == -1) { 1739 /* Turns out that the array is empty. Just free it. */ 1740 SvREFCNT_dec(iter->xhv_backreferences); 1741 1742 } else { 1743 sv_magic(MUTABLE_SV(hv), 1744 MUTABLE_SV(iter->xhv_backreferences), 1745 PERL_MAGIC_backref, NULL, 0); 1746 } 1747 iter->xhv_backreferences = NULL; 1748 } 1749 1750 entry = iter->xhv_eiter; /* HvEITER(hv) */ 1751 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ 1752 HvLAZYDEL_off(hv); 1753 hv_free_ent(hv, entry); 1754 } 1755 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ 1756 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 1757 1758 if((meta = iter->xhv_mro_meta)) { 1759 if (meta->mro_linear_all) { 1760 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all)); 1761 meta->mro_linear_all = NULL; 1762 /* This is just acting as a shortcut pointer. */ 1763 meta->mro_linear_current = NULL; 1764 } else if (meta->mro_linear_current) { 1765 /* Only the current MRO is stored, so this owns the data. 1766 */ 1767 SvREFCNT_dec(meta->mro_linear_current); 1768 meta->mro_linear_current = NULL; 1769 } 1770 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod); 1771 SvREFCNT_dec(meta->isa); 1772 Safefree(meta); 1773 iter->xhv_mro_meta = NULL; 1774 } 1775 1776 /* There are now no allocated pointers in the aux structure. */ 1777 1778 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */ 1779 /* What aux structure? */ 1780 } 1781 1782 /* make everyone else think the array is empty, so that the destructors 1783 * called for freed entries can't recusively mess with us */ 1784 HvARRAY(hv) = NULL; 1785 HvFILL(hv) = 0; 1786 ((XPVHV*) SvANY(hv))->xhv_keys = 0; 1787 1788 1789 do { 1790 /* Loop down the linked list heads */ 1791 HE *entry = array[i]; 1792 1793 while (entry) { 1794 register HE * const oentry = entry; 1795 entry = HeNEXT(entry); 1796 hv_free_ent(hv, oentry); 1797 } 1798 } while (--i >= 0); 1799 1800 /* As there are no allocated pointers in the aux structure, it's now 1801 safe to free the array we just cleaned up, if it's not the one we're 1802 going to put back. */ 1803 if (array != orig_array) { 1804 Safefree(array); 1805 } 1806 1807 if (!HvARRAY(hv)) { 1808 /* Good. No-one added anything this time round. */ 1809 break; 1810 } 1811 1812 if (SvOOK(hv)) { 1813 /* Someone attempted to iterate or set the hash name while we had 1814 the array set to 0. We'll catch backferences on the next time 1815 round the while loop. */ 1816 assert(HvARRAY(hv)); 1817 1818 if (HvAUX(hv)->xhv_name) { 1819 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0); 1820 } 1821 } 1822 1823 if (--attempts == 0) { 1824 Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries"); 1825 } 1826 } 1827 1828 HvARRAY(hv) = orig_array; 1829 1830 /* If the hash was actually a symbol table, put the name back. */ 1831 if (name) { 1832 /* We have restored the original array. If name is non-NULL, then 1833 the original array had an aux structure at the end. So this is 1834 valid: */ 1835 SvFLAGS(hv) |= SVf_OOK; 1836 HvAUX(hv)->xhv_name = name; 1837 } 1838 } 1839 1840 /* 1841 =for apidoc hv_undef 1842 1843 Undefines the hash. 1844 1845 =cut 1846 */ 1847 1848 void 1849 Perl_hv_undef(pTHX_ HV *hv) 1850 { 1851 dVAR; 1852 register XPVHV* xhv; 1853 const char *name; 1854 1855 if (!hv) 1856 return; 1857 DEBUG_A(Perl_hv_assert(aTHX_ hv)); 1858 xhv = (XPVHV*)SvANY(hv); 1859 1860 if ((name = HvNAME_get(hv)) && !PL_dirty) 1861 mro_isa_changed_in(hv); 1862 1863 hfreeentries(hv); 1864 if (name) { 1865 if (PL_stashcache) 1866 (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); 1867 hv_name_set(hv, NULL, 0, 0); 1868 } 1869 SvFLAGS(hv) &= ~SVf_OOK; 1870 Safefree(HvARRAY(hv)); 1871 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */ 1872 HvARRAY(hv) = 0; 1873 HvPLACEHOLDERS_set(hv, 0); 1874 1875 if (SvRMAGICAL(hv)) 1876 mg_clear(MUTABLE_SV(hv)); 1877 } 1878 1879 static struct xpvhv_aux* 1880 S_hv_auxinit(HV *hv) { 1881 struct xpvhv_aux *iter; 1882 char *array; 1883 1884 PERL_ARGS_ASSERT_HV_AUXINIT; 1885 1886 if (!HvARRAY(hv)) { 1887 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) 1888 + sizeof(struct xpvhv_aux), char); 1889 } else { 1890 array = (char *) HvARRAY(hv); 1891 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1) 1892 + sizeof(struct xpvhv_aux), char); 1893 } 1894 HvARRAY(hv) = (HE**) array; 1895 /* SvOOK_on(hv) attacks the IV flags. */ 1896 SvFLAGS(hv) |= SVf_OOK; 1897 iter = HvAUX(hv); 1898 1899 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ 1900 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 1901 iter->xhv_name = 0; 1902 iter->xhv_backreferences = 0; 1903 iter->xhv_mro_meta = NULL; 1904 return iter; 1905 } 1906 1907 /* 1908 =for apidoc hv_iterinit 1909 1910 Prepares a starting point to traverse a hash table. Returns the number of 1911 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is 1912 currently only meaningful for hashes without tie magic. 1913 1914 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of 1915 hash buckets that happen to be in use. If you still need that esoteric 1916 value, you can get it through the macro C<HvFILL(tb)>. 1917 1918 1919 =cut 1920 */ 1921 1922 I32 1923 Perl_hv_iterinit(pTHX_ HV *hv) 1924 { 1925 PERL_ARGS_ASSERT_HV_ITERINIT; 1926 1927 /* FIXME: Are we not NULL, or do we croak? Place bets now! */ 1928 1929 if (!hv) 1930 Perl_croak(aTHX_ "Bad hash"); 1931 1932 if (SvOOK(hv)) { 1933 struct xpvhv_aux * const iter = HvAUX(hv); 1934 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */ 1935 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ 1936 HvLAZYDEL_off(hv); 1937 hv_free_ent(hv, entry); 1938 } 1939 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ 1940 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 1941 } else { 1942 hv_auxinit(hv); 1943 } 1944 1945 /* used to be xhv->xhv_fill before 5.004_65 */ 1946 return HvTOTALKEYS(hv); 1947 } 1948 1949 I32 * 1950 Perl_hv_riter_p(pTHX_ HV *hv) { 1951 struct xpvhv_aux *iter; 1952 1953 PERL_ARGS_ASSERT_HV_RITER_P; 1954 1955 if (!hv) 1956 Perl_croak(aTHX_ "Bad hash"); 1957 1958 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); 1959 return &(iter->xhv_riter); 1960 } 1961 1962 HE ** 1963 Perl_hv_eiter_p(pTHX_ HV *hv) { 1964 struct xpvhv_aux *iter; 1965 1966 PERL_ARGS_ASSERT_HV_EITER_P; 1967 1968 if (!hv) 1969 Perl_croak(aTHX_ "Bad hash"); 1970 1971 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); 1972 return &(iter->xhv_eiter); 1973 } 1974 1975 void 1976 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { 1977 struct xpvhv_aux *iter; 1978 1979 PERL_ARGS_ASSERT_HV_RITER_SET; 1980 1981 if (!hv) 1982 Perl_croak(aTHX_ "Bad hash"); 1983 1984 if (SvOOK(hv)) { 1985 iter = HvAUX(hv); 1986 } else { 1987 if (riter == -1) 1988 return; 1989 1990 iter = hv_auxinit(hv); 1991 } 1992 iter->xhv_riter = riter; 1993 } 1994 1995 void 1996 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { 1997 struct xpvhv_aux *iter; 1998 1999 PERL_ARGS_ASSERT_HV_EITER_SET; 2000 2001 if (!hv) 2002 Perl_croak(aTHX_ "Bad hash"); 2003 2004 if (SvOOK(hv)) { 2005 iter = HvAUX(hv); 2006 } else { 2007 /* 0 is the default so don't go malloc()ing a new structure just to 2008 hold 0. */ 2009 if (!eiter) 2010 return; 2011 2012 iter = hv_auxinit(hv); 2013 } 2014 iter->xhv_eiter = eiter; 2015 } 2016 2017 void 2018 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) 2019 { 2020 dVAR; 2021 struct xpvhv_aux *iter; 2022 U32 hash; 2023 2024 PERL_ARGS_ASSERT_HV_NAME_SET; 2025 PERL_UNUSED_ARG(flags); 2026 2027 if (len > I32_MAX) 2028 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); 2029 2030 if (SvOOK(hv)) { 2031 iter = HvAUX(hv); 2032 if (iter->xhv_name) { 2033 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0); 2034 } 2035 } else { 2036 if (name == 0) 2037 return; 2038 2039 iter = hv_auxinit(hv); 2040 } 2041 PERL_HASH(hash, name, len); 2042 iter->xhv_name = name ? share_hek(name, len, hash) : NULL; 2043 } 2044 2045 AV ** 2046 Perl_hv_backreferences_p(pTHX_ HV *hv) { 2047 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); 2048 2049 PERL_ARGS_ASSERT_HV_BACKREFERENCES_P; 2050 PERL_UNUSED_CONTEXT; 2051 2052 return &(iter->xhv_backreferences); 2053 } 2054 2055 void 2056 Perl_hv_kill_backrefs(pTHX_ HV *hv) { 2057 AV *av; 2058 2059 PERL_ARGS_ASSERT_HV_KILL_BACKREFS; 2060 2061 if (!SvOOK(hv)) 2062 return; 2063 2064 av = HvAUX(hv)->xhv_backreferences; 2065 2066 if (av) { 2067 HvAUX(hv)->xhv_backreferences = 0; 2068 Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av); 2069 SvREFCNT_dec(av); 2070 } 2071 } 2072 2073 /* 2074 hv_iternext is implemented as a macro in hv.h 2075 2076 =for apidoc hv_iternext 2077 2078 Returns entries from a hash iterator. See C<hv_iterinit>. 2079 2080 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the 2081 iterator currently points to, without losing your place or invalidating your 2082 iterator. Note that in this case the current entry is deleted from the hash 2083 with your iterator holding the last reference to it. Your iterator is flagged 2084 to free the entry on the next call to C<hv_iternext>, so you must not discard 2085 your iterator immediately else the entry will leak - call C<hv_iternext> to 2086 trigger the resource deallocation. 2087 2088 =for apidoc hv_iternext_flags 2089 2090 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>. 2091 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is 2092 set the placeholders keys (for restricted hashes) will be returned in addition 2093 to normal keys. By default placeholders are automatically skipped over. 2094 Currently a placeholder is implemented with a value that is 2095 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and 2096 restricted hashes may change, and the implementation currently is 2097 insufficiently abstracted for any change to be tidy. 2098 2099 =cut 2100 */ 2101 2102 HE * 2103 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) 2104 { 2105 dVAR; 2106 register XPVHV* xhv; 2107 register HE *entry; 2108 HE *oldentry; 2109 MAGIC* mg; 2110 struct xpvhv_aux *iter; 2111 2112 PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS; 2113 2114 if (!hv) 2115 Perl_croak(aTHX_ "Bad hash"); 2116 2117 xhv = (XPVHV*)SvANY(hv); 2118 2119 if (!SvOOK(hv)) { 2120 /* Too many things (well, pp_each at least) merrily assume that you can 2121 call iv_iternext without calling hv_iterinit, so we'll have to deal 2122 with it. */ 2123 hv_iterinit(hv); 2124 } 2125 iter = HvAUX(hv); 2126 2127 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ 2128 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) { 2129 if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) { 2130 SV * const key = sv_newmortal(); 2131 if (entry) { 2132 sv_setsv(key, HeSVKEY_force(entry)); 2133 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ 2134 } 2135 else { 2136 char *k; 2137 HEK *hek; 2138 2139 /* one HE per MAGICAL hash */ 2140 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ 2141 Zero(entry, 1, HE); 2142 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char); 2143 hek = (HEK*)k; 2144 HeKEY_hek(entry) = hek; 2145 HeKLEN(entry) = HEf_SVKEY; 2146 } 2147 magic_nextpack(MUTABLE_SV(hv),mg,key); 2148 if (SvOK(key)) { 2149 /* force key to stay around until next time */ 2150 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); 2151 return entry; /* beware, hent_val is not set */ 2152 } 2153 SvREFCNT_dec(HeVAL(entry)); 2154 Safefree(HeKEY_hek(entry)); 2155 del_HE(entry); 2156 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ 2157 return NULL; 2158 } 2159 } 2160 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */ 2161 if (!entry && SvRMAGICAL((const SV *)hv) 2162 && mg_find((const SV *)hv, PERL_MAGIC_env)) { 2163 prime_env_iter(); 2164 #ifdef VMS 2165 /* The prime_env_iter() on VMS just loaded up new hash values 2166 * so the iteration count needs to be reset back to the beginning 2167 */ 2168 hv_iterinit(hv); 2169 iter = HvAUX(hv); 2170 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ 2171 #endif 2172 } 2173 #endif 2174 2175 /* hv_iterint now ensures this. */ 2176 assert (HvARRAY(hv)); 2177 2178 /* At start of hash, entry is NULL. */ 2179 if (entry) 2180 { 2181 entry = HeNEXT(entry); 2182 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { 2183 /* 2184 * Skip past any placeholders -- don't want to include them in 2185 * any iteration. 2186 */ 2187 while (entry && HeVAL(entry) == &PL_sv_placeholder) { 2188 entry = HeNEXT(entry); 2189 } 2190 } 2191 } 2192 2193 /* Skip the entire loop if the hash is empty. */ 2194 if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS) 2195 ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) { 2196 while (!entry) { 2197 /* OK. Come to the end of the current list. Grab the next one. */ 2198 2199 iter->xhv_riter++; /* HvRITER(hv)++ */ 2200 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { 2201 /* There is no next one. End of the hash. */ 2202 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ 2203 break; 2204 } 2205 entry = (HvARRAY(hv))[iter->xhv_riter]; 2206 2207 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { 2208 /* If we have an entry, but it's a placeholder, don't count it. 2209 Try the next. */ 2210 while (entry && HeVAL(entry) == &PL_sv_placeholder) 2211 entry = HeNEXT(entry); 2212 } 2213 /* Will loop again if this linked list starts NULL 2214 (for HV_ITERNEXT_WANTPLACEHOLDERS) 2215 or if we run through it and find only placeholders. */ 2216 } 2217 } 2218 2219 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ 2220 HvLAZYDEL_off(hv); 2221 hv_free_ent(hv, oldentry); 2222 } 2223 2224 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry)) 2225 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/ 2226 2227 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */ 2228 return entry; 2229 } 2230 2231 /* 2232 =for apidoc hv_iterkey 2233 2234 Returns the key from the current position of the hash iterator. See 2235 C<hv_iterinit>. 2236 2237 =cut 2238 */ 2239 2240 char * 2241 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen) 2242 { 2243 PERL_ARGS_ASSERT_HV_ITERKEY; 2244 2245 if (HeKLEN(entry) == HEf_SVKEY) { 2246 STRLEN len; 2247 char * const p = SvPV(HeKEY_sv(entry), len); 2248 *retlen = len; 2249 return p; 2250 } 2251 else { 2252 *retlen = HeKLEN(entry); 2253 return HeKEY(entry); 2254 } 2255 } 2256 2257 /* unlike hv_iterval(), this always returns a mortal copy of the key */ 2258 /* 2259 =for apidoc hv_iterkeysv 2260 2261 Returns the key as an C<SV*> from the current position of the hash 2262 iterator. The return value will always be a mortal copy of the key. Also 2263 see C<hv_iterinit>. 2264 2265 =cut 2266 */ 2267 2268 SV * 2269 Perl_hv_iterkeysv(pTHX_ register HE *entry) 2270 { 2271 PERL_ARGS_ASSERT_HV_ITERKEYSV; 2272 2273 return sv_2mortal(newSVhek(HeKEY_hek(entry))); 2274 } 2275 2276 /* 2277 =for apidoc hv_iterval 2278 2279 Returns the value from the current position of the hash iterator. See 2280 C<hv_iterkey>. 2281 2282 =cut 2283 */ 2284 2285 SV * 2286 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry) 2287 { 2288 PERL_ARGS_ASSERT_HV_ITERVAL; 2289 2290 if (SvRMAGICAL(hv)) { 2291 if (mg_find((const SV *)hv, PERL_MAGIC_tied)) { 2292 SV* const sv = sv_newmortal(); 2293 if (HeKLEN(entry) == HEf_SVKEY) 2294 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY); 2295 else 2296 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry)); 2297 return sv; 2298 } 2299 } 2300 return HeVAL(entry); 2301 } 2302 2303 /* 2304 =for apidoc hv_iternextsv 2305 2306 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one 2307 operation. 2308 2309 =cut 2310 */ 2311 2312 SV * 2313 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) 2314 { 2315 HE * const he = hv_iternext_flags(hv, 0); 2316 2317 PERL_ARGS_ASSERT_HV_ITERNEXTSV; 2318 2319 if (!he) 2320 return NULL; 2321 *key = hv_iterkey(he, retlen); 2322 return hv_iterval(hv, he); 2323 } 2324 2325 /* 2326 2327 Now a macro in hv.h 2328 2329 =for apidoc hv_magic 2330 2331 Adds magic to a hash. See C<sv_magic>. 2332 2333 =cut 2334 */ 2335 2336 /* possibly free a shared string if no one has access to it 2337 * len and hash must both be valid for str. 2338 */ 2339 void 2340 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) 2341 { 2342 unshare_hek_or_pvn (NULL, str, len, hash); 2343 } 2344 2345 2346 void 2347 Perl_unshare_hek(pTHX_ HEK *hek) 2348 { 2349 assert(hek); 2350 unshare_hek_or_pvn(hek, NULL, 0, 0); 2351 } 2352 2353 /* possibly free a shared string if no one has access to it 2354 hek if non-NULL takes priority over the other 3, else str, len and hash 2355 are used. If so, len and hash must both be valid for str. 2356 */ 2357 STATIC void 2358 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) 2359 { 2360 dVAR; 2361 register XPVHV* xhv; 2362 HE *entry; 2363 register HE **oentry; 2364 HE **first; 2365 bool is_utf8 = FALSE; 2366 int k_flags = 0; 2367 const char * const save = str; 2368 struct shared_he *he = NULL; 2369 2370 if (hek) { 2371 /* Find the shared he which is just before us in memory. */ 2372 he = (struct shared_he *)(((char *)hek) 2373 - STRUCT_OFFSET(struct shared_he, 2374 shared_he_hek)); 2375 2376 /* Assert that the caller passed us a genuine (or at least consistent) 2377 shared hek */ 2378 assert (he->shared_he_he.hent_hek == hek); 2379 2380 if (he->shared_he_he.he_valu.hent_refcount - 1) { 2381 --he->shared_he_he.he_valu.hent_refcount; 2382 return; 2383 } 2384 2385 hash = HEK_HASH(hek); 2386 } else if (len < 0) { 2387 STRLEN tmplen = -len; 2388 is_utf8 = TRUE; 2389 /* See the note in hv_fetch(). --jhi */ 2390 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); 2391 len = tmplen; 2392 if (is_utf8) 2393 k_flags = HVhek_UTF8; 2394 if (str != save) 2395 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 2396 } 2397 2398 /* what follows was the moral equivalent of: 2399 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { 2400 if (--*Svp == NULL) 2401 hv_delete(PL_strtab, str, len, G_DISCARD, hash); 2402 } */ 2403 xhv = (XPVHV*)SvANY(PL_strtab); 2404 /* assert(xhv_array != 0) */ 2405 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; 2406 if (he) { 2407 const HE *const he_he = &(he->shared_he_he); 2408 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { 2409 if (entry == he_he) 2410 break; 2411 } 2412 } else { 2413 const int flags_masked = k_flags & HVhek_MASK; 2414 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { 2415 if (HeHASH(entry) != hash) /* strings can't be equal */ 2416 continue; 2417 if (HeKLEN(entry) != len) 2418 continue; 2419 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ 2420 continue; 2421 if (HeKFLAGS(entry) != flags_masked) 2422 continue; 2423 break; 2424 } 2425 } 2426 2427 if (entry) { 2428 if (--entry->he_valu.hent_refcount == 0) { 2429 *oentry = HeNEXT(entry); 2430 if (!*first) { 2431 /* There are now no entries in our slot. */ 2432 xhv->xhv_fill--; /* HvFILL(hv)-- */ 2433 } 2434 Safefree(entry); 2435 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ 2436 } 2437 } 2438 2439 if (!entry) 2440 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 2441 "Attempt to free non-existent shared string '%s'%s" 2442 pTHX__FORMAT, 2443 hek ? HEK_KEY(hek) : str, 2444 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); 2445 if (k_flags & HVhek_FREEKEY) 2446 Safefree(str); 2447 } 2448 2449 /* get a (constant) string ptr from the global string table 2450 * string will get added if it is not already there. 2451 * len and hash must both be valid for str. 2452 */ 2453 HEK * 2454 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) 2455 { 2456 bool is_utf8 = FALSE; 2457 int flags = 0; 2458 const char * const save = str; 2459 2460 PERL_ARGS_ASSERT_SHARE_HEK; 2461 2462 if (len < 0) { 2463 STRLEN tmplen = -len; 2464 is_utf8 = TRUE; 2465 /* See the note in hv_fetch(). --jhi */ 2466 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); 2467 len = tmplen; 2468 /* If we were able to downgrade here, then than means that we were passed 2469 in a key which only had chars 0-255, but was utf8 encoded. */ 2470 if (is_utf8) 2471 flags = HVhek_UTF8; 2472 /* If we found we were able to downgrade the string to bytes, then 2473 we should flag that it needs upgrading on keys or each. Also flag 2474 that we need share_hek_flags to free the string. */ 2475 if (str != save) 2476 flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 2477 } 2478 2479 return share_hek_flags (str, len, hash, flags); 2480 } 2481 2482 STATIC HEK * 2483 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) 2484 { 2485 dVAR; 2486 register HE *entry; 2487 const int flags_masked = flags & HVhek_MASK; 2488 const U32 hindex = hash & (I32) HvMAX(PL_strtab); 2489 register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab); 2490 2491 PERL_ARGS_ASSERT_SHARE_HEK_FLAGS; 2492 2493 /* what follows is the moral equivalent of: 2494 2495 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) 2496 hv_store(PL_strtab, str, len, NULL, hash); 2497 2498 Can't rehash the shared string table, so not sure if it's worth 2499 counting the number of entries in the linked list 2500 */ 2501 2502 /* assert(xhv_array != 0) */ 2503 entry = (HvARRAY(PL_strtab))[hindex]; 2504 for (;entry; entry = HeNEXT(entry)) { 2505 if (HeHASH(entry) != hash) /* strings can't be equal */ 2506 continue; 2507 if (HeKLEN(entry) != len) 2508 continue; 2509 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ 2510 continue; 2511 if (HeKFLAGS(entry) != flags_masked) 2512 continue; 2513 break; 2514 } 2515 2516 if (!entry) { 2517 /* What used to be head of the list. 2518 If this is NULL, then we're the first entry for this slot, which 2519 means we need to increate fill. */ 2520 struct shared_he *new_entry; 2521 HEK *hek; 2522 char *k; 2523 HE **const head = &HvARRAY(PL_strtab)[hindex]; 2524 HE *const next = *head; 2525 2526 /* We don't actually store a HE from the arena and a regular HEK. 2527 Instead we allocate one chunk of memory big enough for both, 2528 and put the HEK straight after the HE. This way we can find the 2529 HEK directly from the HE. 2530 */ 2531 2532 Newx(k, STRUCT_OFFSET(struct shared_he, 2533 shared_he_hek.hek_key[0]) + len + 2, char); 2534 new_entry = (struct shared_he *)k; 2535 entry = &(new_entry->shared_he_he); 2536 hek = &(new_entry->shared_he_hek); 2537 2538 Copy(str, HEK_KEY(hek), len, char); 2539 HEK_KEY(hek)[len] = 0; 2540 HEK_LEN(hek) = len; 2541 HEK_HASH(hek) = hash; 2542 HEK_FLAGS(hek) = (unsigned char)flags_masked; 2543 2544 /* Still "point" to the HEK, so that other code need not know what 2545 we're up to. */ 2546 HeKEY_hek(entry) = hek; 2547 entry->he_valu.hent_refcount = 0; 2548 HeNEXT(entry) = next; 2549 *head = entry; 2550 2551 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ 2552 if (!next) { /* initial entry? */ 2553 xhv->xhv_fill++; /* HvFILL(hv)++ */ 2554 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { 2555 hsplit(PL_strtab); 2556 } 2557 } 2558 2559 ++entry->he_valu.hent_refcount; 2560 2561 if (flags & HVhek_FREEKEY) 2562 Safefree(str); 2563 2564 return HeKEY_hek(entry); 2565 } 2566 2567 I32 * 2568 Perl_hv_placeholders_p(pTHX_ HV *hv) 2569 { 2570 dVAR; 2571 MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); 2572 2573 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P; 2574 2575 if (!mg) { 2576 mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0); 2577 2578 if (!mg) { 2579 Perl_die(aTHX_ "panic: hv_placeholders_p"); 2580 } 2581 } 2582 return &(mg->mg_len); 2583 } 2584 2585 2586 I32 2587 Perl_hv_placeholders_get(pTHX_ const HV *hv) 2588 { 2589 dVAR; 2590 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); 2591 2592 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET; 2593 2594 return mg ? mg->mg_len : 0; 2595 } 2596 2597 void 2598 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) 2599 { 2600 dVAR; 2601 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); 2602 2603 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET; 2604 2605 if (mg) { 2606 mg->mg_len = ph; 2607 } else if (ph) { 2608 if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph)) 2609 Perl_die(aTHX_ "panic: hv_placeholders_set"); 2610 } 2611 /* else we don't need to add magic to record 0 placeholders. */ 2612 } 2613 2614 STATIC SV * 2615 S_refcounted_he_value(pTHX_ const struct refcounted_he *he) 2616 { 2617 dVAR; 2618 SV *value; 2619 2620 PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE; 2621 2622 switch(he->refcounted_he_data[0] & HVrhek_typemask) { 2623 case HVrhek_undef: 2624 value = newSV(0); 2625 break; 2626 case HVrhek_delete: 2627 value = &PL_sv_placeholder; 2628 break; 2629 case HVrhek_IV: 2630 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv); 2631 break; 2632 case HVrhek_UV: 2633 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv); 2634 break; 2635 case HVrhek_PV: 2636 case HVrhek_PV_UTF8: 2637 /* Create a string SV that directly points to the bytes in our 2638 structure. */ 2639 value = newSV_type(SVt_PV); 2640 SvPV_set(value, (char *) he->refcounted_he_data + 1); 2641 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len); 2642 /* This stops anything trying to free it */ 2643 SvLEN_set(value, 0); 2644 SvPOK_on(value); 2645 SvREADONLY_on(value); 2646 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8) 2647 SvUTF8_on(value); 2648 break; 2649 default: 2650 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x", 2651 he->refcounted_he_data[0]); 2652 } 2653 return value; 2654 } 2655 2656 /* 2657 =for apidoc refcounted_he_chain_2hv 2658 2659 Generates and returns a C<HV *> by walking up the tree starting at the passed 2660 in C<struct refcounted_he *>. 2661 2662 =cut 2663 */ 2664 HV * 2665 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) 2666 { 2667 dVAR; 2668 HV *hv = newHV(); 2669 U32 placeholders = 0; 2670 /* We could chase the chain once to get an idea of the number of keys, 2671 and call ksplit. But for now we'll make a potentially inefficient 2672 hash with only 8 entries in its array. */ 2673 const U32 max = HvMAX(hv); 2674 2675 if (!HvARRAY(hv)) { 2676 char *array; 2677 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); 2678 HvARRAY(hv) = (HE**)array; 2679 } 2680 2681 while (chain) { 2682 #ifdef USE_ITHREADS 2683 U32 hash = chain->refcounted_he_hash; 2684 #else 2685 U32 hash = HEK_HASH(chain->refcounted_he_hek); 2686 #endif 2687 HE **oentry = &((HvARRAY(hv))[hash & max]); 2688 HE *entry = *oentry; 2689 SV *value; 2690 2691 for (; entry; entry = HeNEXT(entry)) { 2692 if (HeHASH(entry) == hash) { 2693 /* We might have a duplicate key here. If so, entry is older 2694 than the key we've already put in the hash, so if they are 2695 the same, skip adding entry. */ 2696 #ifdef USE_ITHREADS 2697 const STRLEN klen = HeKLEN(entry); 2698 const char *const key = HeKEY(entry); 2699 if (klen == chain->refcounted_he_keylen 2700 && (!!HeKUTF8(entry) 2701 == !!(chain->refcounted_he_data[0] & HVhek_UTF8)) 2702 && memEQ(key, REF_HE_KEY(chain), klen)) 2703 goto next_please; 2704 #else 2705 if (HeKEY_hek(entry) == chain->refcounted_he_hek) 2706 goto next_please; 2707 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek) 2708 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek) 2709 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek), 2710 HeKLEN(entry))) 2711 goto next_please; 2712 #endif 2713 } 2714 } 2715 assert (!entry); 2716 entry = new_HE(); 2717 2718 #ifdef USE_ITHREADS 2719 HeKEY_hek(entry) 2720 = share_hek_flags(REF_HE_KEY(chain), 2721 chain->refcounted_he_keylen, 2722 chain->refcounted_he_hash, 2723 (chain->refcounted_he_data[0] 2724 & (HVhek_UTF8|HVhek_WASUTF8))); 2725 #else 2726 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); 2727 #endif 2728 value = refcounted_he_value(chain); 2729 if (value == &PL_sv_placeholder) 2730 placeholders++; 2731 HeVAL(entry) = value; 2732 2733 /* Link it into the chain. */ 2734 HeNEXT(entry) = *oentry; 2735 if (!HeNEXT(entry)) { 2736 /* initial entry. */ 2737 HvFILL(hv)++; 2738 } 2739 *oentry = entry; 2740 2741 HvTOTALKEYS(hv)++; 2742 2743 next_please: 2744 chain = chain->refcounted_he_next; 2745 } 2746 2747 if (placeholders) { 2748 clear_placeholders(hv, placeholders); 2749 HvTOTALKEYS(hv) -= placeholders; 2750 } 2751 2752 /* We could check in the loop to see if we encounter any keys with key 2753 flags, but it's probably not worth it, as this per-hash flag is only 2754 really meant as an optimisation for things like Storable. */ 2755 HvHASKFLAGS_on(hv); 2756 DEBUG_A(Perl_hv_assert(aTHX_ hv)); 2757 2758 return hv; 2759 } 2760 2761 SV * 2762 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, 2763 const char *key, STRLEN klen, int flags, U32 hash) 2764 { 2765 dVAR; 2766 /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness 2767 of your key has to exactly match that which is stored. */ 2768 SV *value = &PL_sv_placeholder; 2769 2770 if (chain) { 2771 /* No point in doing any of this if there's nothing to find. */ 2772 bool is_utf8; 2773 2774 if (keysv) { 2775 if (flags & HVhek_FREEKEY) 2776 Safefree(key); 2777 key = SvPV_const(keysv, klen); 2778 flags = 0; 2779 is_utf8 = (SvUTF8(keysv) != 0); 2780 } else { 2781 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); 2782 } 2783 2784 if (!hash) { 2785 if (keysv && (SvIsCOW_shared_hash(keysv))) { 2786 hash = SvSHARED_HASH(keysv); 2787 } else { 2788 PERL_HASH(hash, key, klen); 2789 } 2790 } 2791 2792 for (; chain; chain = chain->refcounted_he_next) { 2793 #ifdef USE_ITHREADS 2794 if (hash != chain->refcounted_he_hash) 2795 continue; 2796 if (klen != chain->refcounted_he_keylen) 2797 continue; 2798 if (memNE(REF_HE_KEY(chain),key,klen)) 2799 continue; 2800 if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8)) 2801 continue; 2802 #else 2803 if (hash != HEK_HASH(chain->refcounted_he_hek)) 2804 continue; 2805 if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek)) 2806 continue; 2807 if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen)) 2808 continue; 2809 if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek)) 2810 continue; 2811 #endif 2812 2813 value = sv_2mortal(refcounted_he_value(chain)); 2814 break; 2815 } 2816 } 2817 2818 if (flags & HVhek_FREEKEY) 2819 Safefree(key); 2820 2821 return value; 2822 } 2823 2824 /* 2825 =for apidoc refcounted_he_new 2826 2827 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is 2828 stored in a compact form, all references remain the property of the caller. 2829 The C<struct refcounted_he> is returned with a reference count of 1. 2830 2831 =cut 2832 */ 2833 2834 struct refcounted_he * 2835 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, 2836 SV *const key, SV *const value) { 2837 dVAR; 2838 STRLEN key_len; 2839 const char *key_p = SvPV_const(key, key_len); 2840 STRLEN value_len = 0; 2841 const char *value_p = NULL; 2842 char value_type; 2843 char flags; 2844 bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; 2845 2846 if (SvPOK(value)) { 2847 value_type = HVrhek_PV; 2848 } else if (SvIOK(value)) { 2849 value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; 2850 } else if (value == &PL_sv_placeholder) { 2851 value_type = HVrhek_delete; 2852 } else if (!SvOK(value)) { 2853 value_type = HVrhek_undef; 2854 } else { 2855 value_type = HVrhek_PV; 2856 } 2857 2858 if (value_type == HVrhek_PV) { 2859 /* Do it this way so that the SvUTF8() test is after the SvPV, in case 2860 the value is overloaded, and doesn't yet have the UTF-8flag set. */ 2861 value_p = SvPV_const(value, value_len); 2862 if (SvUTF8(value)) 2863 value_type = HVrhek_PV_UTF8; 2864 } 2865 flags = value_type; 2866 2867 if (is_utf8) { 2868 /* Hash keys are always stored normalised to (yes) ISO-8859-1. 2869 As we're going to be building hash keys from this value in future, 2870 normalise it now. */ 2871 key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8); 2872 flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8; 2873 } 2874 2875 return refcounted_he_new_common(parent, key_p, key_len, flags, value_type, 2876 ((value_type == HVrhek_PV 2877 || value_type == HVrhek_PV_UTF8) ? 2878 (void *)value_p : (void *)value), 2879 value_len); 2880 } 2881 2882 static struct refcounted_he * 2883 S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, 2884 const char *const key_p, const STRLEN key_len, 2885 const char flags, char value_type, 2886 const void *value, const STRLEN value_len) { 2887 dVAR; 2888 struct refcounted_he *he; 2889 U32 hash; 2890 const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8; 2891 STRLEN key_offset = is_pv ? value_len + 2 : 1; 2892 2893 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON; 2894 2895 #ifdef USE_ITHREADS 2896 he = (struct refcounted_he*) 2897 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 2898 + key_len 2899 + key_offset); 2900 #else 2901 he = (struct refcounted_he*) 2902 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 2903 + key_offset); 2904 #endif 2905 2906 he->refcounted_he_next = parent; 2907 2908 if (is_pv) { 2909 Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char); 2910 he->refcounted_he_val.refcounted_he_u_len = value_len; 2911 } else if (value_type == HVrhek_IV) { 2912 he->refcounted_he_val.refcounted_he_u_iv = SvIVX((const SV *)value); 2913 } else if (value_type == HVrhek_UV) { 2914 he->refcounted_he_val.refcounted_he_u_uv = SvUVX((const SV *)value); 2915 } 2916 2917 PERL_HASH(hash, key_p, key_len); 2918 2919 #ifdef USE_ITHREADS 2920 he->refcounted_he_hash = hash; 2921 he->refcounted_he_keylen = key_len; 2922 Copy(key_p, he->refcounted_he_data + key_offset, key_len, char); 2923 #else 2924 he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags); 2925 #endif 2926 2927 if (flags & HVhek_WASUTF8) { 2928 /* If it was downgraded from UTF-8, then the pointer returned from 2929 bytes_from_utf8 is an allocated pointer that we must free. */ 2930 Safefree(key_p); 2931 } 2932 2933 he->refcounted_he_data[0] = flags; 2934 he->refcounted_he_refcnt = 1; 2935 2936 return he; 2937 } 2938 2939 /* 2940 =for apidoc refcounted_he_free 2941 2942 Decrements the reference count of the passed in C<struct refcounted_he *> 2943 by one. If the reference count reaches zero the structure's memory is freed, 2944 and C<refcounted_he_free> iterates onto the parent node. 2945 2946 =cut 2947 */ 2948 2949 void 2950 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { 2951 dVAR; 2952 PERL_UNUSED_CONTEXT; 2953 2954 while (he) { 2955 struct refcounted_he *copy; 2956 U32 new_count; 2957 2958 HINTS_REFCNT_LOCK; 2959 new_count = --he->refcounted_he_refcnt; 2960 HINTS_REFCNT_UNLOCK; 2961 2962 if (new_count) { 2963 return; 2964 } 2965 2966 #ifndef USE_ITHREADS 2967 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); 2968 #endif 2969 copy = he; 2970 he = he->refcounted_he_next; 2971 PerlMemShared_free(copy); 2972 } 2973 } 2974 2975 /* pp_entereval is aware that labels are stored with a key ':' at the top of 2976 the linked list. */ 2977 const char * 2978 Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len, 2979 U32 *flags) { 2980 if (!chain) 2981 return NULL; 2982 #ifdef USE_ITHREADS 2983 if (chain->refcounted_he_keylen != 1) 2984 return NULL; 2985 if (*REF_HE_KEY(chain) != ':') 2986 return NULL; 2987 #else 2988 if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1) 2989 return NULL; 2990 if (*HEK_KEY(chain->refcounted_he_hek) != ':') 2991 return NULL; 2992 #endif 2993 /* Stop anyone trying to really mess us up by adding their own value for 2994 ':' into %^H */ 2995 if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV 2996 && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8) 2997 return NULL; 2998 2999 if (len) 3000 *len = chain->refcounted_he_val.refcounted_he_u_len; 3001 if (flags) { 3002 *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask) 3003 == HVrhek_PV_UTF8) ? SVf_UTF8 : 0; 3004 } 3005 return chain->refcounted_he_data + 1; 3006 } 3007 3008 /* As newSTATEOP currently gets passed plain char* labels, we will only provide 3009 that interface. Once it works out how to pass in length and UTF-8 ness, this 3010 function will need superseding. */ 3011 struct refcounted_he * 3012 Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label) 3013 { 3014 PERL_ARGS_ASSERT_STORE_COP_LABEL; 3015 3016 return refcounted_he_new_common(chain, ":", 1, HVrhek_PV, HVrhek_PV, 3017 label, strlen(label)); 3018 } 3019 3020 /* 3021 =for apidoc hv_assert 3022 3023 Check that a hash is in an internally consistent state. 3024 3025 =cut 3026 */ 3027 3028 #ifdef DEBUGGING 3029 3030 void 3031 Perl_hv_assert(pTHX_ HV *hv) 3032 { 3033 dVAR; 3034 HE* entry; 3035 int withflags = 0; 3036 int placeholders = 0; 3037 int real = 0; 3038 int bad = 0; 3039 const I32 riter = HvRITER_get(hv); 3040 HE *eiter = HvEITER_get(hv); 3041 3042 PERL_ARGS_ASSERT_HV_ASSERT; 3043 3044 (void)hv_iterinit(hv); 3045 3046 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { 3047 /* sanity check the values */ 3048 if (HeVAL(entry) == &PL_sv_placeholder) 3049 placeholders++; 3050 else 3051 real++; 3052 /* sanity check the keys */ 3053 if (HeSVKEY(entry)) { 3054 NOOP; /* Don't know what to check on SV keys. */ 3055 } else if (HeKUTF8(entry)) { 3056 withflags++; 3057 if (HeKWASUTF8(entry)) { 3058 PerlIO_printf(Perl_debug_log, 3059 "hash key has both WASUTF8 and UTF8: '%.*s'\n", 3060 (int) HeKLEN(entry), HeKEY(entry)); 3061 bad = 1; 3062 } 3063 } else if (HeKWASUTF8(entry)) 3064 withflags++; 3065 } 3066 if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) { 3067 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n"; 3068 const int nhashkeys = HvUSEDKEYS(hv); 3069 const int nhashplaceholders = HvPLACEHOLDERS_get(hv); 3070 3071 if (nhashkeys != real) { 3072 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys ); 3073 bad = 1; 3074 } 3075 if (nhashplaceholders != placeholders) { 3076 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders ); 3077 bad = 1; 3078 } 3079 } 3080 if (withflags && ! HvHASKFLAGS(hv)) { 3081 PerlIO_printf(Perl_debug_log, 3082 "Hash has HASKFLAGS off but I count %d key(s) with flags\n", 3083 withflags); 3084 bad = 1; 3085 } 3086 if (bad) { 3087 sv_dump(MUTABLE_SV(hv)); 3088 } 3089 HvRITER_set(hv, riter); /* Restore hash iterator state */ 3090 HvEITER_set(hv, eiter); 3091 } 3092 3093 #endif 3094 3095 /* 3096 * Local variables: 3097 * c-indentation-style: bsd 3098 * c-basic-offset: 4 3099 * indent-tabs-mode: t 3100 * End: 3101 * 3102 * ex: set ts=8 sts=4 sw=4 noet: 3103 */ 3104