3 * Copyright (c) 1991-2002, Larry Wall
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.
11 * "I sit beside the fire and think of all that I have seen." --Bilbo
15 =head1 Hash Manipulation Functions
30 PL_he_root = HeNEXT(he);
39 HeNEXT(p) = (HE*)PL_he_root;
50 New(54, ptr, 1008/sizeof(XPV), XPV);
51 ptr->xpv_pv = (char*)PL_he_arenaroot;
52 PL_he_arenaroot = ptr;
55 heend = &he[1008 / sizeof(HE) - 1];
58 HeNEXT(he) = (HE*)(he + 1);
66 #define new_HE() (HE*)safemalloc(sizeof(HE))
67 #define del_HE(p) safefree((char*)p)
71 #define new_HE() new_he()
72 #define del_HE(p) del_he(p)
77 S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
88 New(54, k, HEK_BASESIZE + len + 1, char);
90 Copy(str, HEK_KEY(hek), len, char);
93 HEK_UTF8(hek) = (char)is_utf8;
98 Perl_unshare_hek(pTHX_ HEK *hek)
100 unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
104 #if defined(USE_ITHREADS)
106 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
112 /* look for it in the table first */
113 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
117 /* create anew and remember what it is */
119 ptr_table_store(PL_ptr_table, e, ret);
121 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
122 if (HeKLEN(e) == HEf_SVKEY)
123 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
125 HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
127 HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
128 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
131 #endif /* USE_ITHREADS */
134 Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen,
137 SV *sv = sv_newmortal();
138 if (key == keysave) {
139 sv_setpvn(sv, key, klen);
142 /* Need to free saved eventually assign to mortal SV */
143 SV *sv = sv_newmortal();
144 sv_usepvn(sv, (char *) key, klen);
149 Perl_croak(aTHX_ "Attempt to access to key '%"SVf"' in fixed hash",sv);
152 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
158 Returns the SV which corresponds to the specified key in the hash. The
159 C<klen> is the length of the key. If C<lval> is set then the fetch will be
160 part of a store. Check that the return value is non-null before
161 dereferencing it to an C<SV*>.
163 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
164 information on how to use this function on tied hashes.
170 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
176 bool is_utf8 = FALSE;
177 const char *keysave = key;
187 if (SvRMAGICAL(hv)) {
188 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
190 mg_copy((SV*)hv, sv, key, klen);
192 return &PL_hv_fetch_sv;
194 #ifdef ENV_IS_CASELESS
195 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
197 for (i = 0; i < klen; ++i)
198 if (isLOWER(key[i])) {
199 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
200 SV **ret = hv_fetch(hv, nkey, klen, 0);
202 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
209 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
210 avoid unnecessary pointer dereferencing. */
211 xhv = (XPVHV*)SvANY(hv);
212 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
214 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
215 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
218 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
219 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
226 STRLEN tmplen = klen;
227 /* Just casting the &klen to (STRLEN) won't work well
228 * if STRLEN and I32 are of different widths. --jhi */
229 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
233 PERL_HASH(hash, key, klen);
235 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
236 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
237 for (; entry; entry = HeNEXT(entry)) {
238 if (HeHASH(entry) != hash) /* strings can't be equal */
240 if (HeKLEN(entry) != klen)
242 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
244 if (HeKUTF8(entry) != (char)is_utf8)
248 /* if we find a placeholder, we pretend we haven't found anything */
249 if (HeVAL(entry) == &PL_sv_undef)
251 return &HeVAL(entry);
254 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
255 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
257 char *env = PerlEnv_ENVgetenv_len(key,&len);
259 sv = newSVpvn(env,len);
263 return hv_store(hv,key,klen,sv,hash);
267 if (!entry && SvREADONLY(hv)) {
268 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
270 if (lval) { /* gonna assign to this, so it better be there */
272 if (key != keysave) { /* must be is_utf8 == 0 */
273 SV **ret = hv_store(hv,key,klen,sv,hash);
278 return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
285 /* returns an HE * structure with the all fields set */
286 /* note that hent_val will be a mortal sv for MAGICAL hashes */
288 =for apidoc hv_fetch_ent
290 Returns the hash entry which corresponds to the specified key in the hash.
291 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
292 if you want the function to compute it. IF C<lval> is set then the fetch
293 will be part of a store. Make sure the return value is non-null before
294 accessing it. The return value when C<tb> is a tied hash is a pointer to a
295 static location, so be sure to make a copy of the structure if you need to
298 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
299 information on how to use this function on tied hashes.
305 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
318 if (SvRMAGICAL(hv)) {
319 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
321 keysv = sv_2mortal(newSVsv(keysv));
322 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
323 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
325 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
326 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
328 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
329 HeVAL(&PL_hv_fetch_ent_mh) = sv;
330 return &PL_hv_fetch_ent_mh;
332 #ifdef ENV_IS_CASELESS
333 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
335 key = SvPV(keysv, klen);
336 for (i = 0; i < klen; ++i)
337 if (isLOWER(key[i])) {
338 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
339 (void)strupr(SvPVX(nkeysv));
340 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
342 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
349 xhv = (XPVHV*)SvANY(hv);
350 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
352 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
353 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
356 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
357 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
363 keysave = key = SvPV(keysv, klen);
364 is_utf8 = (SvUTF8(keysv)!=0);
367 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
370 PERL_HASH(hash, key, klen);
372 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
373 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
374 for (; entry; entry = HeNEXT(entry)) {
375 if (HeHASH(entry) != hash) /* strings can't be equal */
377 if (HeKLEN(entry) != klen)
379 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
381 if (HeKUTF8(entry) != (char)is_utf8)
385 /* if we find a placeholder, we pretend we haven't found anything */
386 if (HeVAL(entry) == &PL_sv_undef)
390 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
391 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
393 char *env = PerlEnv_ENVgetenv_len(key,&len);
395 sv = newSVpvn(env,len);
397 return hv_store_ent(hv,keysv,sv,hash);
401 if (!entry && SvREADONLY(hv)) {
402 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
406 if (lval) { /* gonna assign to this, so it better be there */
408 return hv_store_ent(hv,keysv,sv,hash);
414 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
416 MAGIC *mg = SvMAGIC(hv);
420 if (isUPPER(mg->mg_type)) {
422 switch (mg->mg_type) {
423 case PERL_MAGIC_tied:
425 *needs_store = FALSE;
428 mg = mg->mg_moremagic;
435 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
436 the length of the key. The C<hash> parameter is the precomputed hash
437 value; if it is zero then Perl will compute it. The return value will be
438 NULL if the operation failed or if the value did not need to be actually
439 stored within the hash (as in the case of tied hashes). Otherwise it can
440 be dereferenced to get the original C<SV*>. Note that the caller is
441 responsible for suitably incrementing the reference count of C<val> before
442 the call, and decrementing it if the function returned NULL.
444 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
445 information on how to use this function on tied hashes.
451 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
456 register HE **oentry;
457 bool is_utf8 = FALSE;
458 const char *keysave = key;
468 xhv = (XPVHV*)SvANY(hv);
472 hv_magic_check (hv, &needs_copy, &needs_store);
474 mg_copy((SV*)hv, val, key, klen);
475 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store)
477 #ifdef ENV_IS_CASELESS
478 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
479 key = savepvn(key,klen);
480 key = (const char*)strupr((char*)key);
487 STRLEN tmplen = klen;
488 /* See the note in hv_fetch(). --jhi */
489 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
494 PERL_HASH(hash, key, klen);
496 if (!xhv->xhv_array /* !HvARRAY(hv) */)
497 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
498 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
501 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
502 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
505 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
506 if (HeHASH(entry) != hash) /* strings can't be equal */
508 if (HeKLEN(entry) != klen)
510 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
512 if (HeKUTF8(entry) != (char)is_utf8)
514 if (HeVAL(entry) == &PL_sv_undef)
515 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
517 SvREFCNT_dec(HeVAL(entry));
521 return &HeVAL(entry);
524 if (SvREADONLY(hv)) {
525 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
530 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
531 else /* gotta do the real thing */
532 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
536 HeNEXT(entry) = *oentry;
539 xhv->xhv_keys++; /* HvKEYS(hv)++ */
540 if (i) { /* initial entry? */
541 xhv->xhv_fill++; /* HvFILL(hv)++ */
542 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
546 return &HeVAL(entry);
550 =for apidoc hv_store_ent
552 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
553 parameter is the precomputed hash value; if it is zero then Perl will
554 compute it. The return value is the new hash entry so created. It will be
555 NULL if the operation failed or if the value did not need to be actually
556 stored within the hash (as in the case of tied hashes). Otherwise the
557 contents of the return value can be accessed using the C<He?> macros
558 described here. Note that the caller is responsible for suitably
559 incrementing the reference count of C<val> before the call, and
560 decrementing it if the function returned NULL.
562 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
563 information on how to use this function on tied hashes.
569 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
576 register HE **oentry;
583 xhv = (XPVHV*)SvANY(hv);
587 hv_magic_check (hv, &needs_copy, &needs_store);
589 bool save_taint = PL_tainted;
591 PL_tainted = SvTAINTED(keysv);
592 keysv = sv_2mortal(newSVsv(keysv));
593 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
594 TAINT_IF(save_taint);
595 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
597 #ifdef ENV_IS_CASELESS
598 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
599 key = SvPV(keysv, klen);
600 keysv = sv_2mortal(newSVpvn(key,klen));
601 (void)strupr(SvPVX(keysv));
608 keysave = key = SvPV(keysv, klen);
609 is_utf8 = (SvUTF8(keysv) != 0);
612 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
615 PERL_HASH(hash, key, klen);
617 if (!xhv->xhv_array /* !HvARRAY(hv) */)
618 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
619 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
622 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
623 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
626 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
627 if (HeHASH(entry) != hash) /* strings can't be equal */
629 if (HeKLEN(entry) != klen)
631 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
633 if (HeKUTF8(entry) != (char)is_utf8)
635 if (HeVAL(entry) == &PL_sv_undef)
636 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
638 SvREFCNT_dec(HeVAL(entry));
645 if (SvREADONLY(hv)) {
646 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
651 HeKEY_hek(entry) = share_hek(key, is_utf8?-(I32)klen:klen, hash);
652 else /* gotta do the real thing */
653 HeKEY_hek(entry) = save_hek(key, is_utf8?-(I32)klen:klen, hash);
657 HeNEXT(entry) = *oentry;
660 xhv->xhv_keys++; /* HvKEYS(hv)++ */
661 if (i) { /* initial entry? */
662 xhv->xhv_fill++; /* HvFILL(hv)++ */
663 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
671 =for apidoc hv_delete
673 Deletes a key/value pair in the hash. The value SV is removed from the
674 hash and returned to the caller. The C<klen> is the length of the key.
675 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
682 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
688 register HE **oentry;
691 bool is_utf8 = FALSE;
692 const char *keysave = key;
700 if (SvRMAGICAL(hv)) {
703 hv_magic_check (hv, &needs_copy, &needs_store);
705 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
709 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
710 /* No longer an element */
711 sv_unmagic(sv, PERL_MAGIC_tiedelem);
714 return Nullsv; /* element cannot be deleted */
716 #ifdef ENV_IS_CASELESS
717 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
718 sv = sv_2mortal(newSVpvn(key,klen));
719 key = strupr(SvPVX(sv));
724 xhv = (XPVHV*)SvANY(hv);
725 if (!xhv->xhv_array /* !HvARRAY(hv) */)
729 STRLEN tmplen = klen;
730 /* See the note in hv_fetch(). --jhi */
731 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
735 PERL_HASH(hash, key, klen);
737 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
738 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
741 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
742 if (HeHASH(entry) != hash) /* strings can't be equal */
744 if (HeKLEN(entry) != klen)
746 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
748 if (HeKUTF8(entry) != (char)is_utf8)
752 /* if placeholder is here, it's already been deleted.... */
753 if (HeVAL(entry) == &PL_sv_undef)
756 return Nullsv; /* if still SvREADONLY, leave it deleted. */
758 /* okay, really delete the placeholder... */
759 *oentry = HeNEXT(entry);
761 xhv->xhv_fill--; /* HvFILL(hv)-- */
762 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
765 hv_free_ent(hv, entry);
766 xhv->xhv_keys--; /* HvKEYS(hv)-- */
767 xhv->xhv_placeholders--;
771 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
772 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
775 if (flags & G_DISCARD)
778 sv = sv_2mortal(HeVAL(entry));
779 HeVAL(entry) = &PL_sv_undef;
783 * If a restricted hash, rather than really deleting the entry, put
784 * a placeholder there. This marks the key as being "approved", so
785 * we can still access via not-really-existing key without raising
788 if (SvREADONLY(hv)) {
789 HeVAL(entry) = &PL_sv_undef;
790 /* We'll be saving this slot, so the number of allocated keys
791 * doesn't go down, but the number placeholders goes up */
792 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
794 *oentry = HeNEXT(entry);
796 xhv->xhv_fill--; /* HvFILL(hv)-- */
797 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
800 hv_free_ent(hv, entry);
801 xhv->xhv_keys--; /* HvKEYS(hv)-- */
805 if (SvREADONLY(hv)) {
806 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
815 =for apidoc hv_delete_ent
817 Deletes a key/value pair in the hash. The value SV is removed from the
818 hash and returned to the caller. The C<flags> value will normally be zero;
819 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
820 precomputed hash value, or 0 to ask for it to be computed.
826 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
833 register HE **oentry;
840 if (SvRMAGICAL(hv)) {
843 hv_magic_check (hv, &needs_copy, &needs_store);
845 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
849 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
850 /* No longer an element */
851 sv_unmagic(sv, PERL_MAGIC_tiedelem);
854 return Nullsv; /* element cannot be deleted */
856 #ifdef ENV_IS_CASELESS
857 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
858 key = SvPV(keysv, klen);
859 keysv = sv_2mortal(newSVpvn(key,klen));
860 (void)strupr(SvPVX(keysv));
866 xhv = (XPVHV*)SvANY(hv);
867 if (!xhv->xhv_array /* !HvARRAY(hv) */)
870 keysave = key = SvPV(keysv, klen);
871 is_utf8 = (SvUTF8(keysv) != 0);
874 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
877 PERL_HASH(hash, key, klen);
879 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
880 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
883 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
884 if (HeHASH(entry) != hash) /* strings can't be equal */
886 if (HeKLEN(entry) != klen)
888 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
890 if (HeKUTF8(entry) != (char)is_utf8)
895 /* if placeholder is here, it's already been deleted.... */
896 if (HeVAL(entry) == &PL_sv_undef)
899 return Nullsv; /* if still SvREADONLY, leave it deleted. */
901 /* okay, really delete the placeholder. */
902 *oentry = HeNEXT(entry);
904 xhv->xhv_fill--; /* HvFILL(hv)-- */
905 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
908 hv_free_ent(hv, entry);
909 xhv->xhv_keys--; /* HvKEYS(hv)-- */
910 xhv->xhv_placeholders--;
913 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
914 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
917 if (flags & G_DISCARD)
920 sv = sv_2mortal(HeVAL(entry));
921 HeVAL(entry) = &PL_sv_undef;
925 * If a restricted hash, rather than really deleting the entry, put
926 * a placeholder there. This marks the key as being "approved", so
927 * we can still access via not-really-existing key without raising
930 if (SvREADONLY(hv)) {
931 HeVAL(entry) = &PL_sv_undef;
932 /* We'll be saving this slot, so the number of allocated keys
933 * doesn't go down, but the number placeholders goes up */
934 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
936 *oentry = HeNEXT(entry);
938 xhv->xhv_fill--; /* HvFILL(hv)-- */
939 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
942 hv_free_ent(hv, entry);
943 xhv->xhv_keys--; /* HvKEYS(hv)-- */
947 if (SvREADONLY(hv)) {
948 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
957 =for apidoc hv_exists
959 Returns a boolean indicating whether the specified hash key exists. The
960 C<klen> is the length of the key.
966 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
972 bool is_utf8 = FALSE;
973 const char *keysave = key;
983 if (SvRMAGICAL(hv)) {
984 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
986 mg_copy((SV*)hv, sv, key, klen);
987 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
990 #ifdef ENV_IS_CASELESS
991 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
992 sv = sv_2mortal(newSVpvn(key,klen));
993 key = strupr(SvPVX(sv));
998 xhv = (XPVHV*)SvANY(hv);
999 #ifndef DYNAMIC_ENV_FETCH
1000 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1005 STRLEN tmplen = klen;
1006 /* See the note in hv_fetch(). --jhi */
1007 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1011 PERL_HASH(hash, key, klen);
1013 #ifdef DYNAMIC_ENV_FETCH
1014 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1017 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1018 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1019 for (; entry; entry = HeNEXT(entry)) {
1020 if (HeHASH(entry) != hash) /* strings can't be equal */
1022 if (HeKLEN(entry) != klen)
1024 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1026 if (HeKUTF8(entry) != (char)is_utf8)
1030 /* If we find the key, but the value is a placeholder, return false. */
1031 if (HeVAL(entry) == &PL_sv_undef)
1036 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1037 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1039 char *env = PerlEnv_ENVgetenv_len(key,&len);
1041 sv = newSVpvn(env,len);
1043 (void)hv_store(hv,key,klen,sv,hash);
1055 =for apidoc hv_exists_ent
1057 Returns a boolean indicating whether the specified hash key exists. C<hash>
1058 can be a valid precomputed hash value, or 0 to ask for it to be
1065 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1067 register XPVHV* xhv;
1078 if (SvRMAGICAL(hv)) {
1079 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1080 SV* svret = sv_newmortal();
1081 sv = sv_newmortal();
1082 keysv = sv_2mortal(newSVsv(keysv));
1083 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1084 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1085 return SvTRUE(svret);
1087 #ifdef ENV_IS_CASELESS
1088 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1089 key = SvPV(keysv, klen);
1090 keysv = sv_2mortal(newSVpvn(key,klen));
1091 (void)strupr(SvPVX(keysv));
1097 xhv = (XPVHV*)SvANY(hv);
1098 #ifndef DYNAMIC_ENV_FETCH
1099 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1103 keysave = key = SvPV(keysv, klen);
1104 is_utf8 = (SvUTF8(keysv) != 0);
1106 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1108 PERL_HASH(hash, key, klen);
1110 #ifdef DYNAMIC_ENV_FETCH
1111 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1114 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1115 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1116 for (; entry; entry = HeNEXT(entry)) {
1117 if (HeHASH(entry) != hash) /* strings can't be equal */
1119 if (HeKLEN(entry) != klen)
1121 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1123 if (HeKUTF8(entry) != (char)is_utf8)
1127 /* If we find the key, but the value is a placeholder, return false. */
1128 if (HeVAL(entry) == &PL_sv_undef)
1132 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1133 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1135 char *env = PerlEnv_ENVgetenv_len(key,&len);
1137 sv = newSVpvn(env,len);
1139 (void)hv_store_ent(hv,keysv,sv,hash);
1150 S_hsplit(pTHX_ HV *hv)
1152 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1153 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1154 register I32 newsize = oldsize * 2;
1156 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1160 register HE **oentry;
1163 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1164 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1170 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1175 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1176 if (oldsize >= 64) {
1177 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1178 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1181 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1185 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1186 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1187 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1190 for (i=0; i<oldsize; i++,aep++) {
1191 if (!*aep) /* non-existent */
1194 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1195 if ((HeHASH(entry) & newsize) != i) {
1196 *oentry = HeNEXT(entry);
1197 HeNEXT(entry) = *bep;
1199 xhv->xhv_fill++; /* HvFILL(hv)++ */
1204 oentry = &HeNEXT(entry);
1206 if (!*aep) /* everything moved */
1207 xhv->xhv_fill--; /* HvFILL(hv)-- */
1212 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1214 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1215 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1216 register I32 newsize;
1222 register HE **oentry;
1224 newsize = (I32) newmax; /* possible truncation here */
1225 if (newsize != newmax || newmax <= oldsize)
1227 while ((newsize & (1 + ~newsize)) != newsize) {
1228 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1230 if (newsize < newmax)
1232 if (newsize < newmax)
1233 return; /* overflow detection */
1235 a = xhv->xhv_array; /* HvARRAY(hv) */
1238 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1239 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1245 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1250 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1251 if (oldsize >= 64) {
1252 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1253 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1256 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1259 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1262 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1264 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1265 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1266 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1270 for (i=0; i<oldsize; i++,aep++) {
1271 if (!*aep) /* non-existent */
1273 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1274 if ((j = (HeHASH(entry) & newsize)) != i) {
1276 *oentry = HeNEXT(entry);
1277 if (!(HeNEXT(entry) = aep[j]))
1278 xhv->xhv_fill++; /* HvFILL(hv)++ */
1283 oentry = &HeNEXT(entry);
1285 if (!*aep) /* everything moved */
1286 xhv->xhv_fill--; /* HvFILL(hv)-- */
1293 Creates a new HV. The reference count is set to 1.
1302 register XPVHV* xhv;
1304 hv = (HV*)NEWSV(502,0);
1305 sv_upgrade((SV *)hv, SVt_PVHV);
1306 xhv = (XPVHV*)SvANY(hv);
1309 #ifndef NODEFAULT_SHAREKEYS
1310 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1312 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1313 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1314 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1315 (void)hv_iterinit(hv); /* so each() will start off right */
1320 Perl_newHVhv(pTHX_ HV *ohv)
1323 STRLEN hv_max, hv_fill;
1325 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1327 hv_max = HvMAX(ohv);
1329 if (!SvMAGICAL((SV *)ohv)) {
1330 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1331 int i, shared = !!HvSHAREKEYS(ohv);
1332 HE **ents, **oents = (HE **)HvARRAY(ohv);
1334 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1337 /* In each bucket... */
1338 for (i = 0; i <= hv_max; i++) {
1339 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1346 /* Copy the linked list of entries. */
1347 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1348 U32 hash = HeHASH(oent);
1349 char *key = HeKEY(oent);
1350 STRLEN len = HeKLEN_UTF8(oent);
1353 HeVAL(ent) = newSVsv(HeVAL(oent));
1354 HeKEY_hek(ent) = shared ? share_hek(key, len, hash)
1355 : save_hek(key, len, hash);
1366 HvFILL(hv) = hv_fill;
1367 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1371 /* Iterate over ohv, copying keys and values one at a time. */
1373 I32 riter = HvRITER(ohv);
1374 HE *eiter = HvEITER(ohv);
1376 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1377 while (hv_max && hv_max + 1 >= hv_fill * 2)
1378 hv_max = hv_max / 2;
1382 while ((entry = hv_iternext(ohv))) {
1383 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1384 newSVsv(HeVAL(entry)), HeHASH(entry));
1386 HvRITER(ohv) = riter;
1387 HvEITER(ohv) = eiter;
1394 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1401 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1402 PL_sub_generation++; /* may be deletion of method from stash */
1404 if (HeKLEN(entry) == HEf_SVKEY) {
1405 SvREFCNT_dec(HeKEY_sv(entry));
1406 Safefree(HeKEY_hek(entry));
1408 else if (HvSHAREKEYS(hv))
1409 unshare_hek(HeKEY_hek(entry));
1411 Safefree(HeKEY_hek(entry));
1416 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1420 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1421 PL_sub_generation++; /* may be deletion of method from stash */
1422 sv_2mortal(HeVAL(entry)); /* free between statements */
1423 if (HeKLEN(entry) == HEf_SVKEY) {
1424 sv_2mortal(HeKEY_sv(entry));
1425 Safefree(HeKEY_hek(entry));
1427 else if (HvSHAREKEYS(hv))
1428 unshare_hek(HeKEY_hek(entry));
1430 Safefree(HeKEY_hek(entry));
1435 =for apidoc hv_clear
1437 Clears a hash, making it empty.
1443 Perl_hv_clear(pTHX_ HV *hv)
1445 register XPVHV* xhv;
1448 xhv = (XPVHV*)SvANY(hv);
1450 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1451 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1452 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1453 if (xhv->xhv_array /* HvARRAY(hv) */)
1454 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1455 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1462 S_hfreeentries(pTHX_ HV *hv)
1464 register HE **array;
1466 register HE *oentry = Null(HE*);
1477 array = HvARRAY(hv);
1482 entry = HeNEXT(entry);
1483 hv_free_ent(hv, oentry);
1488 entry = array[riter];
1491 (void)hv_iterinit(hv);
1495 =for apidoc hv_undef
1503 Perl_hv_undef(pTHX_ HV *hv)
1505 register XPVHV* xhv;
1508 xhv = (XPVHV*)SvANY(hv);
1510 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1512 Safefree(HvNAME(hv));
1515 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1516 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1517 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1518 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1519 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1526 =for apidoc hv_iterinit
1528 Prepares a starting point to traverse a hash table. Returns the number of
1529 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1530 currently only meaningful for hashes without tie magic.
1532 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1533 hash buckets that happen to be in use. If you still need that esoteric
1534 value, you can get it through the macro C<HvFILL(tb)>.
1540 Perl_hv_iterinit(pTHX_ HV *hv)
1542 register XPVHV* xhv;
1546 Perl_croak(aTHX_ "Bad hash");
1547 xhv = (XPVHV*)SvANY(hv);
1548 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1549 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1551 hv_free_ent(hv, entry);
1553 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1554 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1555 /* used to be xhv->xhv_fill before 5.004_65 */
1556 return XHvTOTALKEYS(xhv);
1560 =for apidoc hv_iternext
1562 Returns entries from a hash iterator. See C<hv_iterinit>.
1568 Perl_hv_iternext(pTHX_ HV *hv)
1570 register XPVHV* xhv;
1576 Perl_croak(aTHX_ "Bad hash");
1577 xhv = (XPVHV*)SvANY(hv);
1578 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1580 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1581 SV *key = sv_newmortal();
1583 sv_setsv(key, HeSVKEY_force(entry));
1584 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1590 /* one HE per MAGICAL hash */
1591 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1593 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1595 HeKEY_hek(entry) = hek;
1596 HeKLEN(entry) = HEf_SVKEY;
1598 magic_nextpack((SV*) hv,mg,key);
1600 /* force key to stay around until next time */
1601 HeSVKEY_set(entry, SvREFCNT_inc(key));
1602 return entry; /* beware, hent_val is not set */
1605 SvREFCNT_dec(HeVAL(entry));
1606 Safefree(HeKEY_hek(entry));
1608 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1611 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1612 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1616 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1617 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1618 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1622 entry = HeNEXT(entry);
1624 * Skip past any placeholders -- don't want to include them in
1627 while (entry && HeVAL(entry) == &PL_sv_undef) {
1628 entry = HeNEXT(entry);
1632 xhv->xhv_riter++; /* HvRITER(hv)++ */
1633 if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1634 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1637 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1638 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1640 /* if we have an entry, but it's a placeholder, don't count it */
1641 if (entry && HeVAL(entry) == &PL_sv_undef)
1646 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1648 hv_free_ent(hv, oldentry);
1651 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1656 =for apidoc hv_iterkey
1658 Returns the key from the current position of the hash iterator. See
1665 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1667 if (HeKLEN(entry) == HEf_SVKEY) {
1669 char *p = SvPV(HeKEY_sv(entry), len);
1674 *retlen = HeKLEN(entry);
1675 return HeKEY(entry);
1679 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1681 =for apidoc hv_iterkeysv
1683 Returns the key as an C<SV*> from the current position of the hash
1684 iterator. The return value will always be a mortal copy of the key. Also
1691 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1693 if (HeKLEN(entry) == HEf_SVKEY)
1694 return sv_mortalcopy(HeKEY_sv(entry));
1696 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1697 HeKLEN_UTF8(entry), HeHASH(entry)));
1701 =for apidoc hv_iterval
1703 Returns the value from the current position of the hash iterator. See
1710 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1712 if (SvRMAGICAL(hv)) {
1713 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1714 SV* sv = sv_newmortal();
1715 if (HeKLEN(entry) == HEf_SVKEY)
1716 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1717 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1721 return HeVAL(entry);
1725 =for apidoc hv_iternextsv
1727 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1734 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1737 if ( (he = hv_iternext(hv)) == NULL)
1739 *key = hv_iterkey(he, retlen);
1740 return hv_iterval(hv, he);
1744 =for apidoc hv_magic
1746 Adds magic to a hash. See C<sv_magic>.
1752 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1754 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1757 #if 0 /* use the macro from hv.h instead */
1760 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1762 return HEK_KEY(share_hek(sv, len, hash));
1767 /* possibly free a shared string if no one has access to it
1768 * len and hash must both be valid for str.
1771 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1773 register XPVHV* xhv;
1775 register HE **oentry;
1778 bool is_utf8 = FALSE;
1779 const char *save = str;
1782 STRLEN tmplen = -len;
1784 /* See the note in hv_fetch(). --jhi */
1785 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1789 /* what follows is the moral equivalent of:
1790 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1791 if (--*Svp == Nullsv)
1792 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1794 xhv = (XPVHV*)SvANY(PL_strtab);
1795 /* assert(xhv_array != 0) */
1797 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1798 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1799 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1800 if (HeHASH(entry) != hash) /* strings can't be equal */
1802 if (HeKLEN(entry) != len)
1804 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1806 if (HeKUTF8(entry) != (char)is_utf8)
1809 if (--HeVAL(entry) == Nullsv) {
1810 *oentry = HeNEXT(entry);
1812 xhv->xhv_fill--; /* HvFILL(hv)-- */
1813 Safefree(HeKEY_hek(entry));
1815 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1819 UNLOCK_STRTAB_MUTEX;
1822 if (!found && ckWARN_d(WARN_INTERNAL))
1823 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1826 /* get a (constant) string ptr from the global string table
1827 * string will get added if it is not already there.
1828 * len and hash must both be valid for str.
1831 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1833 register XPVHV* xhv;
1835 register HE **oentry;
1838 bool is_utf8 = FALSE;
1839 const char *save = str;
1842 STRLEN tmplen = -len;
1844 /* See the note in hv_fetch(). --jhi */
1845 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1849 /* what follows is the moral equivalent of:
1851 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1852 hv_store(PL_strtab, str, len, Nullsv, hash);
1854 xhv = (XPVHV*)SvANY(PL_strtab);
1855 /* assert(xhv_array != 0) */
1857 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1858 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1859 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1860 if (HeHASH(entry) != hash) /* strings can't be equal */
1862 if (HeKLEN(entry) != len)
1864 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1866 if (HeKUTF8(entry) != (char)is_utf8)
1873 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1874 HeVAL(entry) = Nullsv;
1875 HeNEXT(entry) = *oentry;
1877 xhv->xhv_keys++; /* HvKEYS(hv)++ */
1878 if (i) { /* initial entry? */
1879 xhv->xhv_fill++; /* HvFILL(hv)++ */
1880 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
1885 ++HeVAL(entry); /* use value slot as REFCNT */
1886 UNLOCK_STRTAB_MUTEX;
1889 return HeKEY_hek(entry);