1 /* hv.c 2 * 3 * Copyright (c) 1991-2002, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * "I sit beside the fire and think of all that I have seen." --Bilbo 12 */ 13 14 /* 15 =head1 Hash Manipulation Functions 16 */ 17 18 #include "EXTERN.h" 19 #define PERL_IN_HV_C 20 #include "perl.h" 21 22 STATIC HE* 23 S_new_he(pTHX) 24 { 25 HE* he; 26 LOCK_SV_MUTEX; 27 if (!PL_he_root) 28 more_he(); 29 he = PL_he_root; 30 PL_he_root = HeNEXT(he); 31 UNLOCK_SV_MUTEX; 32 return he; 33 } 34 35 STATIC void 36 S_del_he(pTHX_ HE *p) 37 { 38 LOCK_SV_MUTEX; 39 HeNEXT(p) = (HE*)PL_he_root; 40 PL_he_root = p; 41 UNLOCK_SV_MUTEX; 42 } 43 44 STATIC void 45 S_more_he(pTHX) 46 { 47 register HE* he; 48 register HE* heend; 49 XPV *ptr; 50 New(54, ptr, 1008/sizeof(XPV), XPV); 51 ptr->xpv_pv = (char*)PL_he_arenaroot; 52 PL_he_arenaroot = ptr; 53 54 he = (HE*)ptr; 55 heend = &he[1008 / sizeof(HE) - 1]; 56 PL_he_root = ++he; 57 while (he < heend) { 58 HeNEXT(he) = (HE*)(he + 1); 59 he++; 60 } 61 HeNEXT(he) = 0; 62 } 63 64 #ifdef PURIFY 65 66 #define new_HE() (HE*)safemalloc(sizeof(HE)) 67 #define del_HE(p) safefree((char*)p) 68 69 #else 70 71 #define new_HE() new_he() 72 #define del_HE(p) del_he(p) 73 74 #endif 75 76 STATIC HEK * 77 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) 78 { 79 char *k; 80 register HEK *hek; 81 82 New(54, k, HEK_BASESIZE + len + 2, char); 83 hek = (HEK*)k; 84 Copy(str, HEK_KEY(hek), len, char); 85 HEK_KEY(hek)[len] = 0; 86 HEK_LEN(hek) = len; 87 HEK_HASH(hek) = hash; 88 HEK_FLAGS(hek) = (unsigned char)flags; 89 return hek; 90 } 91 92 #if defined(USE_ITHREADS) 93 HE * 94 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) 95 { 96 HE *ret; 97 98 if (!e) 99 return Nullhe; 100 /* look for it in the table first */ 101 ret = (HE*)ptr_table_fetch(PL_ptr_table, e); 102 if (ret) 103 return ret; 104 105 /* create anew and remember what it is */ 106 ret = new_HE(); 107 ptr_table_store(PL_ptr_table, e, ret); 108 109 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param); 110 if (HeKLEN(e) == HEf_SVKEY) 111 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param)); 112 else if (shared) 113 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), 114 HeKFLAGS(e)); 115 else 116 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), 117 HeKFLAGS(e)); 118 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param)); 119 return ret; 120 } 121 #endif /* USE_ITHREADS */ 122 123 static void 124 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, 125 const char *msg) 126 { 127 SV *sv = sv_newmortal(), *esv = sv_newmortal(); 128 if (!(flags & HVhek_FREEKEY)) { 129 sv_setpvn(sv, key, klen); 130 } 131 else { 132 /* Need to free saved eventually assign to mortal SV */ 133 SV *sv = sv_newmortal(); 134 sv_usepvn(sv, (char *) key, klen); 135 } 136 if (flags & HVhek_UTF8) { 137 SvUTF8_on(sv); 138 } 139 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg); 140 Perl_croak(aTHX_ SvPVX(esv), sv); 141 } 142 143 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot 144 * contains an SV* */ 145 146 /* 147 =for apidoc hv_fetch 148 149 Returns the SV which corresponds to the specified key in the hash. The 150 C<klen> is the length of the key. If C<lval> is set then the fetch will be 151 part of a store. Check that the return value is non-null before 152 dereferencing it to an C<SV*>. 153 154 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more 155 information on how to use this function on tied hashes. 156 157 =cut 158 */ 159 160 161 SV** 162 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval) 163 { 164 bool is_utf8 = FALSE; 165 const char *keysave = key; 166 int flags = 0; 167 168 if (klen < 0) { 169 klen = -klen; 170 is_utf8 = TRUE; 171 } 172 173 if (is_utf8) { 174 STRLEN tmplen = klen; 175 /* Just casting the &klen to (STRLEN) won't work well 176 * if STRLEN and I32 are of different widths. --jhi */ 177 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8); 178 klen = tmplen; 179 /* If we were able to downgrade here, then than means that we were 180 passed in a key which only had chars 0-255, but was utf8 encoded. */ 181 if (is_utf8) 182 flags = HVhek_UTF8; 183 /* If we found we were able to downgrade the string to bytes, then 184 we should flag that it needs upgrading on keys or each. */ 185 if (key != keysave) 186 flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 187 } 188 189 return hv_fetch_flags (hv, key, klen, lval, flags); 190 } 191 192 STATIC SV** 193 S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags) 194 { 195 register XPVHV* xhv; 196 register U32 hash; 197 register HE *entry; 198 SV *sv; 199 200 if (!hv) 201 return 0; 202 203 if (SvRMAGICAL(hv)) { 204 /* All this clause seems to be utf8 unaware. 205 By moving the utf8 stuff out to hv_fetch_flags I need to ensure 206 key doesn't leak. I've not tried solving the utf8-ness. 207 NWC. 208 */ 209 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { 210 sv = sv_newmortal(); 211 mg_copy((SV*)hv, sv, key, klen); 212 if (flags & HVhek_FREEKEY) 213 Safefree(key); 214 PL_hv_fetch_sv = sv; 215 return &PL_hv_fetch_sv; 216 } 217 #ifdef ENV_IS_CASELESS 218 else if (mg_find((SV*)hv, PERL_MAGIC_env)) { 219 I32 i; 220 for (i = 0; i < klen; ++i) 221 if (isLOWER(key[i])) { 222 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen)))); 223 SV **ret = hv_fetch(hv, nkey, klen, 0); 224 if (!ret && lval) { 225 ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0, 226 flags); 227 } else if (flags & HVhek_FREEKEY) 228 Safefree(key); 229 return ret; 230 } 231 } 232 #endif 233 } 234 235 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to 236 avoid unnecessary pointer dereferencing. */ 237 xhv = (XPVHV*)SvANY(hv); 238 if (!xhv->xhv_array /* !HvARRAY(hv) */) { 239 if (lval 240 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ 241 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) 242 #endif 243 ) 244 Newz(503, xhv->xhv_array /* HvARRAY(hv) */, 245 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), 246 char); 247 else { 248 if (flags & HVhek_FREEKEY) 249 Safefree(key); 250 return 0; 251 } 252 } 253 254 PERL_HASH(hash, key, klen); 255 256 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 257 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 258 for (; entry; entry = HeNEXT(entry)) { 259 if (HeHASH(entry) != hash) /* strings can't be equal */ 260 continue; 261 if (HeKLEN(entry) != (I32)klen) 262 continue; 263 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 264 continue; 265 /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0. 266 flags is 1 if utf8. need HeKFLAGS(entry) also 1. 267 xor is true if bits differ, in which case this isn't a match. */ 268 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8) 269 continue; 270 if (lval && HeKFLAGS(entry) != flags) { 271 /* We match if HVhek_UTF8 bit in our flags and hash key's match. 272 But if entry was set previously with HVhek_WASUTF8 and key now 273 doesn't (or vice versa) then we should change the key's flag, 274 as this is assignment. */ 275 if (HvSHAREKEYS(hv)) { 276 /* Need to swap the key we have for a key with the flags we 277 need. As keys are shared we can't just write to the flag, 278 so we share the new one, unshare the old one. */ 279 int flags_nofree = flags & ~HVhek_FREEKEY; 280 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree); 281 unshare_hek (HeKEY_hek(entry)); 282 HeKEY_hek(entry) = new_hek; 283 } 284 else 285 HeKFLAGS(entry) = flags; 286 } 287 if (flags & HVhek_FREEKEY) 288 Safefree(key); 289 /* if we find a placeholder, we pretend we haven't found anything */ 290 if (HeVAL(entry) == &PL_sv_undef) 291 break; 292 return &HeVAL(entry); 293 294 } 295 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ 296 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { 297 unsigned long len; 298 char *env = PerlEnv_ENVgetenv_len(key,&len); 299 if (env) { 300 sv = newSVpvn(env,len); 301 SvTAINTED_on(sv); 302 if (flags & HVhek_FREEKEY) 303 Safefree(key); 304 return hv_store(hv,key,klen,sv,hash); 305 } 306 } 307 #endif 308 if (!entry && SvREADONLY(hv)) { 309 S_hv_notallowed(aTHX_ flags, key, klen, 310 "access disallowed key '%"SVf"' in" 311 ); 312 } 313 if (lval) { /* gonna assign to this, so it better be there */ 314 sv = NEWSV(61,0); 315 return hv_store_flags(hv,key,klen,sv,hash,flags); 316 } 317 if (flags & HVhek_FREEKEY) 318 Safefree(key); 319 return 0; 320 } 321 322 /* returns an HE * structure with the all fields set */ 323 /* note that hent_val will be a mortal sv for MAGICAL hashes */ 324 /* 325 =for apidoc hv_fetch_ent 326 327 Returns the hash entry which corresponds to the specified key in the hash. 328 C<hash> must be a valid precomputed hash number for the given C<key>, or 0 329 if you want the function to compute it. IF C<lval> is set then the fetch 330 will be part of a store. Make sure the return value is non-null before 331 accessing it. The return value when C<tb> is a tied hash is a pointer to a 332 static location, so be sure to make a copy of the structure if you need to 333 store it somewhere. 334 335 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more 336 information on how to use this function on tied hashes. 337 338 =cut 339 */ 340 341 HE * 342 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) 343 { 344 register XPVHV* xhv; 345 register char *key; 346 STRLEN klen; 347 register HE *entry; 348 SV *sv; 349 bool is_utf8; 350 int flags = 0; 351 char *keysave; 352 353 if (!hv) 354 return 0; 355 356 if (SvRMAGICAL(hv)) { 357 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { 358 sv = sv_newmortal(); 359 keysv = sv_2mortal(newSVsv(keysv)); 360 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); 361 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) { 362 char *k; 363 New(54, k, HEK_BASESIZE + sizeof(SV*), char); 364 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k; 365 } 366 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv); 367 HeVAL(&PL_hv_fetch_ent_mh) = sv; 368 return &PL_hv_fetch_ent_mh; 369 } 370 #ifdef ENV_IS_CASELESS 371 else if (mg_find((SV*)hv, PERL_MAGIC_env)) { 372 U32 i; 373 key = SvPV(keysv, klen); 374 for (i = 0; i < klen; ++i) 375 if (isLOWER(key[i])) { 376 SV *nkeysv = sv_2mortal(newSVpvn(key,klen)); 377 (void)strupr(SvPVX(nkeysv)); 378 entry = hv_fetch_ent(hv, nkeysv, 0, 0); 379 if (!entry && lval) 380 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash); 381 return entry; 382 } 383 } 384 #endif 385 } 386 387 xhv = (XPVHV*)SvANY(hv); 388 if (!xhv->xhv_array /* !HvARRAY(hv) */) { 389 if (lval 390 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ 391 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) 392 #endif 393 ) 394 Newz(503, xhv->xhv_array /* HvARRAY(hv) */, 395 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), 396 char); 397 else 398 return 0; 399 } 400 401 keysave = key = SvPV(keysv, klen); 402 is_utf8 = (SvUTF8(keysv)!=0); 403 404 if (is_utf8) { 405 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); 406 if (is_utf8) 407 flags = HVhek_UTF8; 408 if (key != keysave) 409 flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 410 } 411 412 if (!hash) 413 PERL_HASH(hash, key, klen); 414 415 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 416 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 417 for (; entry; entry = HeNEXT(entry)) { 418 if (HeHASH(entry) != hash) /* strings can't be equal */ 419 continue; 420 if (HeKLEN(entry) != (I32)klen) 421 continue; 422 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 423 continue; 424 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8) 425 continue; 426 if (lval && HeKFLAGS(entry) != flags) { 427 /* We match if HVhek_UTF8 bit in our flags and hash key's match. 428 But if entry was set previously with HVhek_WASUTF8 and key now 429 doesn't (or vice versa) then we should change the key's flag, 430 as this is assignment. */ 431 if (HvSHAREKEYS(hv)) { 432 /* Need to swap the key we have for a key with the flags we 433 need. As keys are shared we can't just write to the flag, 434 so we share the new one, unshare the old one. */ 435 int flags_nofree = flags & ~HVhek_FREEKEY; 436 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree); 437 unshare_hek (HeKEY_hek(entry)); 438 HeKEY_hek(entry) = new_hek; 439 } 440 else 441 HeKFLAGS(entry) = flags; 442 } 443 if (key != keysave) 444 Safefree(key); 445 /* if we find a placeholder, we pretend we haven't found anything */ 446 if (HeVAL(entry) == &PL_sv_undef) 447 break; 448 return entry; 449 } 450 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ 451 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { 452 unsigned long len; 453 char *env = PerlEnv_ENVgetenv_len(key,&len); 454 if (env) { 455 sv = newSVpvn(env,len); 456 SvTAINTED_on(sv); 457 return hv_store_ent(hv,keysv,sv,hash); 458 } 459 } 460 #endif 461 if (!entry && SvREADONLY(hv)) { 462 S_hv_notallowed(aTHX_ flags, key, klen, 463 "access disallowed key '%"SVf"' in" 464 ); 465 } 466 if (flags & HVhek_FREEKEY) 467 Safefree(key); 468 if (lval) { /* gonna assign to this, so it better be there */ 469 sv = NEWSV(61,0); 470 return hv_store_ent(hv,keysv,sv,hash); 471 } 472 return 0; 473 } 474 475 STATIC void 476 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store) 477 { 478 MAGIC *mg = SvMAGIC(hv); 479 *needs_copy = FALSE; 480 *needs_store = TRUE; 481 while (mg) { 482 if (isUPPER(mg->mg_type)) { 483 *needs_copy = TRUE; 484 switch (mg->mg_type) { 485 case PERL_MAGIC_tied: 486 case PERL_MAGIC_sig: 487 *needs_store = FALSE; 488 } 489 } 490 mg = mg->mg_moremagic; 491 } 492 } 493 494 /* 495 =for apidoc hv_store 496 497 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is 498 the length of the key. The C<hash> parameter is the precomputed hash 499 value; if it is zero then Perl will compute it. The return value will be 500 NULL if the operation failed or if the value did not need to be actually 501 stored within the hash (as in the case of tied hashes). Otherwise it can 502 be dereferenced to get the original C<SV*>. Note that the caller is 503 responsible for suitably incrementing the reference count of C<val> before 504 the call, and decrementing it if the function returned NULL. 505 506 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more 507 information on how to use this function on tied hashes. 508 509 =cut 510 */ 511 512 SV** 513 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash) 514 { 515 bool is_utf8 = FALSE; 516 const char *keysave = key; 517 int flags = 0; 518 519 if (klen < 0) { 520 klen = -klen; 521 is_utf8 = TRUE; 522 } 523 524 if (is_utf8) { 525 STRLEN tmplen = klen; 526 /* Just casting the &klen to (STRLEN) won't work well 527 * if STRLEN and I32 are of different widths. --jhi */ 528 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8); 529 klen = tmplen; 530 /* If we were able to downgrade here, then than means that we were 531 passed in a key which only had chars 0-255, but was utf8 encoded. */ 532 if (is_utf8) 533 flags = HVhek_UTF8; 534 /* If we found we were able to downgrade the string to bytes, then 535 we should flag that it needs upgrading on keys or each. */ 536 if (key != keysave) 537 flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 538 } 539 540 return hv_store_flags (hv, key, klen, val, hash, flags); 541 } 542 543 SV** 544 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, 545 register U32 hash, int flags) 546 { 547 register XPVHV* xhv; 548 register I32 i; 549 register HE *entry; 550 register HE **oentry; 551 552 if (!hv) 553 return 0; 554 555 xhv = (XPVHV*)SvANY(hv); 556 if (SvMAGICAL(hv)) { 557 bool needs_copy; 558 bool needs_store; 559 hv_magic_check (hv, &needs_copy, &needs_store); 560 if (needs_copy) { 561 mg_copy((SV*)hv, val, key, klen); 562 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) { 563 if (flags & HVhek_FREEKEY) 564 Safefree(key); 565 return 0; 566 } 567 #ifdef ENV_IS_CASELESS 568 else if (mg_find((SV*)hv, PERL_MAGIC_env)) { 569 key = savepvn(key,klen); 570 key = (const char*)strupr((char*)key); 571 hash = 0; 572 } 573 #endif 574 } 575 } 576 577 if (flags) 578 HvHASKFLAGS_on((SV*)hv); 579 580 if (!hash) 581 PERL_HASH(hash, key, klen); 582 583 if (!xhv->xhv_array /* !HvARRAY(hv) */) 584 Newz(505, xhv->xhv_array /* HvARRAY(hv) */, 585 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), 586 char); 587 588 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 589 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 590 i = 1; 591 592 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) { 593 if (HeHASH(entry) != hash) /* strings can't be equal */ 594 continue; 595 if (HeKLEN(entry) != (I32)klen) 596 continue; 597 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 598 continue; 599 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8) 600 continue; 601 if (HeVAL(entry) == &PL_sv_undef) 602 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */ 603 else 604 SvREFCNT_dec(HeVAL(entry)); 605 if (flags & HVhek_PLACEHOLD) { 606 /* We have been requested to insert a placeholder. Currently 607 only Storable is allowed to do this. */ 608 xhv->xhv_placeholders++; 609 HeVAL(entry) = &PL_sv_undef; 610 } else 611 HeVAL(entry) = val; 612 613 if (HeKFLAGS(entry) != flags) { 614 /* We match if HVhek_UTF8 bit in our flags and hash key's match. 615 But if entry was set previously with HVhek_WASUTF8 and key now 616 doesn't (or vice versa) then we should change the key's flag, 617 as this is assignment. */ 618 if (HvSHAREKEYS(hv)) { 619 /* Need to swap the key we have for a key with the flags we 620 need. As keys are shared we can't just write to the flag, 621 so we share the new one, unshare the old one. */ 622 int flags_nofree = flags & ~HVhek_FREEKEY; 623 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree); 624 unshare_hek (HeKEY_hek(entry)); 625 HeKEY_hek(entry) = new_hek; 626 } 627 else 628 HeKFLAGS(entry) = flags; 629 } 630 if (flags & HVhek_FREEKEY) 631 Safefree(key); 632 return &HeVAL(entry); 633 } 634 635 if (SvREADONLY(hv)) { 636 S_hv_notallowed(aTHX_ flags, key, klen, 637 "access disallowed key '%"SVf"' to" 638 ); 639 } 640 641 entry = new_HE(); 642 /* share_hek_flags will do the free for us. This might be considered 643 bad API design. */ 644 if (HvSHAREKEYS(hv)) 645 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); 646 else /* gotta do the real thing */ 647 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); 648 if (flags & HVhek_PLACEHOLD) { 649 /* We have been requested to insert a placeholder. Currently 650 only Storable is allowed to do this. */ 651 xhv->xhv_placeholders++; 652 HeVAL(entry) = &PL_sv_undef; 653 } else 654 HeVAL(entry) = val; 655 HeNEXT(entry) = *oentry; 656 *oentry = entry; 657 658 xhv->xhv_keys++; /* HvKEYS(hv)++ */ 659 if (i) { /* initial entry? */ 660 xhv->xhv_fill++; /* HvFILL(hv)++ */ 661 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) 662 hsplit(hv); 663 } 664 665 return &HeVAL(entry); 666 } 667 668 /* 669 =for apidoc hv_store_ent 670 671 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash> 672 parameter is the precomputed hash value; if it is zero then Perl will 673 compute it. The return value is the new hash entry so created. It will be 674 NULL if the operation failed or if the value did not need to be actually 675 stored within the hash (as in the case of tied hashes). Otherwise the 676 contents of the return value can be accessed using the C<He?> macros 677 described here. Note that the caller is responsible for suitably 678 incrementing the reference count of C<val> before the call, and 679 decrementing it if the function returned NULL. 680 681 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more 682 information on how to use this function on tied hashes. 683 684 =cut 685 */ 686 687 HE * 688 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) 689 { 690 XPVHV* xhv; 691 char *key; 692 STRLEN klen; 693 I32 i; 694 HE *entry; 695 HE **oentry; 696 bool is_utf8; 697 int flags = 0; 698 char *keysave; 699 700 if (!hv) 701 return 0; 702 703 xhv = (XPVHV*)SvANY(hv); 704 if (SvMAGICAL(hv)) { 705 bool needs_copy; 706 bool needs_store; 707 hv_magic_check (hv, &needs_copy, &needs_store); 708 if (needs_copy) { 709 bool save_taint = PL_tainted; 710 if (PL_tainting) 711 PL_tainted = SvTAINTED(keysv); 712 keysv = sv_2mortal(newSVsv(keysv)); 713 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY); 714 TAINT_IF(save_taint); 715 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) 716 return Nullhe; 717 #ifdef ENV_IS_CASELESS 718 else if (mg_find((SV*)hv, PERL_MAGIC_env)) { 719 key = SvPV(keysv, klen); 720 keysv = sv_2mortal(newSVpvn(key,klen)); 721 (void)strupr(SvPVX(keysv)); 722 hash = 0; 723 } 724 #endif 725 } 726 } 727 728 keysave = key = SvPV(keysv, klen); 729 is_utf8 = (SvUTF8(keysv) != 0); 730 731 if (is_utf8) { 732 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); 733 if (is_utf8) 734 flags = HVhek_UTF8; 735 if (key != keysave) 736 flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 737 HvHASKFLAGS_on((SV*)hv); 738 } 739 740 if (!hash) 741 PERL_HASH(hash, key, klen); 742 743 if (!xhv->xhv_array /* !HvARRAY(hv) */) 744 Newz(505, xhv->xhv_array /* HvARRAY(hv) */, 745 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), 746 char); 747 748 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 749 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 750 i = 1; 751 entry = *oentry; 752 for (; entry; i=0, entry = HeNEXT(entry)) { 753 if (HeHASH(entry) != hash) /* strings can't be equal */ 754 continue; 755 if (HeKLEN(entry) != (I32)klen) 756 continue; 757 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 758 continue; 759 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8) 760 continue; 761 if (HeVAL(entry) == &PL_sv_undef) 762 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */ 763 else 764 SvREFCNT_dec(HeVAL(entry)); 765 HeVAL(entry) = val; 766 if (HeKFLAGS(entry) != flags) { 767 /* We match if HVhek_UTF8 bit in our flags and hash key's match. 768 But if entry was set previously with HVhek_WASUTF8 and key now 769 doesn't (or vice versa) then we should change the key's flag, 770 as this is assignment. */ 771 if (HvSHAREKEYS(hv)) { 772 /* Need to swap the key we have for a key with the flags we 773 need. As keys are shared we can't just write to the flag, 774 so we share the new one, unshare the old one. */ 775 int flags_nofree = flags & ~HVhek_FREEKEY; 776 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree); 777 unshare_hek (HeKEY_hek(entry)); 778 HeKEY_hek(entry) = new_hek; 779 } 780 else 781 HeKFLAGS(entry) = flags; 782 } 783 if (flags & HVhek_FREEKEY) 784 Safefree(key); 785 return entry; 786 } 787 788 if (SvREADONLY(hv)) { 789 S_hv_notallowed(aTHX_ flags, key, klen, 790 "access disallowed key '%"SVf"' to" 791 ); 792 } 793 794 entry = new_HE(); 795 /* share_hek_flags will do the free for us. This might be considered 796 bad API design. */ 797 if (HvSHAREKEYS(hv)) 798 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); 799 else /* gotta do the real thing */ 800 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); 801 HeVAL(entry) = val; 802 HeNEXT(entry) = *oentry; 803 *oentry = entry; 804 805 xhv->xhv_keys++; /* HvKEYS(hv)++ */ 806 if (i) { /* initial entry? */ 807 xhv->xhv_fill++; /* HvFILL(hv)++ */ 808 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) 809 hsplit(hv); 810 } 811 812 return entry; 813 } 814 815 /* 816 =for apidoc hv_delete 817 818 Deletes a key/value pair in the hash. The value SV is removed from the 819 hash and returned to the caller. The C<klen> is the length of the key. 820 The C<flags> value will normally be zero; if set to G_DISCARD then NULL 821 will be returned. 822 823 =cut 824 */ 825 826 SV * 827 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) 828 { 829 register XPVHV* xhv; 830 register I32 i; 831 register U32 hash; 832 register HE *entry; 833 register HE **oentry; 834 SV **svp; 835 SV *sv; 836 bool is_utf8 = FALSE; 837 int k_flags = 0; 838 const char *keysave = key; 839 840 if (!hv) 841 return Nullsv; 842 if (klen < 0) { 843 klen = -klen; 844 is_utf8 = TRUE; 845 } 846 if (SvRMAGICAL(hv)) { 847 bool needs_copy; 848 bool needs_store; 849 hv_magic_check (hv, &needs_copy, &needs_store); 850 851 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) { 852 sv = *svp; 853 mg_clear(sv); 854 if (!needs_store) { 855 if (mg_find(sv, PERL_MAGIC_tiedelem)) { 856 /* No longer an element */ 857 sv_unmagic(sv, PERL_MAGIC_tiedelem); 858 return sv; 859 } 860 return Nullsv; /* element cannot be deleted */ 861 } 862 #ifdef ENV_IS_CASELESS 863 else if (mg_find((SV*)hv, PERL_MAGIC_env)) { 864 sv = sv_2mortal(newSVpvn(key,klen)); 865 key = strupr(SvPVX(sv)); 866 } 867 #endif 868 } 869 } 870 xhv = (XPVHV*)SvANY(hv); 871 if (!xhv->xhv_array /* !HvARRAY(hv) */) 872 return Nullsv; 873 874 if (is_utf8) { 875 STRLEN tmplen = klen; 876 /* See the note in hv_fetch(). --jhi */ 877 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8); 878 klen = tmplen; 879 if (is_utf8) 880 k_flags = HVhek_UTF8; 881 if (key != keysave) 882 k_flags |= HVhek_FREEKEY; 883 } 884 885 PERL_HASH(hash, key, klen); 886 887 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 888 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 889 entry = *oentry; 890 i = 1; 891 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { 892 if (HeHASH(entry) != hash) /* strings can't be equal */ 893 continue; 894 if (HeKLEN(entry) != (I32)klen) 895 continue; 896 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 897 continue; 898 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8) 899 continue; 900 if (k_flags & HVhek_FREEKEY) 901 Safefree(key); 902 /* if placeholder is here, it's already been deleted.... */ 903 if (HeVAL(entry) == &PL_sv_undef) 904 { 905 if (SvREADONLY(hv)) 906 return Nullsv; /* if still SvREADONLY, leave it deleted. */ 907 else { 908 /* okay, really delete the placeholder... */ 909 *oentry = HeNEXT(entry); 910 if (i && !*oentry) 911 xhv->xhv_fill--; /* HvFILL(hv)-- */ 912 if (entry == xhv->xhv_eiter /* HvEITER(hv) */) 913 HvLAZYDEL_on(hv); 914 else 915 hv_free_ent(hv, entry); 916 xhv->xhv_keys--; /* HvKEYS(hv)-- */ 917 if (xhv->xhv_keys == 0) 918 HvHASKFLAGS_off(hv); 919 xhv->xhv_placeholders--; 920 return Nullsv; 921 } 922 } 923 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { 924 S_hv_notallowed(aTHX_ k_flags, key, klen, 925 "delete readonly key '%"SVf"' from" 926 ); 927 } 928 929 if (flags & G_DISCARD) 930 sv = Nullsv; 931 else { 932 sv = sv_2mortal(HeVAL(entry)); 933 HeVAL(entry) = &PL_sv_undef; 934 } 935 936 /* 937 * If a restricted hash, rather than really deleting the entry, put 938 * a placeholder there. This marks the key as being "approved", so 939 * we can still access via not-really-existing key without raising 940 * an error. 941 */ 942 if (SvREADONLY(hv)) { 943 HeVAL(entry) = &PL_sv_undef; 944 /* We'll be saving this slot, so the number of allocated keys 945 * doesn't go down, but the number placeholders goes up */ 946 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */ 947 } else { 948 *oentry = HeNEXT(entry); 949 if (i && !*oentry) 950 xhv->xhv_fill--; /* HvFILL(hv)-- */ 951 if (entry == xhv->xhv_eiter /* HvEITER(hv) */) 952 HvLAZYDEL_on(hv); 953 else 954 hv_free_ent(hv, entry); 955 xhv->xhv_keys--; /* HvKEYS(hv)-- */ 956 if (xhv->xhv_keys == 0) 957 HvHASKFLAGS_off(hv); 958 } 959 return sv; 960 } 961 if (SvREADONLY(hv)) { 962 S_hv_notallowed(aTHX_ k_flags, key, klen, 963 "access disallowed key '%"SVf"' from" 964 ); 965 } 966 967 if (k_flags & HVhek_FREEKEY) 968 Safefree(key); 969 return Nullsv; 970 } 971 972 /* 973 =for apidoc hv_delete_ent 974 975 Deletes a key/value pair in the hash. The value SV is removed from the 976 hash and returned to the caller. The C<flags> value will normally be zero; 977 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid 978 precomputed hash value, or 0 to ask for it to be computed. 979 980 =cut 981 */ 982 983 SV * 984 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) 985 { 986 register XPVHV* xhv; 987 register I32 i; 988 register char *key; 989 STRLEN klen; 990 register HE *entry; 991 register HE **oentry; 992 SV *sv; 993 bool is_utf8; 994 int k_flags = 0; 995 char *keysave; 996 997 if (!hv) 998 return Nullsv; 999 if (SvRMAGICAL(hv)) { 1000 bool needs_copy; 1001 bool needs_store; 1002 hv_magic_check (hv, &needs_copy, &needs_store); 1003 1004 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) { 1005 sv = HeVAL(entry); 1006 mg_clear(sv); 1007 if (!needs_store) { 1008 if (mg_find(sv, PERL_MAGIC_tiedelem)) { 1009 /* No longer an element */ 1010 sv_unmagic(sv, PERL_MAGIC_tiedelem); 1011 return sv; 1012 } 1013 return Nullsv; /* element cannot be deleted */ 1014 } 1015 #ifdef ENV_IS_CASELESS 1016 else if (mg_find((SV*)hv, PERL_MAGIC_env)) { 1017 key = SvPV(keysv, klen); 1018 keysv = sv_2mortal(newSVpvn(key,klen)); 1019 (void)strupr(SvPVX(keysv)); 1020 hash = 0; 1021 } 1022 #endif 1023 } 1024 } 1025 xhv = (XPVHV*)SvANY(hv); 1026 if (!xhv->xhv_array /* !HvARRAY(hv) */) 1027 return Nullsv; 1028 1029 keysave = key = SvPV(keysv, klen); 1030 is_utf8 = (SvUTF8(keysv) != 0); 1031 1032 if (is_utf8) { 1033 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); 1034 if (is_utf8) 1035 k_flags = HVhek_UTF8; 1036 if (key != keysave) 1037 k_flags |= HVhek_FREEKEY; 1038 } 1039 1040 if (!hash) 1041 PERL_HASH(hash, key, klen); 1042 1043 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 1044 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 1045 entry = *oentry; 1046 i = 1; 1047 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { 1048 if (HeHASH(entry) != hash) /* strings can't be equal */ 1049 continue; 1050 if (HeKLEN(entry) != (I32)klen) 1051 continue; 1052 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 1053 continue; 1054 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8) 1055 continue; 1056 if (k_flags & HVhek_FREEKEY) 1057 Safefree(key); 1058 1059 /* if placeholder is here, it's already been deleted.... */ 1060 if (HeVAL(entry) == &PL_sv_undef) 1061 { 1062 if (SvREADONLY(hv)) 1063 return Nullsv; /* if still SvREADONLY, leave it deleted. */ 1064 1065 /* okay, really delete the placeholder. */ 1066 *oentry = HeNEXT(entry); 1067 if (i && !*oentry) 1068 xhv->xhv_fill--; /* HvFILL(hv)-- */ 1069 if (entry == xhv->xhv_eiter /* HvEITER(hv) */) 1070 HvLAZYDEL_on(hv); 1071 else 1072 hv_free_ent(hv, entry); 1073 xhv->xhv_keys--; /* HvKEYS(hv)-- */ 1074 if (xhv->xhv_keys == 0) 1075 HvHASKFLAGS_off(hv); 1076 xhv->xhv_placeholders--; 1077 return Nullsv; 1078 } 1079 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { 1080 S_hv_notallowed(aTHX_ k_flags, key, klen, 1081 "delete readonly key '%"SVf"' from" 1082 ); 1083 } 1084 1085 if (flags & G_DISCARD) 1086 sv = Nullsv; 1087 else { 1088 sv = sv_2mortal(HeVAL(entry)); 1089 HeVAL(entry) = &PL_sv_undef; 1090 } 1091 1092 /* 1093 * If a restricted hash, rather than really deleting the entry, put 1094 * a placeholder there. This marks the key as being "approved", so 1095 * we can still access via not-really-existing key without raising 1096 * an error. 1097 */ 1098 if (SvREADONLY(hv)) { 1099 HeVAL(entry) = &PL_sv_undef; 1100 /* We'll be saving this slot, so the number of allocated keys 1101 * doesn't go down, but the number placeholders goes up */ 1102 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */ 1103 } else { 1104 *oentry = HeNEXT(entry); 1105 if (i && !*oentry) 1106 xhv->xhv_fill--; /* HvFILL(hv)-- */ 1107 if (entry == xhv->xhv_eiter /* HvEITER(hv) */) 1108 HvLAZYDEL_on(hv); 1109 else 1110 hv_free_ent(hv, entry); 1111 xhv->xhv_keys--; /* HvKEYS(hv)-- */ 1112 if (xhv->xhv_keys == 0) 1113 HvHASKFLAGS_off(hv); 1114 } 1115 return sv; 1116 } 1117 if (SvREADONLY(hv)) { 1118 S_hv_notallowed(aTHX_ k_flags, key, klen, 1119 "delete disallowed key '%"SVf"' from" 1120 ); 1121 } 1122 1123 if (k_flags & HVhek_FREEKEY) 1124 Safefree(key); 1125 return Nullsv; 1126 } 1127 1128 /* 1129 =for apidoc hv_exists 1130 1131 Returns a boolean indicating whether the specified hash key exists. The 1132 C<klen> is the length of the key. 1133 1134 =cut 1135 */ 1136 1137 bool 1138 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen) 1139 { 1140 register XPVHV* xhv; 1141 register U32 hash; 1142 register HE *entry; 1143 SV *sv; 1144 bool is_utf8 = FALSE; 1145 const char *keysave = key; 1146 int k_flags = 0; 1147 1148 if (!hv) 1149 return 0; 1150 1151 if (klen < 0) { 1152 klen = -klen; 1153 is_utf8 = TRUE; 1154 } 1155 1156 if (SvRMAGICAL(hv)) { 1157 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { 1158 sv = sv_newmortal(); 1159 mg_copy((SV*)hv, sv, key, klen); 1160 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem)); 1161 return (bool)SvTRUE(sv); 1162 } 1163 #ifdef ENV_IS_CASELESS 1164 else if (mg_find((SV*)hv, PERL_MAGIC_env)) { 1165 sv = sv_2mortal(newSVpvn(key,klen)); 1166 key = strupr(SvPVX(sv)); 1167 } 1168 #endif 1169 } 1170 1171 xhv = (XPVHV*)SvANY(hv); 1172 #ifndef DYNAMIC_ENV_FETCH 1173 if (!xhv->xhv_array /* !HvARRAY(hv) */) 1174 return 0; 1175 #endif 1176 1177 if (is_utf8) { 1178 STRLEN tmplen = klen; 1179 /* See the note in hv_fetch(). --jhi */ 1180 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8); 1181 klen = tmplen; 1182 if (is_utf8) 1183 k_flags = HVhek_UTF8; 1184 if (key != keysave) 1185 k_flags |= HVhek_FREEKEY; 1186 } 1187 1188 PERL_HASH(hash, key, klen); 1189 1190 #ifdef DYNAMIC_ENV_FETCH 1191 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*); 1192 else 1193 #endif 1194 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 1195 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 1196 for (; entry; entry = HeNEXT(entry)) { 1197 if (HeHASH(entry) != hash) /* strings can't be equal */ 1198 continue; 1199 if (HeKLEN(entry) != klen) 1200 continue; 1201 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 1202 continue; 1203 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8) 1204 continue; 1205 if (k_flags & HVhek_FREEKEY) 1206 Safefree(key); 1207 /* If we find the key, but the value is a placeholder, return false. */ 1208 if (HeVAL(entry) == &PL_sv_undef) 1209 return FALSE; 1210 1211 return TRUE; 1212 } 1213 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */ 1214 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { 1215 unsigned long len; 1216 char *env = PerlEnv_ENVgetenv_len(key,&len); 1217 if (env) { 1218 sv = newSVpvn(env,len); 1219 SvTAINTED_on(sv); 1220 (void)hv_store(hv,key,klen,sv,hash); 1221 if (k_flags & HVhek_FREEKEY) 1222 Safefree(key); 1223 return TRUE; 1224 } 1225 } 1226 #endif 1227 if (k_flags & HVhek_FREEKEY) 1228 Safefree(key); 1229 return FALSE; 1230 } 1231 1232 1233 /* 1234 =for apidoc hv_exists_ent 1235 1236 Returns a boolean indicating whether the specified hash key exists. C<hash> 1237 can be a valid precomputed hash value, or 0 to ask for it to be 1238 computed. 1239 1240 =cut 1241 */ 1242 1243 bool 1244 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) 1245 { 1246 register XPVHV* xhv; 1247 register char *key; 1248 STRLEN klen; 1249 register HE *entry; 1250 SV *sv; 1251 bool is_utf8; 1252 char *keysave; 1253 int k_flags = 0; 1254 1255 if (!hv) 1256 return 0; 1257 1258 if (SvRMAGICAL(hv)) { 1259 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { 1260 SV* svret = sv_newmortal(); 1261 sv = sv_newmortal(); 1262 keysv = sv_2mortal(newSVsv(keysv)); 1263 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); 1264 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem)); 1265 return (bool)SvTRUE(svret); 1266 } 1267 #ifdef ENV_IS_CASELESS 1268 else if (mg_find((SV*)hv, PERL_MAGIC_env)) { 1269 key = SvPV(keysv, klen); 1270 keysv = sv_2mortal(newSVpvn(key,klen)); 1271 (void)strupr(SvPVX(keysv)); 1272 hash = 0; 1273 } 1274 #endif 1275 } 1276 1277 xhv = (XPVHV*)SvANY(hv); 1278 #ifndef DYNAMIC_ENV_FETCH 1279 if (!xhv->xhv_array /* !HvARRAY(hv) */) 1280 return 0; 1281 #endif 1282 1283 keysave = key = SvPV(keysv, klen); 1284 is_utf8 = (SvUTF8(keysv) != 0); 1285 if (is_utf8) { 1286 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); 1287 if (is_utf8) 1288 k_flags = HVhek_UTF8; 1289 if (key != keysave) 1290 k_flags |= HVhek_FREEKEY; 1291 } 1292 if (!hash) 1293 PERL_HASH(hash, key, klen); 1294 1295 #ifdef DYNAMIC_ENV_FETCH 1296 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*); 1297 else 1298 #endif 1299 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 1300 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 1301 for (; entry; entry = HeNEXT(entry)) { 1302 if (HeHASH(entry) != hash) /* strings can't be equal */ 1303 continue; 1304 if (HeKLEN(entry) != (I32)klen) 1305 continue; 1306 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ 1307 continue; 1308 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8) 1309 continue; 1310 if (k_flags & HVhek_FREEKEY) 1311 Safefree(key); 1312 /* If we find the key, but the value is a placeholder, return false. */ 1313 if (HeVAL(entry) == &PL_sv_undef) 1314 return FALSE; 1315 return TRUE; 1316 } 1317 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */ 1318 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { 1319 unsigned long len; 1320 char *env = PerlEnv_ENVgetenv_len(key,&len); 1321 if (env) { 1322 sv = newSVpvn(env,len); 1323 SvTAINTED_on(sv); 1324 (void)hv_store_ent(hv,keysv,sv,hash); 1325 if (k_flags & HVhek_FREEKEY) 1326 Safefree(key); 1327 return TRUE; 1328 } 1329 } 1330 #endif 1331 if (k_flags & HVhek_FREEKEY) 1332 Safefree(key); 1333 return FALSE; 1334 } 1335 1336 STATIC void 1337 S_hsplit(pTHX_ HV *hv) 1338 { 1339 register XPVHV* xhv = (XPVHV*)SvANY(hv); 1340 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ 1341 register I32 newsize = oldsize * 2; 1342 register I32 i; 1343 register char *a = xhv->xhv_array; /* HvARRAY(hv) */ 1344 register HE **aep; 1345 register HE **bep; 1346 register HE *entry; 1347 register HE **oentry; 1348 1349 PL_nomemok = TRUE; 1350 #if defined(STRANGE_MALLOC) || defined(MYMALLOC) 1351 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); 1352 if (!a) { 1353 PL_nomemok = FALSE; 1354 return; 1355 } 1356 #else 1357 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); 1358 if (!a) { 1359 PL_nomemok = FALSE; 1360 return; 1361 } 1362 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char); 1363 if (oldsize >= 64) { 1364 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */, 1365 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)); 1366 } 1367 else 1368 Safefree(xhv->xhv_array /* HvARRAY(hv) */); 1369 #endif 1370 1371 PL_nomemok = FALSE; 1372 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ 1373 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ 1374 xhv->xhv_array = a; /* HvARRAY(hv) = a */ 1375 aep = (HE**)a; 1376 1377 for (i=0; i<oldsize; i++,aep++) { 1378 if (!*aep) /* non-existent */ 1379 continue; 1380 bep = aep+oldsize; 1381 for (oentry = aep, entry = *aep; entry; entry = *oentry) { 1382 if ((HeHASH(entry) & newsize) != (U32)i) { 1383 *oentry = HeNEXT(entry); 1384 HeNEXT(entry) = *bep; 1385 if (!*bep) 1386 xhv->xhv_fill++; /* HvFILL(hv)++ */ 1387 *bep = entry; 1388 continue; 1389 } 1390 else 1391 oentry = &HeNEXT(entry); 1392 } 1393 if (!*aep) /* everything moved */ 1394 xhv->xhv_fill--; /* HvFILL(hv)-- */ 1395 } 1396 } 1397 1398 void 1399 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) 1400 { 1401 register XPVHV* xhv = (XPVHV*)SvANY(hv); 1402 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ 1403 register I32 newsize; 1404 register I32 i; 1405 register I32 j; 1406 register char *a; 1407 register HE **aep; 1408 register HE *entry; 1409 register HE **oentry; 1410 1411 newsize = (I32) newmax; /* possible truncation here */ 1412 if (newsize != newmax || newmax <= oldsize) 1413 return; 1414 while ((newsize & (1 + ~newsize)) != newsize) { 1415 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */ 1416 } 1417 if (newsize < newmax) 1418 newsize *= 2; 1419 if (newsize < newmax) 1420 return; /* overflow detection */ 1421 1422 a = xhv->xhv_array; /* HvARRAY(hv) */ 1423 if (a) { 1424 PL_nomemok = TRUE; 1425 #if defined(STRANGE_MALLOC) || defined(MYMALLOC) 1426 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); 1427 if (!a) { 1428 PL_nomemok = FALSE; 1429 return; 1430 } 1431 #else 1432 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); 1433 if (!a) { 1434 PL_nomemok = FALSE; 1435 return; 1436 } 1437 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char); 1438 if (oldsize >= 64) { 1439 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */, 1440 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)); 1441 } 1442 else 1443 Safefree(xhv->xhv_array /* HvARRAY(hv) */); 1444 #endif 1445 PL_nomemok = FALSE; 1446 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ 1447 } 1448 else { 1449 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); 1450 } 1451 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ 1452 xhv->xhv_array = a; /* HvARRAY(hv) = a */ 1453 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */ 1454 return; 1455 1456 aep = (HE**)a; 1457 for (i=0; i<oldsize; i++,aep++) { 1458 if (!*aep) /* non-existent */ 1459 continue; 1460 for (oentry = aep, entry = *aep; entry; entry = *oentry) { 1461 if ((j = (HeHASH(entry) & newsize)) != i) { 1462 j -= i; 1463 *oentry = HeNEXT(entry); 1464 if (!(HeNEXT(entry) = aep[j])) 1465 xhv->xhv_fill++; /* HvFILL(hv)++ */ 1466 aep[j] = entry; 1467 continue; 1468 } 1469 else 1470 oentry = &HeNEXT(entry); 1471 } 1472 if (!*aep) /* everything moved */ 1473 xhv->xhv_fill--; /* HvFILL(hv)-- */ 1474 } 1475 } 1476 1477 /* 1478 =for apidoc newHV 1479 1480 Creates a new HV. The reference count is set to 1. 1481 1482 =cut 1483 */ 1484 1485 HV * 1486 Perl_newHV(pTHX) 1487 { 1488 register HV *hv; 1489 register XPVHV* xhv; 1490 1491 hv = (HV*)NEWSV(502,0); 1492 sv_upgrade((SV *)hv, SVt_PVHV); 1493 xhv = (XPVHV*)SvANY(hv); 1494 SvPOK_off(hv); 1495 SvNOK_off(hv); 1496 #ifndef NODEFAULT_SHAREKEYS 1497 HvSHAREKEYS_on(hv); /* key-sharing on by default */ 1498 #endif 1499 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */ 1500 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */ 1501 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */ 1502 (void)hv_iterinit(hv); /* so each() will start off right */ 1503 return hv; 1504 } 1505 1506 HV * 1507 Perl_newHVhv(pTHX_ HV *ohv) 1508 { 1509 HV *hv = newHV(); 1510 STRLEN hv_max, hv_fill; 1511 1512 if (!ohv || (hv_fill = HvFILL(ohv)) == 0) 1513 return hv; 1514 hv_max = HvMAX(ohv); 1515 1516 if (!SvMAGICAL((SV *)ohv)) { 1517 /* It's an ordinary hash, so copy it fast. AMS 20010804 */ 1518 STRLEN i; 1519 bool shared = !!HvSHAREKEYS(ohv); 1520 HE **ents, **oents = (HE **)HvARRAY(ohv); 1521 char *a; 1522 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); 1523 ents = (HE**)a; 1524 1525 /* In each bucket... */ 1526 for (i = 0; i <= hv_max; i++) { 1527 HE *prev = NULL, *ent = NULL, *oent = oents[i]; 1528 1529 if (!oent) { 1530 ents[i] = NULL; 1531 continue; 1532 } 1533 1534 /* Copy the linked list of entries. */ 1535 for (oent = oents[i]; oent; oent = HeNEXT(oent)) { 1536 U32 hash = HeHASH(oent); 1537 char *key = HeKEY(oent); 1538 STRLEN len = HeKLEN(oent); 1539 int flags = HeKFLAGS(oent); 1540 1541 ent = new_HE(); 1542 HeVAL(ent) = newSVsv(HeVAL(oent)); 1543 HeKEY_hek(ent) 1544 = shared ? share_hek_flags(key, len, hash, flags) 1545 : save_hek_flags(key, len, hash, flags); 1546 if (prev) 1547 HeNEXT(prev) = ent; 1548 else 1549 ents[i] = ent; 1550 prev = ent; 1551 HeNEXT(ent) = NULL; 1552 } 1553 } 1554 1555 HvMAX(hv) = hv_max; 1556 HvFILL(hv) = hv_fill; 1557 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); 1558 HvARRAY(hv) = ents; 1559 } 1560 else { 1561 /* Iterate over ohv, copying keys and values one at a time. */ 1562 HE *entry; 1563 I32 riter = HvRITER(ohv); 1564 HE *eiter = HvEITER(ohv); 1565 1566 /* Can we use fewer buckets? (hv_max is always 2^n-1) */ 1567 while (hv_max && hv_max + 1 >= hv_fill * 2) 1568 hv_max = hv_max / 2; 1569 HvMAX(hv) = hv_max; 1570 1571 hv_iterinit(ohv); 1572 while ((entry = hv_iternext_flags(ohv, 0))) { 1573 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), 1574 newSVsv(HeVAL(entry)), HeHASH(entry), 1575 HeKFLAGS(entry)); 1576 } 1577 HvRITER(ohv) = riter; 1578 HvEITER(ohv) = eiter; 1579 } 1580 1581 return hv; 1582 } 1583 1584 void 1585 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) 1586 { 1587 SV *val; 1588 1589 if (!entry) 1590 return; 1591 val = HeVAL(entry); 1592 if (val && isGV(val) && GvCVu(val) && HvNAME(hv)) 1593 PL_sub_generation++; /* may be deletion of method from stash */ 1594 SvREFCNT_dec(val); 1595 if (HeKLEN(entry) == HEf_SVKEY) { 1596 SvREFCNT_dec(HeKEY_sv(entry)); 1597 Safefree(HeKEY_hek(entry)); 1598 } 1599 else if (HvSHAREKEYS(hv)) 1600 unshare_hek(HeKEY_hek(entry)); 1601 else 1602 Safefree(HeKEY_hek(entry)); 1603 del_HE(entry); 1604 } 1605 1606 void 1607 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) 1608 { 1609 if (!entry) 1610 return; 1611 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv)) 1612 PL_sub_generation++; /* may be deletion of method from stash */ 1613 sv_2mortal(HeVAL(entry)); /* free between statements */ 1614 if (HeKLEN(entry) == HEf_SVKEY) { 1615 sv_2mortal(HeKEY_sv(entry)); 1616 Safefree(HeKEY_hek(entry)); 1617 } 1618 else if (HvSHAREKEYS(hv)) 1619 unshare_hek(HeKEY_hek(entry)); 1620 else 1621 Safefree(HeKEY_hek(entry)); 1622 del_HE(entry); 1623 } 1624 1625 /* 1626 =for apidoc hv_clear 1627 1628 Clears a hash, making it empty. 1629 1630 =cut 1631 */ 1632 1633 void 1634 Perl_hv_clear(pTHX_ HV *hv) 1635 { 1636 register XPVHV* xhv; 1637 if (!hv) 1638 return; 1639 1640 if(SvREADONLY(hv)) { 1641 Perl_croak(aTHX_ "Attempt to clear a restricted hash"); 1642 } 1643 1644 xhv = (XPVHV*)SvANY(hv); 1645 hfreeentries(hv); 1646 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */ 1647 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */ 1648 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */ 1649 if (xhv->xhv_array /* HvARRAY(hv) */) 1650 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */, 1651 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*)); 1652 1653 if (SvRMAGICAL(hv)) 1654 mg_clear((SV*)hv); 1655 1656 HvHASKFLAGS_off(hv); 1657 } 1658 1659 STATIC void 1660 S_hfreeentries(pTHX_ HV *hv) 1661 { 1662 register HE **array; 1663 register HE *entry; 1664 register HE *oentry = Null(HE*); 1665 I32 riter; 1666 I32 max; 1667 1668 if (!hv) 1669 return; 1670 if (!HvARRAY(hv)) 1671 return; 1672 1673 riter = 0; 1674 max = HvMAX(hv); 1675 array = HvARRAY(hv); 1676 entry = array[0]; 1677 for (;;) { 1678 if (entry) { 1679 oentry = entry; 1680 entry = HeNEXT(entry); 1681 hv_free_ent(hv, oentry); 1682 } 1683 if (!entry) { 1684 if (++riter > max) 1685 break; 1686 entry = array[riter]; 1687 } 1688 } 1689 (void)hv_iterinit(hv); 1690 } 1691 1692 /* 1693 =for apidoc hv_undef 1694 1695 Undefines the hash. 1696 1697 =cut 1698 */ 1699 1700 void 1701 Perl_hv_undef(pTHX_ HV *hv) 1702 { 1703 register XPVHV* xhv; 1704 if (!hv) 1705 return; 1706 xhv = (XPVHV*)SvANY(hv); 1707 hfreeentries(hv); 1708 Safefree(xhv->xhv_array /* HvARRAY(hv) */); 1709 if (HvNAME(hv)) { 1710 Safefree(HvNAME(hv)); 1711 HvNAME(hv) = 0; 1712 } 1713 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */ 1714 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */ 1715 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */ 1716 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */ 1717 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */ 1718 1719 if (SvRMAGICAL(hv)) 1720 mg_clear((SV*)hv); 1721 } 1722 1723 /* 1724 =for apidoc hv_iterinit 1725 1726 Prepares a starting point to traverse a hash table. Returns the number of 1727 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is 1728 currently only meaningful for hashes without tie magic. 1729 1730 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of 1731 hash buckets that happen to be in use. If you still need that esoteric 1732 value, you can get it through the macro C<HvFILL(tb)>. 1733 1734 1735 =cut 1736 */ 1737 1738 I32 1739 Perl_hv_iterinit(pTHX_ HV *hv) 1740 { 1741 register XPVHV* xhv; 1742 HE *entry; 1743 1744 if (!hv) 1745 Perl_croak(aTHX_ "Bad hash"); 1746 xhv = (XPVHV*)SvANY(hv); 1747 entry = xhv->xhv_eiter; /* HvEITER(hv) */ 1748 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ 1749 HvLAZYDEL_off(hv); 1750 hv_free_ent(hv, entry); 1751 } 1752 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */ 1753 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ 1754 /* used to be xhv->xhv_fill before 5.004_65 */ 1755 return XHvTOTALKEYS(xhv); 1756 } 1757 /* 1758 =for apidoc hv_iternext 1759 1760 Returns entries from a hash iterator. See C<hv_iterinit>. 1761 1762 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the 1763 iterator currently points to, without losing your place or invalidating your 1764 iterator. Note that in this case the current entry is deleted from the hash 1765 with your iterator holding the last reference to it. Your iterator is flagged 1766 to free the entry on the next call to C<hv_iternext>, so you must not discard 1767 your iterator immediately else the entry will leak - call C<hv_iternext> to 1768 trigger the resource deallocation. 1769 1770 =cut 1771 */ 1772 1773 HE * 1774 Perl_hv_iternext(pTHX_ HV *hv) 1775 { 1776 return hv_iternext_flags(hv, 0); 1777 } 1778 1779 /* 1780 =for apidoc hv_iternext_flags 1781 1782 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>. 1783 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is 1784 set the placeholders keys (for restricted hashes) will be returned in addition 1785 to normal keys. By default placeholders are automatically skipped over. 1786 Currently a placeholder is implemented with a value that is literally 1787 <&Perl_sv_undef> (a regular C<undef> value is a normal read-write SV for which 1788 C<!SvOK> is false). Note that the implementation of placeholders and 1789 restricted hashes may change, and the implementation currently is 1790 insufficiently abstracted for any change to be tidy. 1791 1792 =cut 1793 */ 1794 1795 HE * 1796 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) 1797 { 1798 register XPVHV* xhv; 1799 register HE *entry; 1800 HE *oldentry; 1801 MAGIC* mg; 1802 1803 if (!hv) 1804 Perl_croak(aTHX_ "Bad hash"); 1805 xhv = (XPVHV*)SvANY(hv); 1806 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */ 1807 1808 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) { 1809 SV *key = sv_newmortal(); 1810 if (entry) { 1811 sv_setsv(key, HeSVKEY_force(entry)); 1812 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ 1813 } 1814 else { 1815 char *k; 1816 HEK *hek; 1817 1818 /* one HE per MAGICAL hash */ 1819 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ 1820 Zero(entry, 1, HE); 1821 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char); 1822 hek = (HEK*)k; 1823 HeKEY_hek(entry) = hek; 1824 HeKLEN(entry) = HEf_SVKEY; 1825 } 1826 magic_nextpack((SV*) hv,mg,key); 1827 if (SvOK(key)) { 1828 /* force key to stay around until next time */ 1829 HeSVKEY_set(entry, SvREFCNT_inc(key)); 1830 return entry; /* beware, hent_val is not set */ 1831 } 1832 if (HeVAL(entry)) 1833 SvREFCNT_dec(HeVAL(entry)); 1834 Safefree(HeKEY_hek(entry)); 1835 del_HE(entry); 1836 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ 1837 return Null(HE*); 1838 } 1839 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */ 1840 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) 1841 prime_env_iter(); 1842 #endif 1843 1844 if (!xhv->xhv_array /* !HvARRAY(hv) */) 1845 Newz(506, xhv->xhv_array /* HvARRAY(hv) */, 1846 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), 1847 char); 1848 if (entry) 1849 { 1850 entry = HeNEXT(entry); 1851 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { 1852 /* 1853 * Skip past any placeholders -- don't want to include them in 1854 * any iteration. 1855 */ 1856 while (entry && HeVAL(entry) == &PL_sv_undef) { 1857 entry = HeNEXT(entry); 1858 } 1859 } 1860 } 1861 while (!entry) { 1862 xhv->xhv_riter++; /* HvRITER(hv)++ */ 1863 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { 1864 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */ 1865 break; 1866 } 1867 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */ 1868 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter]; 1869 1870 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { 1871 /* if we have an entry, but it's a placeholder, don't count it */ 1872 if (entry && HeVAL(entry) == &PL_sv_undef) 1873 entry = 0; 1874 } 1875 } 1876 1877 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ 1878 HvLAZYDEL_off(hv); 1879 hv_free_ent(hv, oldentry); 1880 } 1881 1882 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */ 1883 return entry; 1884 } 1885 1886 /* 1887 =for apidoc hv_iterkey 1888 1889 Returns the key from the current position of the hash iterator. See 1890 C<hv_iterinit>. 1891 1892 =cut 1893 */ 1894 1895 char * 1896 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen) 1897 { 1898 if (HeKLEN(entry) == HEf_SVKEY) { 1899 STRLEN len; 1900 char *p = SvPV(HeKEY_sv(entry), len); 1901 *retlen = len; 1902 return p; 1903 } 1904 else { 1905 *retlen = HeKLEN(entry); 1906 return HeKEY(entry); 1907 } 1908 } 1909 1910 /* unlike hv_iterval(), this always returns a mortal copy of the key */ 1911 /* 1912 =for apidoc hv_iterkeysv 1913 1914 Returns the key as an C<SV*> from the current position of the hash 1915 iterator. The return value will always be a mortal copy of the key. Also 1916 see C<hv_iterinit>. 1917 1918 =cut 1919 */ 1920 1921 SV * 1922 Perl_hv_iterkeysv(pTHX_ register HE *entry) 1923 { 1924 if (HeKLEN(entry) != HEf_SVKEY) { 1925 HEK *hek = HeKEY_hek(entry); 1926 int flags = HEK_FLAGS(hek); 1927 SV *sv; 1928 1929 if (flags & HVhek_WASUTF8) { 1930 /* Trouble :-) 1931 Andreas would like keys he put in as utf8 to come back as utf8 1932 */ 1933 STRLEN utf8_len = HEK_LEN(hek); 1934 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); 1935 1936 sv = newSVpvn ((char*)as_utf8, utf8_len); 1937 SvUTF8_on (sv); 1938 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ 1939 } else { 1940 sv = newSVpvn_share(HEK_KEY(hek), 1941 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)), 1942 HEK_HASH(hek)); 1943 } 1944 return sv_2mortal(sv); 1945 } 1946 return sv_mortalcopy(HeKEY_sv(entry)); 1947 } 1948 1949 /* 1950 =for apidoc hv_iterval 1951 1952 Returns the value from the current position of the hash iterator. See 1953 C<hv_iterkey>. 1954 1955 =cut 1956 */ 1957 1958 SV * 1959 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry) 1960 { 1961 if (SvRMAGICAL(hv)) { 1962 if (mg_find((SV*)hv, PERL_MAGIC_tied)) { 1963 SV* sv = sv_newmortal(); 1964 if (HeKLEN(entry) == HEf_SVKEY) 1965 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY); 1966 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry)); 1967 return sv; 1968 } 1969 } 1970 return HeVAL(entry); 1971 } 1972 1973 /* 1974 =for apidoc hv_iternextsv 1975 1976 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one 1977 operation. 1978 1979 =cut 1980 */ 1981 1982 SV * 1983 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) 1984 { 1985 HE *he; 1986 if ( (he = hv_iternext_flags(hv, 0)) == NULL) 1987 return NULL; 1988 *key = hv_iterkey(he, retlen); 1989 return hv_iterval(hv, he); 1990 } 1991 1992 /* 1993 =for apidoc hv_magic 1994 1995 Adds magic to a hash. See C<sv_magic>. 1996 1997 =cut 1998 */ 1999 2000 void 2001 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how) 2002 { 2003 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0); 2004 } 2005 2006 #if 0 /* use the macro from hv.h instead */ 2007 2008 char* 2009 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash) 2010 { 2011 return HEK_KEY(share_hek(sv, len, hash)); 2012 } 2013 2014 #endif 2015 2016 /* possibly free a shared string if no one has access to it 2017 * len and hash must both be valid for str. 2018 */ 2019 void 2020 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) 2021 { 2022 unshare_hek_or_pvn (NULL, str, len, hash); 2023 } 2024 2025 2026 void 2027 Perl_unshare_hek(pTHX_ HEK *hek) 2028 { 2029 unshare_hek_or_pvn(hek, NULL, 0, 0); 2030 } 2031 2032 /* possibly free a shared string if no one has access to it 2033 hek if non-NULL takes priority over the other 3, else str, len and hash 2034 are used. If so, len and hash must both be valid for str. 2035 */ 2036 STATIC void 2037 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) 2038 { 2039 register XPVHV* xhv; 2040 register HE *entry; 2041 register HE **oentry; 2042 register I32 i = 1; 2043 I32 found = 0; 2044 bool is_utf8 = FALSE; 2045 int k_flags = 0; 2046 const char *save = str; 2047 2048 if (hek) { 2049 hash = HEK_HASH(hek); 2050 } else if (len < 0) { 2051 STRLEN tmplen = -len; 2052 is_utf8 = TRUE; 2053 /* See the note in hv_fetch(). --jhi */ 2054 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); 2055 len = tmplen; 2056 if (is_utf8) 2057 k_flags = HVhek_UTF8; 2058 if (str != save) 2059 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 2060 } 2061 2062 /* what follows is the moral equivalent of: 2063 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { 2064 if (--*Svp == Nullsv) 2065 hv_delete(PL_strtab, str, len, G_DISCARD, hash); 2066 } */ 2067 xhv = (XPVHV*)SvANY(PL_strtab); 2068 /* assert(xhv_array != 0) */ 2069 LOCK_STRTAB_MUTEX; 2070 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 2071 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 2072 if (hek) { 2073 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { 2074 if (HeKEY_hek(entry) != hek) 2075 continue; 2076 found = 1; 2077 break; 2078 } 2079 } else { 2080 int flags_masked = k_flags & HVhek_MASK; 2081 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { 2082 if (HeHASH(entry) != hash) /* strings can't be equal */ 2083 continue; 2084 if (HeKLEN(entry) != len) 2085 continue; 2086 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ 2087 continue; 2088 if (HeKFLAGS(entry) != flags_masked) 2089 continue; 2090 found = 1; 2091 break; 2092 } 2093 } 2094 2095 if (found) { 2096 if (--HeVAL(entry) == Nullsv) { 2097 *oentry = HeNEXT(entry); 2098 if (i && !*oentry) 2099 xhv->xhv_fill--; /* HvFILL(hv)-- */ 2100 Safefree(HeKEY_hek(entry)); 2101 del_HE(entry); 2102 xhv->xhv_keys--; /* HvKEYS(hv)-- */ 2103 } 2104 } 2105 2106 UNLOCK_STRTAB_MUTEX; 2107 if (!found && ckWARN_d(WARN_INTERNAL)) 2108 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), 2109 "Attempt to free non-existent shared string '%s'%s", 2110 hek ? HEK_KEY(hek) : str, 2111 (k_flags & HVhek_UTF8) ? " (utf8)" : ""); 2112 if (k_flags & HVhek_FREEKEY) 2113 Safefree(str); 2114 } 2115 2116 /* get a (constant) string ptr from the global string table 2117 * string will get added if it is not already there. 2118 * len and hash must both be valid for str. 2119 */ 2120 HEK * 2121 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) 2122 { 2123 bool is_utf8 = FALSE; 2124 int flags = 0; 2125 const char *save = str; 2126 2127 if (len < 0) { 2128 STRLEN tmplen = -len; 2129 is_utf8 = TRUE; 2130 /* See the note in hv_fetch(). --jhi */ 2131 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); 2132 len = tmplen; 2133 /* If we were able to downgrade here, then than means that we were passed 2134 in a key which only had chars 0-255, but was utf8 encoded. */ 2135 if (is_utf8) 2136 flags = HVhek_UTF8; 2137 /* If we found we were able to downgrade the string to bytes, then 2138 we should flag that it needs upgrading on keys or each. Also flag 2139 that we need share_hek_flags to free the string. */ 2140 if (str != save) 2141 flags |= HVhek_WASUTF8 | HVhek_FREEKEY; 2142 } 2143 2144 return share_hek_flags (str, len, hash, flags); 2145 } 2146 2147 STATIC HEK * 2148 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) 2149 { 2150 register XPVHV* xhv; 2151 register HE *entry; 2152 register HE **oentry; 2153 register I32 i = 1; 2154 I32 found = 0; 2155 int flags_masked = flags & HVhek_MASK; 2156 2157 /* what follows is the moral equivalent of: 2158 2159 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) 2160 hv_store(PL_strtab, str, len, Nullsv, hash); 2161 */ 2162 xhv = (XPVHV*)SvANY(PL_strtab); 2163 /* assert(xhv_array != 0) */ 2164 LOCK_STRTAB_MUTEX; 2165 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ 2166 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; 2167 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) { 2168 if (HeHASH(entry) != hash) /* strings can't be equal */ 2169 continue; 2170 if (HeKLEN(entry) != len) 2171 continue; 2172 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ 2173 continue; 2174 if (HeKFLAGS(entry) != flags_masked) 2175 continue; 2176 found = 1; 2177 break; 2178 } 2179 if (!found) { 2180 entry = new_HE(); 2181 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags); 2182 HeVAL(entry) = Nullsv; 2183 HeNEXT(entry) = *oentry; 2184 *oentry = entry; 2185 xhv->xhv_keys++; /* HvKEYS(hv)++ */ 2186 if (i) { /* initial entry? */ 2187 xhv->xhv_fill++; /* HvFILL(hv)++ */ 2188 if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) 2189 hsplit(PL_strtab); 2190 } 2191 } 2192 2193 ++HeVAL(entry); /* use value slot as REFCNT */ 2194 UNLOCK_STRTAB_MUTEX; 2195 2196 if (flags & HVhek_FREEKEY) 2197 Safefree(str); 2198 2199 return HeKEY_hek(entry); 2200 } 2201