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 + 2, char);
90 Copy(str, HEK_KEY(hek), len, char);
91 HEK_KEY(hek)[len] = 0;
94 HEK_UTF8(hek) = (char)is_utf8;
99 Perl_unshare_hek(pTHX_ HEK *hek)
101 unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
105 #if defined(USE_ITHREADS)
107 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
113 /* look for it in the table first */
114 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
118 /* create anew and remember what it is */
120 ptr_table_store(PL_ptr_table, e, ret);
122 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
123 if (HeKLEN(e) == HEf_SVKEY)
124 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
126 HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
128 HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
129 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
132 #endif /* USE_ITHREADS */
135 Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen,
136 const char *keysave, const char *msg)
138 SV *sv = sv_newmortal();
139 if (key == keysave) {
140 sv_setpvn(sv, key, klen);
143 /* Need to free saved eventually assign to mortal SV */
144 SV *sv = sv_newmortal();
145 sv_usepvn(sv, (char *) key, klen);
150 Perl_croak(aTHX_ msg, sv);
153 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
159 Returns the SV which corresponds to the specified key in the hash. The
160 C<klen> is the length of the key. If C<lval> is set then the fetch will be
161 part of a store. Check that the return value is non-null before
162 dereferencing it to an C<SV*>.
164 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
165 information on how to use this function on tied hashes.
171 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
177 bool is_utf8 = FALSE;
178 const char *keysave = key;
188 if (SvRMAGICAL(hv)) {
189 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
191 mg_copy((SV*)hv, sv, key, klen);
193 return &PL_hv_fetch_sv;
195 #ifdef ENV_IS_CASELESS
196 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
198 for (i = 0; i < klen; ++i)
199 if (isLOWER(key[i])) {
200 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
201 SV **ret = hv_fetch(hv, nkey, klen, 0);
203 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
210 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
211 avoid unnecessary pointer dereferencing. */
212 xhv = (XPVHV*)SvANY(hv);
213 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
215 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
216 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
219 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
220 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
227 STRLEN tmplen = klen;
228 /* Just casting the &klen to (STRLEN) won't work well
229 * if STRLEN and I32 are of different widths. --jhi */
230 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
234 PERL_HASH(hash, key, klen);
236 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
237 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
238 for (; entry; entry = HeNEXT(entry)) {
239 if (HeHASH(entry) != hash) /* strings can't be equal */
241 if (HeKLEN(entry) != klen)
243 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
245 if (HeKUTF8(entry) != (char)is_utf8)
249 /* if we find a placeholder, we pretend we haven't found anything */
250 if (HeVAL(entry) == &PL_sv_undef)
252 return &HeVAL(entry);
255 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
256 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
258 char *env = PerlEnv_ENVgetenv_len(key,&len);
260 sv = newSVpvn(env,len);
264 return hv_store(hv,key,klen,sv,hash);
268 if (!entry && SvREADONLY(hv)) {
269 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
270 "Attempt to access disallowed key '%"SVf"' in a fixed hash"
273 if (lval) { /* gonna assign to this, so it better be there */
275 if (key != keysave) { /* must be is_utf8 == 0 */
276 SV **ret = hv_store(hv,key,klen,sv,hash);
281 return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
288 /* returns an HE * structure with the all fields set */
289 /* note that hent_val will be a mortal sv for MAGICAL hashes */
291 =for apidoc hv_fetch_ent
293 Returns the hash entry which corresponds to the specified key in the hash.
294 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
295 if you want the function to compute it. IF C<lval> is set then the fetch
296 will be part of a store. Make sure the return value is non-null before
297 accessing it. The return value when C<tb> is a tied hash is a pointer to a
298 static location, so be sure to make a copy of the structure if you need to
301 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
302 information on how to use this function on tied hashes.
308 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
321 if (SvRMAGICAL(hv)) {
322 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
324 keysv = sv_2mortal(newSVsv(keysv));
325 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
326 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
328 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
329 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
331 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
332 HeVAL(&PL_hv_fetch_ent_mh) = sv;
333 return &PL_hv_fetch_ent_mh;
335 #ifdef ENV_IS_CASELESS
336 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
338 key = SvPV(keysv, klen);
339 for (i = 0; i < klen; ++i)
340 if (isLOWER(key[i])) {
341 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
342 (void)strupr(SvPVX(nkeysv));
343 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
345 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
352 xhv = (XPVHV*)SvANY(hv);
353 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
355 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
356 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
359 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
360 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
366 keysave = key = SvPV(keysv, klen);
367 is_utf8 = (SvUTF8(keysv)!=0);
370 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
373 PERL_HASH(hash, key, klen);
375 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
376 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
377 for (; entry; entry = HeNEXT(entry)) {
378 if (HeHASH(entry) != hash) /* strings can't be equal */
380 if (HeKLEN(entry) != klen)
382 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
384 if (HeKUTF8(entry) != (char)is_utf8)
388 /* if we find a placeholder, we pretend we haven't found anything */
389 if (HeVAL(entry) == &PL_sv_undef)
393 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
394 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
396 char *env = PerlEnv_ENVgetenv_len(key,&len);
398 sv = newSVpvn(env,len);
400 return hv_store_ent(hv,keysv,sv,hash);
404 if (!entry && SvREADONLY(hv)) {
405 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
406 "Attempt to access disallowed key '%"SVf"' in a fixed hash"
411 if (lval) { /* gonna assign to this, so it better be there */
413 return hv_store_ent(hv,keysv,sv,hash);
419 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
421 MAGIC *mg = SvMAGIC(hv);
425 if (isUPPER(mg->mg_type)) {
427 switch (mg->mg_type) {
428 case PERL_MAGIC_tied:
430 *needs_store = FALSE;
433 mg = mg->mg_moremagic;
440 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
441 the length of the key. The C<hash> parameter is the precomputed hash
442 value; if it is zero then Perl will compute it. The return value will be
443 NULL if the operation failed or if the value did not need to be actually
444 stored within the hash (as in the case of tied hashes). Otherwise it can
445 be dereferenced to get the original C<SV*>. Note that the caller is
446 responsible for suitably incrementing the reference count of C<val> before
447 the call, and decrementing it if the function returned NULL.
449 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
450 information on how to use this function on tied hashes.
456 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
461 register HE **oentry;
462 bool is_utf8 = FALSE;
463 const char *keysave = key;
473 xhv = (XPVHV*)SvANY(hv);
477 hv_magic_check (hv, &needs_copy, &needs_store);
479 mg_copy((SV*)hv, val, key, klen);
480 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store)
482 #ifdef ENV_IS_CASELESS
483 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
484 key = savepvn(key,klen);
485 key = (const char*)strupr((char*)key);
493 STRLEN tmplen = klen;
494 /* See the note in hv_fetch(). --jhi */
495 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
497 HvUTF8KEYS_on((SV*)hv);
501 PERL_HASH(hash, key, klen);
503 if (!xhv->xhv_array /* !HvARRAY(hv) */)
504 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
505 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
508 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
509 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
512 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
513 if (HeHASH(entry) != hash) /* strings can't be equal */
515 if (HeKLEN(entry) != klen)
517 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
519 if (HeKUTF8(entry) != (char)is_utf8)
521 if (HeVAL(entry) == &PL_sv_undef)
522 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
524 SvREFCNT_dec(HeVAL(entry));
528 return &HeVAL(entry);
531 if (SvREADONLY(hv)) {
532 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
533 "Attempt to access disallowed key '%"SVf"' to a fixed hash"
539 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
540 else /* gotta do the real thing */
541 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
545 HeNEXT(entry) = *oentry;
548 xhv->xhv_keys++; /* HvKEYS(hv)++ */
549 if (i) { /* initial entry? */
550 xhv->xhv_fill++; /* HvFILL(hv)++ */
551 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
555 return &HeVAL(entry);
559 =for apidoc hv_store_ent
561 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
562 parameter is the precomputed hash value; if it is zero then Perl will
563 compute it. The return value is the new hash entry so created. It will be
564 NULL if the operation failed or if the value did not need to be actually
565 stored within the hash (as in the case of tied hashes). Otherwise the
566 contents of the return value can be accessed using the C<He?> macros
567 described here. Note that the caller is responsible for suitably
568 incrementing the reference count of C<val> before the call, and
569 decrementing it if the function returned NULL.
571 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
572 information on how to use this function on tied hashes.
578 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
585 register HE **oentry;
592 xhv = (XPVHV*)SvANY(hv);
596 hv_magic_check (hv, &needs_copy, &needs_store);
598 bool save_taint = PL_tainted;
600 PL_tainted = SvTAINTED(keysv);
601 keysv = sv_2mortal(newSVsv(keysv));
602 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
603 TAINT_IF(save_taint);
604 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
606 #ifdef ENV_IS_CASELESS
607 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
608 key = SvPV(keysv, klen);
609 keysv = sv_2mortal(newSVpvn(key,klen));
610 (void)strupr(SvPVX(keysv));
617 keysave = key = SvPV(keysv, klen);
618 is_utf8 = (SvUTF8(keysv) != 0);
621 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
622 HvUTF8KEYS_on((SV*)hv);
626 PERL_HASH(hash, key, klen);
628 if (!xhv->xhv_array /* !HvARRAY(hv) */)
629 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
630 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
633 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
634 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
637 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
638 if (HeHASH(entry) != hash) /* strings can't be equal */
640 if (HeKLEN(entry) != klen)
642 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
644 if (HeKUTF8(entry) != (char)is_utf8)
646 if (HeVAL(entry) == &PL_sv_undef)
647 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
649 SvREFCNT_dec(HeVAL(entry));
656 if (SvREADONLY(hv)) {
657 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
658 "Attempt to access disallowed key '%"SVf"' to a fixed hash"
664 HeKEY_hek(entry) = share_hek(key, is_utf8?-(I32)klen:klen, hash);
665 else /* gotta do the real thing */
666 HeKEY_hek(entry) = save_hek(key, is_utf8?-(I32)klen:klen, hash);
670 HeNEXT(entry) = *oentry;
673 xhv->xhv_keys++; /* HvKEYS(hv)++ */
674 if (i) { /* initial entry? */
675 xhv->xhv_fill++; /* HvFILL(hv)++ */
676 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
684 =for apidoc hv_delete
686 Deletes a key/value pair in the hash. The value SV is removed from the
687 hash and returned to the caller. The C<klen> is the length of the key.
688 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
695 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
701 register HE **oentry;
704 bool is_utf8 = FALSE;
705 const char *keysave = key;
713 if (SvRMAGICAL(hv)) {
716 hv_magic_check (hv, &needs_copy, &needs_store);
718 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
722 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
723 /* No longer an element */
724 sv_unmagic(sv, PERL_MAGIC_tiedelem);
727 return Nullsv; /* element cannot be deleted */
729 #ifdef ENV_IS_CASELESS
730 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
731 sv = sv_2mortal(newSVpvn(key,klen));
732 key = strupr(SvPVX(sv));
737 xhv = (XPVHV*)SvANY(hv);
738 if (!xhv->xhv_array /* !HvARRAY(hv) */)
742 STRLEN tmplen = klen;
743 /* See the note in hv_fetch(). --jhi */
744 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
748 PERL_HASH(hash, key, klen);
750 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
751 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
754 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
755 if (HeHASH(entry) != hash) /* strings can't be equal */
757 if (HeKLEN(entry) != klen)
759 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
761 if (HeKUTF8(entry) != (char)is_utf8)
765 /* if placeholder is here, it's already been deleted.... */
766 if (HeVAL(entry) == &PL_sv_undef)
769 return Nullsv; /* if still SvREADONLY, leave it deleted. */
771 /* okay, really delete the placeholder... */
772 *oentry = HeNEXT(entry);
774 xhv->xhv_fill--; /* HvFILL(hv)-- */
775 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
778 hv_free_ent(hv, entry);
779 xhv->xhv_keys--; /* HvKEYS(hv)-- */
780 if (xhv->xhv_keys == 0)
782 xhv->xhv_placeholders--;
786 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
787 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
788 "Attempt to delete readonly key '%"SVf"' from a fixed hash"
792 if (flags & G_DISCARD)
795 sv = sv_2mortal(HeVAL(entry));
796 HeVAL(entry) = &PL_sv_undef;
800 * If a restricted hash, rather than really deleting the entry, put
801 * a placeholder there. This marks the key as being "approved", so
802 * we can still access via not-really-existing key without raising
805 if (SvREADONLY(hv)) {
806 HeVAL(entry) = &PL_sv_undef;
807 /* We'll be saving this slot, so the number of allocated keys
808 * doesn't go down, but the number placeholders goes up */
809 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
811 *oentry = HeNEXT(entry);
813 xhv->xhv_fill--; /* HvFILL(hv)-- */
814 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
817 hv_free_ent(hv, entry);
818 xhv->xhv_keys--; /* HvKEYS(hv)-- */
819 if (xhv->xhv_keys == 0)
824 if (SvREADONLY(hv)) {
825 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
826 "Attempt to access disallowed key '%"SVf"' from a fixed hash"
836 =for apidoc hv_delete_ent
838 Deletes a key/value pair in the hash. The value SV is removed from the
839 hash and returned to the caller. The C<flags> value will normally be zero;
840 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
841 precomputed hash value, or 0 to ask for it to be computed.
847 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
854 register HE **oentry;
861 if (SvRMAGICAL(hv)) {
864 hv_magic_check (hv, &needs_copy, &needs_store);
866 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
870 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
871 /* No longer an element */
872 sv_unmagic(sv, PERL_MAGIC_tiedelem);
875 return Nullsv; /* element cannot be deleted */
877 #ifdef ENV_IS_CASELESS
878 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
879 key = SvPV(keysv, klen);
880 keysv = sv_2mortal(newSVpvn(key,klen));
881 (void)strupr(SvPVX(keysv));
887 xhv = (XPVHV*)SvANY(hv);
888 if (!xhv->xhv_array /* !HvARRAY(hv) */)
891 keysave = key = SvPV(keysv, klen);
892 is_utf8 = (SvUTF8(keysv) != 0);
895 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
898 PERL_HASH(hash, key, klen);
900 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
901 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
904 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
905 if (HeHASH(entry) != hash) /* strings can't be equal */
907 if (HeKLEN(entry) != klen)
909 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
911 if (HeKUTF8(entry) != (char)is_utf8)
916 /* if placeholder is here, it's already been deleted.... */
917 if (HeVAL(entry) == &PL_sv_undef)
920 return Nullsv; /* if still SvREADONLY, leave it deleted. */
922 /* okay, really delete the placeholder. */
923 *oentry = HeNEXT(entry);
925 xhv->xhv_fill--; /* HvFILL(hv)-- */
926 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
929 hv_free_ent(hv, entry);
930 xhv->xhv_keys--; /* HvKEYS(hv)-- */
931 if (xhv->xhv_keys == 0)
933 xhv->xhv_placeholders--;
936 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
937 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
938 "Attempt to delete readonly key '%"SVf"' from a fixed hash"
942 if (flags & G_DISCARD)
945 sv = sv_2mortal(HeVAL(entry));
946 HeVAL(entry) = &PL_sv_undef;
950 * If a restricted hash, rather than really deleting the entry, put
951 * a placeholder there. This marks the key as being "approved", so
952 * we can still access via not-really-existing key without raising
955 if (SvREADONLY(hv)) {
956 HeVAL(entry) = &PL_sv_undef;
957 /* We'll be saving this slot, so the number of allocated keys
958 * doesn't go down, but the number placeholders goes up */
959 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
961 *oentry = HeNEXT(entry);
963 xhv->xhv_fill--; /* HvFILL(hv)-- */
964 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
967 hv_free_ent(hv, entry);
968 xhv->xhv_keys--; /* HvKEYS(hv)-- */
969 if (xhv->xhv_keys == 0)
974 if (SvREADONLY(hv)) {
975 Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
976 "Attempt to delete disallowed key '%"SVf"' from a fixed hash"
986 =for apidoc hv_exists
988 Returns a boolean indicating whether the specified hash key exists. The
989 C<klen> is the length of the key.
995 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
1001 bool is_utf8 = FALSE;
1002 const char *keysave = key;
1012 if (SvRMAGICAL(hv)) {
1013 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1014 sv = sv_newmortal();
1015 mg_copy((SV*)hv, sv, key, klen);
1016 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
1019 #ifdef ENV_IS_CASELESS
1020 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1021 sv = sv_2mortal(newSVpvn(key,klen));
1022 key = strupr(SvPVX(sv));
1027 xhv = (XPVHV*)SvANY(hv);
1028 #ifndef DYNAMIC_ENV_FETCH
1029 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1034 STRLEN tmplen = klen;
1035 /* See the note in hv_fetch(). --jhi */
1036 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1040 PERL_HASH(hash, key, klen);
1042 #ifdef DYNAMIC_ENV_FETCH
1043 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1046 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1047 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1048 for (; entry; entry = HeNEXT(entry)) {
1049 if (HeHASH(entry) != hash) /* strings can't be equal */
1051 if (HeKLEN(entry) != klen)
1053 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1055 if (HeKUTF8(entry) != (char)is_utf8)
1059 /* If we find the key, but the value is a placeholder, return false. */
1060 if (HeVAL(entry) == &PL_sv_undef)
1065 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1066 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1068 char *env = PerlEnv_ENVgetenv_len(key,&len);
1070 sv = newSVpvn(env,len);
1072 (void)hv_store(hv,key,klen,sv,hash);
1084 =for apidoc hv_exists_ent
1086 Returns a boolean indicating whether the specified hash key exists. C<hash>
1087 can be a valid precomputed hash value, or 0 to ask for it to be
1094 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1096 register XPVHV* xhv;
1107 if (SvRMAGICAL(hv)) {
1108 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1109 SV* svret = sv_newmortal();
1110 sv = sv_newmortal();
1111 keysv = sv_2mortal(newSVsv(keysv));
1112 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1113 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1114 return SvTRUE(svret);
1116 #ifdef ENV_IS_CASELESS
1117 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1118 key = SvPV(keysv, klen);
1119 keysv = sv_2mortal(newSVpvn(key,klen));
1120 (void)strupr(SvPVX(keysv));
1126 xhv = (XPVHV*)SvANY(hv);
1127 #ifndef DYNAMIC_ENV_FETCH
1128 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1132 keysave = key = SvPV(keysv, klen);
1133 is_utf8 = (SvUTF8(keysv) != 0);
1135 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1137 PERL_HASH(hash, key, klen);
1139 #ifdef DYNAMIC_ENV_FETCH
1140 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1143 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1144 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1145 for (; entry; entry = HeNEXT(entry)) {
1146 if (HeHASH(entry) != hash) /* strings can't be equal */
1148 if (HeKLEN(entry) != klen)
1150 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1152 if (HeKUTF8(entry) != (char)is_utf8)
1156 /* If we find the key, but the value is a placeholder, return false. */
1157 if (HeVAL(entry) == &PL_sv_undef)
1161 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1162 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1164 char *env = PerlEnv_ENVgetenv_len(key,&len);
1166 sv = newSVpvn(env,len);
1168 (void)hv_store_ent(hv,keysv,sv,hash);
1179 S_hsplit(pTHX_ HV *hv)
1181 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1182 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1183 register I32 newsize = oldsize * 2;
1185 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1189 register HE **oentry;
1192 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1193 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1199 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1204 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1205 if (oldsize >= 64) {
1206 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1207 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1210 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1214 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1215 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1216 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1219 for (i=0; i<oldsize; i++,aep++) {
1220 if (!*aep) /* non-existent */
1223 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1224 if ((HeHASH(entry) & newsize) != i) {
1225 *oentry = HeNEXT(entry);
1226 HeNEXT(entry) = *bep;
1228 xhv->xhv_fill++; /* HvFILL(hv)++ */
1233 oentry = &HeNEXT(entry);
1235 if (!*aep) /* everything moved */
1236 xhv->xhv_fill--; /* HvFILL(hv)-- */
1241 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1243 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1244 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1245 register I32 newsize;
1251 register HE **oentry;
1253 newsize = (I32) newmax; /* possible truncation here */
1254 if (newsize != newmax || newmax <= oldsize)
1256 while ((newsize & (1 + ~newsize)) != newsize) {
1257 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1259 if (newsize < newmax)
1261 if (newsize < newmax)
1262 return; /* overflow detection */
1264 a = xhv->xhv_array; /* HvARRAY(hv) */
1267 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1268 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1274 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1279 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1280 if (oldsize >= 64) {
1281 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1282 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1285 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1288 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1291 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1293 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1294 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1295 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1299 for (i=0; i<oldsize; i++,aep++) {
1300 if (!*aep) /* non-existent */
1302 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1303 if ((j = (HeHASH(entry) & newsize)) != i) {
1305 *oentry = HeNEXT(entry);
1306 if (!(HeNEXT(entry) = aep[j]))
1307 xhv->xhv_fill++; /* HvFILL(hv)++ */
1312 oentry = &HeNEXT(entry);
1314 if (!*aep) /* everything moved */
1315 xhv->xhv_fill--; /* HvFILL(hv)-- */
1322 Creates a new HV. The reference count is set to 1.
1331 register XPVHV* xhv;
1333 hv = (HV*)NEWSV(502,0);
1334 sv_upgrade((SV *)hv, SVt_PVHV);
1335 xhv = (XPVHV*)SvANY(hv);
1338 #ifndef NODEFAULT_SHAREKEYS
1339 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1341 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1342 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1343 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1344 (void)hv_iterinit(hv); /* so each() will start off right */
1349 Perl_newHVhv(pTHX_ HV *ohv)
1352 STRLEN hv_max, hv_fill;
1354 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1356 hv_max = HvMAX(ohv);
1358 if (!SvMAGICAL((SV *)ohv)) {
1359 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1360 int i, shared = !!HvSHAREKEYS(ohv);
1361 HE **ents, **oents = (HE **)HvARRAY(ohv);
1363 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1366 /* In each bucket... */
1367 for (i = 0; i <= hv_max; i++) {
1368 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1375 /* Copy the linked list of entries. */
1376 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1377 U32 hash = HeHASH(oent);
1378 char *key = HeKEY(oent);
1379 STRLEN len = HeKLEN_UTF8(oent);
1382 HeVAL(ent) = newSVsv(HeVAL(oent));
1383 HeKEY_hek(ent) = shared ? share_hek(key, len, hash)
1384 : save_hek(key, len, hash);
1395 HvFILL(hv) = hv_fill;
1396 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1400 /* Iterate over ohv, copying keys and values one at a time. */
1402 I32 riter = HvRITER(ohv);
1403 HE *eiter = HvEITER(ohv);
1405 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1406 while (hv_max && hv_max + 1 >= hv_fill * 2)
1407 hv_max = hv_max / 2;
1411 while ((entry = hv_iternext(ohv))) {
1412 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1413 newSVsv(HeVAL(entry)), HeHASH(entry));
1415 HvRITER(ohv) = riter;
1416 HvEITER(ohv) = eiter;
1423 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1430 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1431 PL_sub_generation++; /* may be deletion of method from stash */
1433 if (HeKLEN(entry) == HEf_SVKEY) {
1434 SvREFCNT_dec(HeKEY_sv(entry));
1435 Safefree(HeKEY_hek(entry));
1437 else if (HvSHAREKEYS(hv))
1438 unshare_hek(HeKEY_hek(entry));
1440 Safefree(HeKEY_hek(entry));
1445 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1449 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1450 PL_sub_generation++; /* may be deletion of method from stash */
1451 sv_2mortal(HeVAL(entry)); /* free between statements */
1452 if (HeKLEN(entry) == HEf_SVKEY) {
1453 sv_2mortal(HeKEY_sv(entry));
1454 Safefree(HeKEY_hek(entry));
1456 else if (HvSHAREKEYS(hv))
1457 unshare_hek(HeKEY_hek(entry));
1459 Safefree(HeKEY_hek(entry));
1464 =for apidoc hv_clear
1466 Clears a hash, making it empty.
1472 Perl_hv_clear(pTHX_ HV *hv)
1474 register XPVHV* xhv;
1478 if(SvREADONLY(hv)) {
1479 Perl_croak(aTHX_ "Attempt to clear a fixed hash");
1482 xhv = (XPVHV*)SvANY(hv);
1484 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1485 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1486 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1487 if (xhv->xhv_array /* HvARRAY(hv) */)
1488 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1489 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1498 S_hfreeentries(pTHX_ HV *hv)
1500 register HE **array;
1502 register HE *oentry = Null(HE*);
1513 array = HvARRAY(hv);
1518 entry = HeNEXT(entry);
1519 hv_free_ent(hv, oentry);
1524 entry = array[riter];
1527 (void)hv_iterinit(hv);
1531 =for apidoc hv_undef
1539 Perl_hv_undef(pTHX_ HV *hv)
1541 register XPVHV* xhv;
1544 xhv = (XPVHV*)SvANY(hv);
1546 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1548 Safefree(HvNAME(hv));
1551 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1552 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1553 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1554 xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
1555 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1562 =for apidoc hv_iterinit
1564 Prepares a starting point to traverse a hash table. Returns the number of
1565 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1566 currently only meaningful for hashes without tie magic.
1568 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1569 hash buckets that happen to be in use. If you still need that esoteric
1570 value, you can get it through the macro C<HvFILL(tb)>.
1576 Perl_hv_iterinit(pTHX_ HV *hv)
1578 register XPVHV* xhv;
1582 Perl_croak(aTHX_ "Bad hash");
1583 xhv = (XPVHV*)SvANY(hv);
1584 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1585 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1587 hv_free_ent(hv, entry);
1589 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1590 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1591 /* used to be xhv->xhv_fill before 5.004_65 */
1592 return XHvTOTALKEYS(xhv);
1596 =for apidoc hv_iternext
1598 Returns entries from a hash iterator. See C<hv_iterinit>.
1604 Perl_hv_iternext(pTHX_ HV *hv)
1606 register XPVHV* xhv;
1612 Perl_croak(aTHX_ "Bad hash");
1613 xhv = (XPVHV*)SvANY(hv);
1614 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1616 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1617 SV *key = sv_newmortal();
1619 sv_setsv(key, HeSVKEY_force(entry));
1620 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1626 /* one HE per MAGICAL hash */
1627 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1629 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1631 HeKEY_hek(entry) = hek;
1632 HeKLEN(entry) = HEf_SVKEY;
1634 magic_nextpack((SV*) hv,mg,key);
1636 /* force key to stay around until next time */
1637 HeSVKEY_set(entry, SvREFCNT_inc(key));
1638 return entry; /* beware, hent_val is not set */
1641 SvREFCNT_dec(HeVAL(entry));
1642 Safefree(HeKEY_hek(entry));
1644 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1647 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1648 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1652 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1653 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1654 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1658 entry = HeNEXT(entry);
1660 * Skip past any placeholders -- don't want to include them in
1663 while (entry && HeVAL(entry) == &PL_sv_undef) {
1664 entry = HeNEXT(entry);
1668 xhv->xhv_riter++; /* HvRITER(hv)++ */
1669 if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1670 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1673 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1674 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1676 /* if we have an entry, but it's a placeholder, don't count it */
1677 if (entry && HeVAL(entry) == &PL_sv_undef)
1682 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1684 hv_free_ent(hv, oldentry);
1687 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1692 =for apidoc hv_iterkey
1694 Returns the key from the current position of the hash iterator. See
1701 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1703 if (HeKLEN(entry) == HEf_SVKEY) {
1705 char *p = SvPV(HeKEY_sv(entry), len);
1710 *retlen = HeKLEN(entry);
1711 return HeKEY(entry);
1715 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1717 =for apidoc hv_iterkeysv
1719 Returns the key as an C<SV*> from the current position of the hash
1720 iterator. The return value will always be a mortal copy of the key. Also
1727 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1729 if (HeKLEN(entry) == HEf_SVKEY)
1730 return sv_mortalcopy(HeKEY_sv(entry));
1732 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1733 HeKLEN_UTF8(entry), HeHASH(entry)));
1737 =for apidoc hv_iterval
1739 Returns the value from the current position of the hash iterator. See
1746 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1748 if (SvRMAGICAL(hv)) {
1749 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1750 SV* sv = sv_newmortal();
1751 if (HeKLEN(entry) == HEf_SVKEY)
1752 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1753 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1757 return HeVAL(entry);
1761 =for apidoc hv_iternextsv
1763 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1770 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1773 if ( (he = hv_iternext(hv)) == NULL)
1775 *key = hv_iterkey(he, retlen);
1776 return hv_iterval(hv, he);
1780 =for apidoc hv_magic
1782 Adds magic to a hash. See C<sv_magic>.
1788 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1790 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1793 #if 0 /* use the macro from hv.h instead */
1796 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1798 return HEK_KEY(share_hek(sv, len, hash));
1803 /* possibly free a shared string if no one has access to it
1804 * len and hash must both be valid for str.
1807 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1809 register XPVHV* xhv;
1811 register HE **oentry;
1814 bool is_utf8 = FALSE;
1815 const char *save = str;
1818 STRLEN tmplen = -len;
1820 /* See the note in hv_fetch(). --jhi */
1821 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1825 /* what follows is the moral equivalent of:
1826 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1827 if (--*Svp == Nullsv)
1828 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1830 xhv = (XPVHV*)SvANY(PL_strtab);
1831 /* assert(xhv_array != 0) */
1833 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1834 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1835 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1836 if (HeHASH(entry) != hash) /* strings can't be equal */
1838 if (HeKLEN(entry) != len)
1840 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1842 if (HeKUTF8(entry) != (char)is_utf8)
1845 if (--HeVAL(entry) == Nullsv) {
1846 *oentry = HeNEXT(entry);
1848 xhv->xhv_fill--; /* HvFILL(hv)-- */
1849 Safefree(HeKEY_hek(entry));
1851 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1855 UNLOCK_STRTAB_MUTEX;
1858 if (!found && ckWARN_d(WARN_INTERNAL))
1859 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-existent shared string '%s'",str);
1862 /* get a (constant) string ptr from the global string table
1863 * string will get added if it is not already there.
1864 * len and hash must both be valid for str.
1867 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1869 register XPVHV* xhv;
1871 register HE **oentry;
1874 bool is_utf8 = FALSE;
1875 const char *save = str;
1878 STRLEN tmplen = -len;
1880 /* See the note in hv_fetch(). --jhi */
1881 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1885 /* what follows is the moral equivalent of:
1887 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1888 hv_store(PL_strtab, str, len, Nullsv, hash);
1890 xhv = (XPVHV*)SvANY(PL_strtab);
1891 /* assert(xhv_array != 0) */
1893 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1894 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1895 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1896 if (HeHASH(entry) != hash) /* strings can't be equal */
1898 if (HeKLEN(entry) != len)
1900 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1902 if (HeKUTF8(entry) != (char)is_utf8)
1909 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1910 HeVAL(entry) = Nullsv;
1911 HeNEXT(entry) = *oentry;
1913 xhv->xhv_keys++; /* HvKEYS(hv)++ */
1914 if (i) { /* initial entry? */
1915 xhv->xhv_fill++; /* HvFILL(hv)++ */
1916 if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
1921 ++HeVAL(entry); /* use value slot as REFCNT */
1922 UNLOCK_STRTAB_MUTEX;
1925 return HeKEY_hek(entry);