3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "I sit beside the fire and think of all that I have seen." --Bilbo
16 =head1 Hash Manipulation Functions
21 #define PERL_HASH_INTERNAL_ACCESS
24 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
34 PL_he_root = HeNEXT(he);
43 HeNEXT(p) = (HE*)PL_he_root;
54 New(54, ptr, 1008/sizeof(XPV), XPV);
55 ptr->xpv_pv = (char*)PL_he_arenaroot;
56 PL_he_arenaroot = ptr;
59 heend = &he[1008 / sizeof(HE) - 1];
62 HeNEXT(he) = (HE*)(he + 1);
70 #define new_HE() (HE*)safemalloc(sizeof(HE))
71 #define del_HE(p) safefree((char*)p)
75 #define new_HE() new_he()
76 #define del_HE(p) del_he(p)
81 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
86 New(54, k, HEK_BASESIZE + len + 2, char);
88 Copy(str, HEK_KEY(hek), len, char);
89 HEK_KEY(hek)[len] = 0;
92 HEK_FLAGS(hek) = (unsigned char)flags;
96 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
100 Perl_free_tied_hv_pool(pTHX)
103 HE *he = PL_hv_fetch_ent_mh;
105 Safefree(HeKEY_hek(he));
110 PL_hv_fetch_ent_mh = Nullhe;
113 #if defined(USE_ITHREADS)
115 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
121 /* look for it in the table first */
122 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
126 /* create anew and remember what it is */
128 ptr_table_store(PL_ptr_table, e, ret);
130 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
131 if (HeKLEN(e) == HEf_SVKEY) {
133 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
134 HeKEY_hek(ret) = (HEK*)k;
135 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
138 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
141 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
143 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
146 #endif /* USE_ITHREADS */
149 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
152 SV *sv = sv_newmortal(), *esv = sv_newmortal();
153 if (!(flags & HVhek_FREEKEY)) {
154 sv_setpvn(sv, key, klen);
157 /* Need to free saved eventually assign to mortal SV */
158 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
159 sv_usepvn(sv, (char *) key, klen);
161 if (flags & HVhek_UTF8) {
164 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
165 Perl_croak(aTHX_ SvPVX(esv), sv);
168 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
174 Returns the SV which corresponds to the specified key in the hash. The
175 C<klen> is the length of the key. If C<lval> is set then the fetch will be
176 part of a store. Check that the return value is non-null before
177 dereferencing it to an C<SV*>.
179 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
180 information on how to use this function on tied hashes.
187 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
189 bool is_utf8 = FALSE;
190 const char *keysave = key;
199 STRLEN tmplen = klen;
200 /* Just casting the &klen to (STRLEN) won't work well
201 * if STRLEN and I32 are of different widths. --jhi */
202 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
204 /* If we were able to downgrade here, then than means that we were
205 passed in a key which only had chars 0-255, but was utf8 encoded. */
208 /* If we found we were able to downgrade the string to bytes, then
209 we should flag that it needs upgrading on keys or each. */
211 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
214 return hv_fetch_flags (hv, key, klen, lval, flags);
218 S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
228 if (SvRMAGICAL(hv)) {
229 /* All this clause seems to be utf8 unaware.
230 By moving the utf8 stuff out to hv_fetch_flags I need to ensure
231 key doesn't leak. I've not tried solving the utf8-ness.
234 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
236 sv_upgrade(sv, SVt_PVLV);
237 mg_copy((SV*)hv, sv, key, klen);
238 if (flags & HVhek_FREEKEY)
241 LvTARG(sv) = sv; /* fake (SV**) */
242 return &(LvTARG(sv));
244 #ifdef ENV_IS_CASELESS
245 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
247 for (i = 0; i < klen; ++i)
248 if (isLOWER(key[i])) {
249 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
250 SV **ret = hv_fetch(hv, nkey, klen, 0);
252 ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
254 } else if (flags & HVhek_FREEKEY)
262 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
263 avoid unnecessary pointer dereferencing. */
264 xhv = (XPVHV*)SvANY(hv);
265 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
267 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
268 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
271 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
272 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
275 if (flags & HVhek_FREEKEY)
282 PERL_HASH_INTERNAL(hash, key, klen);
283 /* Yes, you do need this even though you are not "storing" because
284 you can flip the flags below if doing an lval lookup. (And that
285 was put in to give the semantics Andreas was expecting.) */
286 flags |= HVhek_REHASH;
288 PERL_HASH(hash, key, klen);
291 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
292 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
293 for (; entry; entry = HeNEXT(entry)) {
294 if (!HeKEY_hek(entry))
296 if (HeHASH(entry) != hash) /* strings can't be equal */
298 if (HeKLEN(entry) != (I32)klen)
300 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
302 /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
303 flags is 1 if utf8. need HeKFLAGS(entry) also 1.
304 xor is true if bits differ, in which case this isn't a match. */
305 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
307 if (lval && HeKFLAGS(entry) != flags) {
308 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
309 But if entry was set previously with HVhek_WASUTF8 and key now
310 doesn't (or vice versa) then we should change the key's flag,
311 as this is assignment. */
312 if (HvSHAREKEYS(hv)) {
313 /* Need to swap the key we have for a key with the flags we
314 need. As keys are shared we can't just write to the flag,
315 so we share the new one, unshare the old one. */
316 int flags_nofree = flags & ~HVhek_FREEKEY;
317 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
318 unshare_hek (HeKEY_hek(entry));
319 HeKEY_hek(entry) = new_hek;
322 HeKFLAGS(entry) = flags;
323 if (flags & HVhek_ENABLEHVKFLAGS)
326 if (flags & HVhek_FREEKEY)
328 /* if we find a placeholder, we pretend we haven't found anything */
329 if (HeVAL(entry) == &PL_sv_placeholder)
331 return &HeVAL(entry);
334 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
335 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
337 char *env = PerlEnv_ENVgetenv_len(key,&len);
339 sv = newSVpvn(env,len);
341 if (flags & HVhek_FREEKEY)
343 return hv_store(hv,key,klen,sv,hash);
347 if (!entry && SvREADONLY(hv)) {
348 S_hv_notallowed(aTHX_ flags, key, klen,
349 "access disallowed key '%"SVf"' in"
352 if (lval) { /* gonna assign to this, so it better be there */
354 return hv_store_flags(hv,key,klen,sv,hash,flags);
356 if (flags & HVhek_FREEKEY)
361 /* returns an HE * structure with the all fields set */
362 /* note that hent_val will be a mortal sv for MAGICAL hashes */
364 =for apidoc hv_fetch_ent
366 Returns the hash entry which corresponds to the specified key in the hash.
367 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
368 if you want the function to compute it. IF C<lval> is set then the fetch
369 will be part of a store. Make sure the return value is non-null before
370 accessing it. The return value when C<tb> is a tied hash is a pointer to a
371 static location, so be sure to make a copy of the structure if you need to
374 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
375 information on how to use this function on tied hashes.
381 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
395 if (SvRMAGICAL(hv)) {
396 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
398 keysv = newSVsv(keysv);
399 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
400 /* grab a fake HE/HEK pair from the pool or make a new one */
401 entry = PL_hv_fetch_ent_mh;
403 PL_hv_fetch_ent_mh = HeNEXT(entry);
407 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
408 HeKEY_hek(entry) = (HEK*)k;
410 HeNEXT(entry) = Nullhe;
411 HeSVKEY_set(entry, keysv);
413 sv_upgrade(sv, SVt_PVLV);
415 LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
418 #ifdef ENV_IS_CASELESS
419 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
421 key = SvPV(keysv, klen);
422 for (i = 0; i < klen; ++i)
423 if (isLOWER(key[i])) {
424 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
425 (void)strupr(SvPVX(nkeysv));
426 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
428 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
435 keysave = key = SvPV(keysv, klen);
436 xhv = (XPVHV*)SvANY(hv);
437 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
439 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
440 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
443 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
444 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
450 is_utf8 = (SvUTF8(keysv)!=0);
453 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
457 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
461 PERL_HASH_INTERNAL(hash, key, klen);
462 /* Yes, you do need this even though you are not "storing" because
463 you can flip the flags below if doing an lval lookup. (And that
464 was put in to give the semantics Andreas was expecting.) */
465 flags |= HVhek_REHASH;
467 if SvIsCOW_shared_hash(keysv) {
470 PERL_HASH(hash, key, klen);
474 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
475 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
476 for (; entry; entry = HeNEXT(entry)) {
477 if (HeHASH(entry) != hash) /* strings can't be equal */
479 if (HeKLEN(entry) != (I32)klen)
481 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
483 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
485 if (lval && HeKFLAGS(entry) != flags) {
486 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
487 But if entry was set previously with HVhek_WASUTF8 and key now
488 doesn't (or vice versa) then we should change the key's flag,
489 as this is assignment. */
490 if (HvSHAREKEYS(hv)) {
491 /* Need to swap the key we have for a key with the flags we
492 need. As keys are shared we can't just write to the flag,
493 so we share the new one, unshare the old one. */
494 int flags_nofree = flags & ~HVhek_FREEKEY;
495 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
496 unshare_hek (HeKEY_hek(entry));
497 HeKEY_hek(entry) = new_hek;
500 HeKFLAGS(entry) = flags;
501 if (flags & HVhek_ENABLEHVKFLAGS)
506 /* if we find a placeholder, we pretend we haven't found anything */
507 if (HeVAL(entry) == &PL_sv_placeholder)
511 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
512 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
514 char *env = PerlEnv_ENVgetenv_len(key,&len);
516 sv = newSVpvn(env,len);
518 return hv_store_ent(hv,keysv,sv,hash);
522 if (!entry && SvREADONLY(hv)) {
523 S_hv_notallowed(aTHX_ flags, key, klen,
524 "access disallowed key '%"SVf"' in"
527 if (flags & HVhek_FREEKEY)
529 if (lval) { /* gonna assign to this, so it better be there */
531 return hv_store_ent(hv,keysv,sv,hash);
537 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
539 MAGIC *mg = SvMAGIC(hv);
543 if (isUPPER(mg->mg_type)) {
545 switch (mg->mg_type) {
546 case PERL_MAGIC_tied:
548 *needs_store = FALSE;
551 mg = mg->mg_moremagic;
558 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
559 the length of the key. The C<hash> parameter is the precomputed hash
560 value; if it is zero then Perl will compute it. The return value will be
561 NULL if the operation failed or if the value did not need to be actually
562 stored within the hash (as in the case of tied hashes). Otherwise it can
563 be dereferenced to get the original C<SV*>. Note that the caller is
564 responsible for suitably incrementing the reference count of C<val> before
565 the call, and decrementing it if the function returned NULL. Effectively
566 a successful hv_store takes ownership of one reference to C<val>. This is
567 usually what you want; a newly created SV has a reference count of one, so
568 if all your code does is create SVs then store them in a hash, hv_store
569 will own the only reference to the new SV, and your code doesn't need to do
570 anything further to tidy up. hv_store is not implemented as a call to
571 hv_store_ent, and does not create a temporary SV for the key, so if your
572 key data is not already in SV form then use hv_store in preference to
575 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
576 information on how to use this function on tied hashes.
582 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
584 bool is_utf8 = FALSE;
585 const char *keysave = key;
594 STRLEN tmplen = klen;
595 /* Just casting the &klen to (STRLEN) won't work well
596 * if STRLEN and I32 are of different widths. --jhi */
597 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
599 /* If we were able to downgrade here, then than means that we were
600 passed in a key which only had chars 0-255, but was utf8 encoded. */
603 /* If we found we were able to downgrade the string to bytes, then
604 we should flag that it needs upgrading on keys or each. */
606 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
609 return hv_store_flags (hv, key, klen, val, hash, flags);
613 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
614 register U32 hash, int flags)
617 register U32 n_links;
619 register HE **oentry;
624 xhv = (XPVHV*)SvANY(hv);
628 hv_magic_check (hv, &needs_copy, &needs_store);
630 mg_copy((SV*)hv, val, key, klen);
631 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
632 if (flags & HVhek_FREEKEY)
636 #ifdef ENV_IS_CASELESS
637 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
638 key = savepvn(key,klen);
639 key = (const char*)strupr((char*)key);
647 HvHASKFLAGS_on((SV*)hv);
650 /* We don't have a pointer to the hv, so we have to replicate the
651 flag into every HEK, so that hv_iterkeysv can see it. */
652 flags |= HVhek_REHASH;
653 PERL_HASH_INTERNAL(hash, key, klen);
655 PERL_HASH(hash, key, klen);
657 if (!xhv->xhv_array /* !HvARRAY(hv) */)
658 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
659 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
662 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
663 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
667 for (entry = *oentry; entry; ++n_links, entry = HeNEXT(entry)) {
668 if (HeHASH(entry) != hash) /* strings can't be equal */
670 if (HeKLEN(entry) != (I32)klen)
672 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
674 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
676 if (HeVAL(entry) == &PL_sv_placeholder)
677 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
679 SvREFCNT_dec(HeVAL(entry));
680 if (flags & HVhek_PLACEHOLD) {
681 /* We have been requested to insert a placeholder. Currently
682 only Storable is allowed to do this. */
683 xhv->xhv_placeholders++;
684 HeVAL(entry) = &PL_sv_placeholder;
688 if (HeKFLAGS(entry) != flags) {
689 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
690 But if entry was set previously with HVhek_WASUTF8 and key now
691 doesn't (or vice versa) then we should change the key's flag,
692 as this is assignment. */
693 if (HvSHAREKEYS(hv)) {
694 /* Need to swap the key we have for a key with the flags we
695 need. As keys are shared we can't just write to the flag,
696 so we share the new one, unshare the old one. */
697 int flags_nofree = flags & ~HVhek_FREEKEY;
698 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
699 unshare_hek (HeKEY_hek(entry));
700 HeKEY_hek(entry) = new_hek;
703 HeKFLAGS(entry) = flags;
705 if (flags & HVhek_FREEKEY)
707 return &HeVAL(entry);
710 if (SvREADONLY(hv)) {
711 S_hv_notallowed(aTHX_ flags, key, klen,
712 "access disallowed key '%"SVf"' to"
717 /* share_hek_flags will do the free for us. This might be considered
720 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
721 else /* gotta do the real thing */
722 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
723 if (flags & HVhek_PLACEHOLD) {
724 /* We have been requested to insert a placeholder. Currently
725 only Storable is allowed to do this. */
726 xhv->xhv_placeholders++;
727 HeVAL(entry) = &PL_sv_placeholder;
730 HeNEXT(entry) = *oentry;
733 xhv->xhv_keys++; /* HvKEYS(hv)++ */
734 if (!n_links) { /* initial entry? */
735 xhv->xhv_fill++; /* HvFILL(hv)++ */
736 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
737 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
738 /* Use the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
739 splits on a rehashed hash, as we're not going to split it again,
740 and if someone is lucky (evil) enough to get all the keys in one
741 list they could exhaust our memory as we repeatedly double the
742 number of buckets on every entry. Linear search feels a less worse
747 return &HeVAL(entry);
751 =for apidoc hv_store_ent
753 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
754 parameter is the precomputed hash value; if it is zero then Perl will
755 compute it. The return value is the new hash entry so created. It will be
756 NULL if the operation failed or if the value did not need to be actually
757 stored within the hash (as in the case of tied hashes). Otherwise the
758 contents of the return value can be accessed using the C<He?> macros
759 described here. Note that the caller is responsible for suitably
760 incrementing the reference count of C<val> before the call, and
761 decrementing it if the function returned NULL. Effectively a successful
762 hv_store_ent takes ownership of one reference to C<val>. This is
763 usually what you want; a newly created SV has a reference count of one, so
764 if all your code does is create SVs then store them in a hash, hv_store
765 will own the only reference to the new SV, and your code doesn't need to do
766 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
767 unlike C<val> it does not take ownership of it, so maintaining the correct
768 reference count on C<key> is entirely the caller's responsibility. hv_store
769 is not implemented as a call to hv_store_ent, and does not create a temporary
770 SV for the key, so if your key data is not already in SV form then use
771 hv_store in preference to hv_store_ent.
773 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
774 information on how to use this function on tied hashes.
780 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
795 xhv = (XPVHV*)SvANY(hv);
799 hv_magic_check (hv, &needs_copy, &needs_store);
801 bool save_taint = PL_tainted;
803 PL_tainted = SvTAINTED(keysv);
804 keysv = sv_2mortal(newSVsv(keysv));
805 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
806 TAINT_IF(save_taint);
807 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
809 #ifdef ENV_IS_CASELESS
810 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
811 key = SvPV(keysv, klen);
812 keysv = sv_2mortal(newSVpvn(key,klen));
813 (void)strupr(SvPVX(keysv));
820 keysave = key = SvPV(keysv, klen);
821 is_utf8 = (SvUTF8(keysv) != 0);
824 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
828 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
829 HvHASKFLAGS_on((SV*)hv);
833 /* We don't have a pointer to the hv, so we have to replicate the
834 flag into every HEK, so that hv_iterkeysv can see it. */
835 flags |= HVhek_REHASH;
836 PERL_HASH_INTERNAL(hash, key, klen);
838 if SvIsCOW_shared_hash(keysv) {
841 PERL_HASH(hash, key, klen);
845 if (!xhv->xhv_array /* !HvARRAY(hv) */)
846 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
847 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
850 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
851 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
854 for (; entry; ++n_links, entry = HeNEXT(entry)) {
855 if (HeHASH(entry) != hash) /* strings can't be equal */
857 if (HeKLEN(entry) != (I32)klen)
859 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
861 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
863 if (HeVAL(entry) == &PL_sv_placeholder)
864 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
866 SvREFCNT_dec(HeVAL(entry));
868 if (HeKFLAGS(entry) != flags) {
869 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
870 But if entry was set previously with HVhek_WASUTF8 and key now
871 doesn't (or vice versa) then we should change the key's flag,
872 as this is assignment. */
873 if (HvSHAREKEYS(hv)) {
874 /* Need to swap the key we have for a key with the flags we
875 need. As keys are shared we can't just write to the flag,
876 so we share the new one, unshare the old one. */
877 int flags_nofree = flags & ~HVhek_FREEKEY;
878 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
879 unshare_hek (HeKEY_hek(entry));
880 HeKEY_hek(entry) = new_hek;
883 HeKFLAGS(entry) = flags;
885 if (flags & HVhek_FREEKEY)
890 if (SvREADONLY(hv)) {
891 S_hv_notallowed(aTHX_ flags, key, klen,
892 "access disallowed key '%"SVf"' to"
897 /* share_hek_flags will do the free for us. This might be considered
900 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
901 else /* gotta do the real thing */
902 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
904 HeNEXT(entry) = *oentry;
907 xhv->xhv_keys++; /* HvKEYS(hv)++ */
908 if (!n_links) { /* initial entry? */
909 xhv->xhv_fill++; /* HvFILL(hv)++ */
910 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
911 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
912 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
913 splits on a rehashed hash, as we're not going to split it again,
914 and if someone is lucky (evil) enough to get all the keys in one
915 list they could exhaust our memory as we repeatedly double the
916 number of buckets on every entry. Linear search feels a less worse
925 =for apidoc hv_delete
927 Deletes a key/value pair in the hash. The value SV is removed from the
928 hash and returned to the caller. The C<klen> is the length of the key.
929 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
936 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
942 register HE **oentry;
945 bool is_utf8 = FALSE;
947 const char *keysave = key;
955 if (SvRMAGICAL(hv)) {
958 hv_magic_check (hv, &needs_copy, &needs_store);
960 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
966 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
967 /* No longer an element */
968 sv_unmagic(sv, PERL_MAGIC_tiedelem);
971 return Nullsv; /* element cannot be deleted */
973 #ifdef ENV_IS_CASELESS
974 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
975 sv = sv_2mortal(newSVpvn(key,klen));
976 key = strupr(SvPVX(sv));
981 xhv = (XPVHV*)SvANY(hv);
982 if (!xhv->xhv_array /* !HvARRAY(hv) */)
986 STRLEN tmplen = klen;
987 /* See the note in hv_fetch(). --jhi */
988 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
991 k_flags = HVhek_UTF8;
993 k_flags |= HVhek_FREEKEY;
997 PERL_HASH_INTERNAL(hash, key, klen);
999 PERL_HASH(hash, key, klen);
1002 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1003 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1006 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1007 if (HeHASH(entry) != hash) /* strings can't be equal */
1009 if (HeKLEN(entry) != (I32)klen)
1011 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1013 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1015 if (k_flags & HVhek_FREEKEY)
1017 /* if placeholder is here, it's already been deleted.... */
1018 if (HeVAL(entry) == &PL_sv_placeholder)
1021 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1023 /* okay, really delete the placeholder... */
1024 *oentry = HeNEXT(entry);
1026 xhv->xhv_fill--; /* HvFILL(hv)-- */
1027 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1030 hv_free_ent(hv, entry);
1031 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1032 if (xhv->xhv_keys == 0)
1033 HvHASKFLAGS_off(hv);
1034 xhv->xhv_placeholders--;
1038 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1039 S_hv_notallowed(aTHX_ k_flags, key, klen,
1040 "delete readonly key '%"SVf"' from"
1044 if (flags & G_DISCARD)
1047 sv = sv_2mortal(HeVAL(entry));
1048 HeVAL(entry) = &PL_sv_placeholder;
1052 * If a restricted hash, rather than really deleting the entry, put
1053 * a placeholder there. This marks the key as being "approved", so
1054 * we can still access via not-really-existing key without raising
1057 if (SvREADONLY(hv)) {
1058 HeVAL(entry) = &PL_sv_placeholder;
1059 /* We'll be saving this slot, so the number of allocated keys
1060 * doesn't go down, but the number placeholders goes up */
1061 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1063 *oentry = HeNEXT(entry);
1065 xhv->xhv_fill--; /* HvFILL(hv)-- */
1066 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1069 hv_free_ent(hv, entry);
1070 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1071 if (xhv->xhv_keys == 0)
1072 HvHASKFLAGS_off(hv);
1076 if (SvREADONLY(hv)) {
1077 S_hv_notallowed(aTHX_ k_flags, key, klen,
1078 "access disallowed key '%"SVf"' from"
1082 if (k_flags & HVhek_FREEKEY)
1088 =for apidoc hv_delete_ent
1090 Deletes a key/value pair in the hash. The value SV is removed from the
1091 hash and returned to the caller. The C<flags> value will normally be zero;
1092 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
1093 precomputed hash value, or 0 to ask for it to be computed.
1099 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1101 register XPVHV* xhv;
1106 register HE **oentry;
1114 if (SvRMAGICAL(hv)) {
1117 hv_magic_check (hv, &needs_copy, &needs_store);
1119 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
1121 if (SvMAGICAL(sv)) {
1125 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1126 /* No longer an element */
1127 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1130 return Nullsv; /* element cannot be deleted */
1132 #ifdef ENV_IS_CASELESS
1133 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1134 key = SvPV(keysv, klen);
1135 keysv = sv_2mortal(newSVpvn(key,klen));
1136 (void)strupr(SvPVX(keysv));
1142 xhv = (XPVHV*)SvANY(hv);
1143 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1146 keysave = key = SvPV(keysv, klen);
1147 is_utf8 = (SvUTF8(keysv) != 0);
1150 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1152 k_flags = HVhek_UTF8;
1154 k_flags |= HVhek_FREEKEY;
1158 PERL_HASH_INTERNAL(hash, key, klen);
1160 PERL_HASH(hash, key, klen);
1163 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1164 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1167 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1168 if (HeHASH(entry) != hash) /* strings can't be equal */
1170 if (HeKLEN(entry) != (I32)klen)
1172 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1174 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1176 if (k_flags & HVhek_FREEKEY)
1179 /* if placeholder is here, it's already been deleted.... */
1180 if (HeVAL(entry) == &PL_sv_placeholder)
1183 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1185 /* okay, really delete the placeholder. */
1186 *oentry = HeNEXT(entry);
1188 xhv->xhv_fill--; /* HvFILL(hv)-- */
1189 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1192 hv_free_ent(hv, entry);
1193 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1194 if (xhv->xhv_keys == 0)
1195 HvHASKFLAGS_off(hv);
1196 xhv->xhv_placeholders--;
1199 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1200 S_hv_notallowed(aTHX_ k_flags, key, klen,
1201 "delete readonly key '%"SVf"' from"
1205 if (flags & G_DISCARD)
1208 sv = sv_2mortal(HeVAL(entry));
1209 HeVAL(entry) = &PL_sv_placeholder;
1213 * If a restricted hash, rather than really deleting the entry, put
1214 * a placeholder there. This marks the key as being "approved", so
1215 * we can still access via not-really-existing key without raising
1218 if (SvREADONLY(hv)) {
1219 HeVAL(entry) = &PL_sv_placeholder;
1220 /* We'll be saving this slot, so the number of allocated keys
1221 * doesn't go down, but the number placeholders goes up */
1222 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1224 *oentry = HeNEXT(entry);
1226 xhv->xhv_fill--; /* HvFILL(hv)-- */
1227 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1230 hv_free_ent(hv, entry);
1231 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1232 if (xhv->xhv_keys == 0)
1233 HvHASKFLAGS_off(hv);
1237 if (SvREADONLY(hv)) {
1238 S_hv_notallowed(aTHX_ k_flags, key, klen,
1239 "delete disallowed key '%"SVf"' from"
1243 if (k_flags & HVhek_FREEKEY)
1249 =for apidoc hv_exists
1251 Returns a boolean indicating whether the specified hash key exists. The
1252 C<klen> is the length of the key.
1258 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
1260 register XPVHV* xhv;
1264 bool is_utf8 = FALSE;
1265 const char *keysave = key;
1276 if (SvRMAGICAL(hv)) {
1277 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1278 sv = sv_newmortal();
1279 mg_copy((SV*)hv, sv, key, klen);
1280 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
1281 return (bool)SvTRUE(sv);
1283 #ifdef ENV_IS_CASELESS
1284 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1285 sv = sv_2mortal(newSVpvn(key,klen));
1286 key = strupr(SvPVX(sv));
1291 xhv = (XPVHV*)SvANY(hv);
1292 #ifndef DYNAMIC_ENV_FETCH
1293 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1298 STRLEN tmplen = klen;
1299 /* See the note in hv_fetch(). --jhi */
1300 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1303 k_flags = HVhek_UTF8;
1305 k_flags |= HVhek_FREEKEY;
1309 PERL_HASH_INTERNAL(hash, key, klen);
1311 PERL_HASH(hash, key, klen);
1314 #ifdef DYNAMIC_ENV_FETCH
1315 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1318 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1319 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1320 for (; entry; entry = HeNEXT(entry)) {
1321 if (HeHASH(entry) != hash) /* strings can't be equal */
1323 if (HeKLEN(entry) != klen)
1325 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1327 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1329 if (k_flags & HVhek_FREEKEY)
1331 /* If we find the key, but the value is a placeholder, return false. */
1332 if (HeVAL(entry) == &PL_sv_placeholder)
1337 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1338 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1340 char *env = PerlEnv_ENVgetenv_len(key,&len);
1342 sv = newSVpvn(env,len);
1344 (void)hv_store(hv,key,klen,sv,hash);
1345 if (k_flags & HVhek_FREEKEY)
1351 if (k_flags & HVhek_FREEKEY)
1358 =for apidoc hv_exists_ent
1360 Returns a boolean indicating whether the specified hash key exists. C<hash>
1361 can be a valid precomputed hash value, or 0 to ask for it to be
1368 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1370 register XPVHV* xhv;
1382 if (SvRMAGICAL(hv)) {
1383 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1384 SV* svret = sv_newmortal();
1385 sv = sv_newmortal();
1386 keysv = sv_2mortal(newSVsv(keysv));
1387 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1388 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1389 return (bool)SvTRUE(svret);
1391 #ifdef ENV_IS_CASELESS
1392 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1393 key = SvPV(keysv, klen);
1394 keysv = sv_2mortal(newSVpvn(key,klen));
1395 (void)strupr(SvPVX(keysv));
1401 xhv = (XPVHV*)SvANY(hv);
1402 #ifndef DYNAMIC_ENV_FETCH
1403 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1407 keysave = key = SvPV(keysv, klen);
1408 is_utf8 = (SvUTF8(keysv) != 0);
1410 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1412 k_flags = HVhek_UTF8;
1414 k_flags |= HVhek_FREEKEY;
1417 PERL_HASH_INTERNAL(hash, key, klen);
1419 PERL_HASH(hash, key, klen);
1421 #ifdef DYNAMIC_ENV_FETCH
1422 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1425 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1426 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1427 for (; entry; entry = HeNEXT(entry)) {
1428 if (HeHASH(entry) != hash) /* strings can't be equal */
1430 if (HeKLEN(entry) != (I32)klen)
1432 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1434 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1436 if (k_flags & HVhek_FREEKEY)
1438 /* If we find the key, but the value is a placeholder, return false. */
1439 if (HeVAL(entry) == &PL_sv_placeholder)
1443 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1444 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1446 char *env = PerlEnv_ENVgetenv_len(key,&len);
1448 sv = newSVpvn(env,len);
1450 (void)hv_store_ent(hv,keysv,sv,hash);
1451 if (k_flags & HVhek_FREEKEY)
1457 if (k_flags & HVhek_FREEKEY)
1463 S_hsplit(pTHX_ HV *hv)
1465 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1466 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1467 register I32 newsize = oldsize * 2;
1469 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1473 register HE **oentry;
1474 int longest_chain = 0;
1478 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1479 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1485 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1490 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1491 if (oldsize >= 64) {
1492 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1493 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1496 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1500 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1501 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1502 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1505 for (i=0; i<oldsize; i++,aep++) {
1506 int left_length = 0;
1507 int right_length = 0;
1509 if (!*aep) /* non-existent */
1512 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1513 if ((HeHASH(entry) & newsize) != (U32)i) {
1514 *oentry = HeNEXT(entry);
1515 HeNEXT(entry) = *bep;
1517 xhv->xhv_fill++; /* HvFILL(hv)++ */
1523 oentry = &HeNEXT(entry);
1527 if (!*aep) /* everything moved */
1528 xhv->xhv_fill--; /* HvFILL(hv)-- */
1529 /* I think we don't actually need to keep track of the longest length,
1530 merely flag if anything is too long. But for the moment while
1531 developing this code I'll track it. */
1532 if (left_length > longest_chain)
1533 longest_chain = left_length;
1534 if (right_length > longest_chain)
1535 longest_chain = right_length;
1539 /* Pick your policy for "hashing isn't working" here: */
1540 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
1545 if (hv == PL_strtab) {
1546 /* Urg. Someone is doing something nasty to the string table.
1551 /* Awooga. Awooga. Pathological data. */
1552 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1553 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1556 Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1557 was_shared = HvSHAREKEYS(hv);
1560 HvSHAREKEYS_off(hv);
1563 aep = (HE **) xhv->xhv_array;
1565 for (i=0; i<newsize; i++,aep++) {
1568 /* We're going to trash this HE's next pointer when we chain it
1569 into the new hash below, so store where we go next. */
1570 HE *next = HeNEXT(entry);
1574 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1579 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1580 hash, HeKFLAGS(entry));
1581 unshare_hek (HeKEY_hek(entry));
1582 HeKEY_hek(entry) = new_hek;
1584 /* Not shared, so simply write the new hash in. */
1585 HeHASH(entry) = hash;
1587 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1588 HEK_REHASH_on(HeKEY_hek(entry));
1589 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1591 /* Copy oentry to the correct new chain. */
1592 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1594 xhv->xhv_fill++; /* HvFILL(hv)++ */
1595 HeNEXT(entry) = *bep;
1601 Safefree (xhv->xhv_array);
1602 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1606 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1608 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1609 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1610 register I32 newsize;
1616 register HE **oentry;
1618 newsize = (I32) newmax; /* possible truncation here */
1619 if (newsize != newmax || newmax <= oldsize)
1621 while ((newsize & (1 + ~newsize)) != newsize) {
1622 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1624 if (newsize < newmax)
1626 if (newsize < newmax)
1627 return; /* overflow detection */
1629 a = xhv->xhv_array; /* HvARRAY(hv) */
1632 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1633 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1639 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1644 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1645 if (oldsize >= 64) {
1646 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1647 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1650 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1653 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1656 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1658 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1659 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1660 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1664 for (i=0; i<oldsize; i++,aep++) {
1665 if (!*aep) /* non-existent */
1667 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1668 if ((j = (HeHASH(entry) & newsize)) != i) {
1670 *oentry = HeNEXT(entry);
1671 if (!(HeNEXT(entry) = aep[j]))
1672 xhv->xhv_fill++; /* HvFILL(hv)++ */
1677 oentry = &HeNEXT(entry);
1679 if (!*aep) /* everything moved */
1680 xhv->xhv_fill--; /* HvFILL(hv)-- */
1687 Creates a new HV. The reference count is set to 1.
1696 register XPVHV* xhv;
1698 hv = (HV*)NEWSV(502,0);
1699 sv_upgrade((SV *)hv, SVt_PVHV);
1700 xhv = (XPVHV*)SvANY(hv);
1703 #ifndef NODEFAULT_SHAREKEYS
1704 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1707 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1708 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1709 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1710 (void)hv_iterinit(hv); /* so each() will start off right */
1715 Perl_newHVhv(pTHX_ HV *ohv)
1718 STRLEN hv_max, hv_fill;
1720 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1722 hv_max = HvMAX(ohv);
1724 if (!SvMAGICAL((SV *)ohv)) {
1725 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1727 bool shared = !!HvSHAREKEYS(ohv);
1728 HE **ents, **oents = (HE **)HvARRAY(ohv);
1730 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1733 /* In each bucket... */
1734 for (i = 0; i <= hv_max; i++) {
1735 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1742 /* Copy the linked list of entries. */
1743 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1744 U32 hash = HeHASH(oent);
1745 char *key = HeKEY(oent);
1746 STRLEN len = HeKLEN(oent);
1747 int flags = HeKFLAGS(oent);
1750 HeVAL(ent) = newSVsv(HeVAL(oent));
1752 = shared ? share_hek_flags(key, len, hash, flags)
1753 : save_hek_flags(key, len, hash, flags);
1764 HvFILL(hv) = hv_fill;
1765 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1769 /* Iterate over ohv, copying keys and values one at a time. */
1771 I32 riter = HvRITER(ohv);
1772 HE *eiter = HvEITER(ohv);
1774 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1775 while (hv_max && hv_max + 1 >= hv_fill * 2)
1776 hv_max = hv_max / 2;
1780 while ((entry = hv_iternext_flags(ohv, 0))) {
1781 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1782 newSVsv(HeVAL(entry)), HeHASH(entry),
1785 HvRITER(ohv) = riter;
1786 HvEITER(ohv) = eiter;
1793 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1800 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1801 PL_sub_generation++; /* may be deletion of method from stash */
1803 if (HeKLEN(entry) == HEf_SVKEY) {
1804 SvREFCNT_dec(HeKEY_sv(entry));
1805 Safefree(HeKEY_hek(entry));
1807 else if (HvSHAREKEYS(hv))
1808 unshare_hek(HeKEY_hek(entry));
1810 Safefree(HeKEY_hek(entry));
1815 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1819 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1820 PL_sub_generation++; /* may be deletion of method from stash */
1821 sv_2mortal(HeVAL(entry)); /* free between statements */
1822 if (HeKLEN(entry) == HEf_SVKEY) {
1823 sv_2mortal(HeKEY_sv(entry));
1824 Safefree(HeKEY_hek(entry));
1826 else if (HvSHAREKEYS(hv))
1827 unshare_hek(HeKEY_hek(entry));
1829 Safefree(HeKEY_hek(entry));
1834 =for apidoc hv_clear
1836 Clears a hash, making it empty.
1842 Perl_hv_clear(pTHX_ HV *hv)
1844 register XPVHV* xhv;
1848 xhv = (XPVHV*)SvANY(hv);
1850 if (SvREADONLY(hv)) {
1851 /* restricted hash: convert all keys to placeholders */
1854 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1855 entry = ((HE**)xhv->xhv_array)[i];
1856 for (; entry; entry = HeNEXT(entry)) {
1857 /* not already placeholder */
1858 if (HeVAL(entry) != &PL_sv_placeholder) {
1859 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1860 SV* keysv = hv_iterkeysv(entry);
1862 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1865 SvREFCNT_dec(HeVAL(entry));
1866 HeVAL(entry) = &PL_sv_placeholder;
1867 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1875 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1876 if (xhv->xhv_array /* HvARRAY(hv) */)
1877 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1878 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1883 HvHASKFLAGS_off(hv);
1888 S_hfreeentries(pTHX_ HV *hv)
1890 register HE **array;
1892 register HE *oentry = Null(HE*);
1903 array = HvARRAY(hv);
1904 /* make everyone else think the array is empty, so that the destructors
1905 * called for freed entries can't recusively mess with us */
1906 HvARRAY(hv) = Null(HE**);
1908 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1914 entry = HeNEXT(entry);
1915 hv_free_ent(hv, oentry);
1920 entry = array[riter];
1923 HvARRAY(hv) = array;
1924 (void)hv_iterinit(hv);
1928 =for apidoc hv_undef
1936 Perl_hv_undef(pTHX_ HV *hv)
1938 register XPVHV* xhv;
1941 xhv = (XPVHV*)SvANY(hv);
1943 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1946 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1947 Safefree(HvNAME(hv));
1950 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1951 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1952 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1959 =for apidoc hv_iterinit
1961 Prepares a starting point to traverse a hash table. Returns the number of
1962 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1963 currently only meaningful for hashes without tie magic.
1965 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1966 hash buckets that happen to be in use. If you still need that esoteric
1967 value, you can get it through the macro C<HvFILL(tb)>.
1974 Perl_hv_iterinit(pTHX_ HV *hv)
1976 register XPVHV* xhv;
1980 Perl_croak(aTHX_ "Bad hash");
1981 xhv = (XPVHV*)SvANY(hv);
1982 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1983 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1985 hv_free_ent(hv, entry);
1987 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1988 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1989 /* used to be xhv->xhv_fill before 5.004_65 */
1990 return XHvTOTALKEYS(xhv);
1993 =for apidoc hv_iternext
1995 Returns entries from a hash iterator. See C<hv_iterinit>.
1997 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1998 iterator currently points to, without losing your place or invalidating your
1999 iterator. Note that in this case the current entry is deleted from the hash
2000 with your iterator holding the last reference to it. Your iterator is flagged
2001 to free the entry on the next call to C<hv_iternext>, so you must not discard
2002 your iterator immediately else the entry will leak - call C<hv_iternext> to
2003 trigger the resource deallocation.
2009 Perl_hv_iternext(pTHX_ HV *hv)
2011 return hv_iternext_flags(hv, 0);
2015 =for apidoc hv_iternext_flags
2017 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
2018 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2019 set the placeholders keys (for restricted hashes) will be returned in addition
2020 to normal keys. By default placeholders are automatically skipped over.
2021 Currently a placeholder is implemented with a value that is
2022 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2023 restricted hashes may change, and the implementation currently is
2024 insufficiently abstracted for any change to be tidy.
2030 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2032 register XPVHV* xhv;
2038 Perl_croak(aTHX_ "Bad hash");
2039 xhv = (XPVHV*)SvANY(hv);
2040 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
2042 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
2043 SV *key = sv_newmortal();
2045 sv_setsv(key, HeSVKEY_force(entry));
2046 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2052 /* one HE per MAGICAL hash */
2053 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2055 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
2057 HeKEY_hek(entry) = hek;
2058 HeKLEN(entry) = HEf_SVKEY;
2060 magic_nextpack((SV*) hv,mg,key);
2062 /* force key to stay around until next time */
2063 HeSVKEY_set(entry, SvREFCNT_inc(key));
2064 return entry; /* beware, hent_val is not set */
2067 SvREFCNT_dec(HeVAL(entry));
2068 Safefree(HeKEY_hek(entry));
2070 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
2073 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
2074 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
2078 if (!xhv->xhv_array /* !HvARRAY(hv) */)
2079 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
2080 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
2082 /* At start of hash, entry is NULL. */
2085 entry = HeNEXT(entry);
2086 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2088 * Skip past any placeholders -- don't want to include them in
2091 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2092 entry = HeNEXT(entry);
2097 /* OK. Come to the end of the current list. Grab the next one. */
2099 xhv->xhv_riter++; /* HvRITER(hv)++ */
2100 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2101 /* There is no next one. End of the hash. */
2102 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
2105 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
2106 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
2108 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2109 /* If we have an entry, but it's a placeholder, don't count it.
2111 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2112 entry = HeNEXT(entry);
2114 /* Will loop again if this linked list starts NULL
2115 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2116 or if we run through it and find only placeholders. */
2119 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2121 hv_free_ent(hv, oldentry);
2124 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2125 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
2127 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
2132 =for apidoc hv_iterkey
2134 Returns the key from the current position of the hash iterator. See
2141 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2143 if (HeKLEN(entry) == HEf_SVKEY) {
2145 char *p = SvPV(HeKEY_sv(entry), len);
2150 *retlen = HeKLEN(entry);
2151 return HeKEY(entry);
2155 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2157 =for apidoc hv_iterkeysv
2159 Returns the key as an C<SV*> from the current position of the hash
2160 iterator. The return value will always be a mortal copy of the key. Also
2167 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2169 if (HeKLEN(entry) != HEf_SVKEY) {
2170 HEK *hek = HeKEY_hek(entry);
2171 int flags = HEK_FLAGS(hek);
2174 if (flags & HVhek_WASUTF8) {
2176 Andreas would like keys he put in as utf8 to come back as utf8
2178 STRLEN utf8_len = HEK_LEN(hek);
2179 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2181 sv = newSVpvn ((char*)as_utf8, utf8_len);
2183 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2184 } else if (flags & HVhek_REHASH) {
2185 /* We don't have a pointer to the hv, so we have to replicate the
2186 flag into every HEK. This hv is using custom a hasing
2187 algorithm. Hence we can't return a shared string scalar, as
2188 that would contain the (wrong) hash value, and might get passed
2189 into an hv routine with a regular hash */
2191 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
2195 sv = newSVpvn_share(HEK_KEY(hek),
2196 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2199 return sv_2mortal(sv);
2201 return sv_mortalcopy(HeKEY_sv(entry));
2205 =for apidoc hv_iterval
2207 Returns the value from the current position of the hash iterator. See
2214 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2216 if (SvRMAGICAL(hv)) {
2217 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2218 SV* sv = sv_newmortal();
2219 if (HeKLEN(entry) == HEf_SVKEY)
2220 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2221 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2225 return HeVAL(entry);
2229 =for apidoc hv_iternextsv
2231 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2238 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2241 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2243 *key = hv_iterkey(he, retlen);
2244 return hv_iterval(hv, he);
2248 =for apidoc hv_magic
2250 Adds magic to a hash. See C<sv_magic>.
2256 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2258 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2261 #if 0 /* use the macro from hv.h instead */
2264 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2266 return HEK_KEY(share_hek(sv, len, hash));
2271 /* possibly free a shared string if no one has access to it
2272 * len and hash must both be valid for str.
2275 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2277 unshare_hek_or_pvn (NULL, str, len, hash);
2282 Perl_unshare_hek(pTHX_ HEK *hek)
2284 unshare_hek_or_pvn(hek, NULL, 0, 0);
2287 /* possibly free a shared string if no one has access to it
2288 hek if non-NULL takes priority over the other 3, else str, len and hash
2289 are used. If so, len and hash must both be valid for str.
2292 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2294 register XPVHV* xhv;
2296 register HE **oentry;
2299 bool is_utf8 = FALSE;
2301 const char *save = str;
2304 hash = HEK_HASH(hek);
2305 } else if (len < 0) {
2306 STRLEN tmplen = -len;
2308 /* See the note in hv_fetch(). --jhi */
2309 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2312 k_flags = HVhek_UTF8;
2314 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2317 /* what follows is the moral equivalent of:
2318 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2319 if (--*Svp == Nullsv)
2320 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2322 xhv = (XPVHV*)SvANY(PL_strtab);
2323 /* assert(xhv_array != 0) */
2325 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2326 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2328 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2329 if (HeKEY_hek(entry) != hek)
2335 int flags_masked = k_flags & HVhek_MASK;
2336 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2337 if (HeHASH(entry) != hash) /* strings can't be equal */
2339 if (HeKLEN(entry) != len)
2341 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2343 if (HeKFLAGS(entry) != flags_masked)
2351 if (--HeVAL(entry) == Nullsv) {
2352 *oentry = HeNEXT(entry);
2354 xhv->xhv_fill--; /* HvFILL(hv)-- */
2355 Safefree(HeKEY_hek(entry));
2357 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2361 UNLOCK_STRTAB_MUTEX;
2362 if (!found && ckWARN_d(WARN_INTERNAL))
2363 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2364 "Attempt to free non-existent shared string '%s'%s",
2365 hek ? HEK_KEY(hek) : str,
2366 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2367 if (k_flags & HVhek_FREEKEY)
2371 /* get a (constant) string ptr from the global string table
2372 * string will get added if it is not already there.
2373 * len and hash must both be valid for str.
2376 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2378 bool is_utf8 = FALSE;
2380 const char *save = str;
2383 STRLEN tmplen = -len;
2385 /* See the note in hv_fetch(). --jhi */
2386 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2388 /* If we were able to downgrade here, then than means that we were passed
2389 in a key which only had chars 0-255, but was utf8 encoded. */
2392 /* If we found we were able to downgrade the string to bytes, then
2393 we should flag that it needs upgrading on keys or each. Also flag
2394 that we need share_hek_flags to free the string. */
2396 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2399 return share_hek_flags (str, len, hash, flags);
2403 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2405 register XPVHV* xhv;
2407 register HE **oentry;
2410 int flags_masked = flags & HVhek_MASK;
2412 /* what follows is the moral equivalent of:
2414 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2415 hv_store(PL_strtab, str, len, Nullsv, hash);
2417 Can't rehash the shared string table, so not sure if it's worth
2418 counting the number of entries in the linked list
2420 xhv = (XPVHV*)SvANY(PL_strtab);
2421 /* assert(xhv_array != 0) */
2423 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2424 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2425 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2426 if (HeHASH(entry) != hash) /* strings can't be equal */
2428 if (HeKLEN(entry) != len)
2430 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2432 if (HeKFLAGS(entry) != flags_masked)
2439 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2440 HeVAL(entry) = Nullsv;
2441 HeNEXT(entry) = *oentry;
2443 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2444 if (i) { /* initial entry? */
2445 xhv->xhv_fill++; /* HvFILL(hv)++ */
2446 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2451 ++HeVAL(entry); /* use value slot as REFCNT */
2452 UNLOCK_STRTAB_MUTEX;
2454 if (flags & HVhek_FREEKEY)
2457 return HeKEY_hek(entry);