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
23 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
33 PL_he_root = HeNEXT(he);
42 HeNEXT(p) = (HE*)PL_he_root;
53 New(54, ptr, 1008/sizeof(XPV), XPV);
54 ptr->xpv_pv = (char*)PL_he_arenaroot;
55 PL_he_arenaroot = ptr;
58 heend = &he[1008 / sizeof(HE) - 1];
61 HeNEXT(he) = (HE*)(he + 1);
69 #define new_HE() (HE*)safemalloc(sizeof(HE))
70 #define del_HE(p) safefree((char*)p)
74 #define new_HE() new_he()
75 #define del_HE(p) del_he(p)
80 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
85 New(54, k, HEK_BASESIZE + len + 2, char);
87 Copy(str, HEK_KEY(hek), len, char);
88 HEK_KEY(hek)[len] = 0;
91 HEK_FLAGS(hek) = (unsigned char)flags;
95 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
99 Perl_free_tied_hv_pool(pTHX)
102 HE *he = PL_hv_fetch_ent_mh;
104 Safefree(HeKEY_hek(he));
109 PL_hv_fetch_ent_mh = Nullhe;
112 #if defined(USE_ITHREADS)
114 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
120 /* look for it in the table first */
121 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
125 /* create anew and remember what it is */
127 ptr_table_store(PL_ptr_table, e, ret);
129 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
130 if (HeKLEN(e) == HEf_SVKEY) {
132 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
133 HeKEY_hek(ret) = (HEK*)k;
134 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
137 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
140 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
142 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
145 #endif /* USE_ITHREADS */
148 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
151 SV *sv = sv_newmortal(), *esv = sv_newmortal();
152 if (!(flags & HVhek_FREEKEY)) {
153 sv_setpvn(sv, key, klen);
156 /* Need to free saved eventually assign to mortal SV */
157 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
158 sv_usepvn(sv, (char *) key, klen);
160 if (flags & HVhek_UTF8) {
163 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
164 Perl_croak(aTHX_ SvPVX(esv), sv);
167 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
173 Returns the SV which corresponds to the specified key in the hash. The
174 C<klen> is the length of the key. If C<lval> is set then the fetch will be
175 part of a store. Check that the return value is non-null before
176 dereferencing it to an C<SV*>.
178 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
179 information on how to use this function on tied hashes.
186 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
188 bool is_utf8 = FALSE;
189 const char *keysave = key;
198 STRLEN tmplen = klen;
199 /* Just casting the &klen to (STRLEN) won't work well
200 * if STRLEN and I32 are of different widths. --jhi */
201 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
203 /* If we were able to downgrade here, then than means that we were
204 passed in a key which only had chars 0-255, but was utf8 encoded. */
207 /* If we found we were able to downgrade the string to bytes, then
208 we should flag that it needs upgrading on keys or each. */
210 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
213 return hv_fetch_flags (hv, key, klen, lval, flags);
217 S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
227 if (SvRMAGICAL(hv)) {
228 /* All this clause seems to be utf8 unaware.
229 By moving the utf8 stuff out to hv_fetch_flags I need to ensure
230 key doesn't leak. I've not tried solving the utf8-ness.
233 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
235 sv_upgrade(sv, SVt_PVLV);
236 mg_copy((SV*)hv, sv, key, klen);
237 if (flags & HVhek_FREEKEY)
240 LvTARG(sv) = sv; /* fake (SV**) */
241 return &(LvTARG(sv));
243 #ifdef ENV_IS_CASELESS
244 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
246 for (i = 0; i < klen; ++i)
247 if (isLOWER(key[i])) {
248 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
249 SV **ret = hv_fetch(hv, nkey, klen, 0);
251 ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
253 } else if (flags & HVhek_FREEKEY)
261 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
262 avoid unnecessary pointer dereferencing. */
263 xhv = (XPVHV*)SvANY(hv);
264 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
266 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
267 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
270 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
271 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
274 if (flags & HVhek_FREEKEY)
281 PERL_HASH_INTERNAL(hash, key, klen);
282 /* Yes, you do need this even though you are not "storing" because
283 you can flip the flags below if doing an lval lookup. (And that
284 was put in to give the semantics Andreas was expecting.) */
285 flags |= HVhek_REHASH;
287 PERL_HASH(hash, key, klen);
290 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
291 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
292 for (; entry; entry = HeNEXT(entry)) {
293 if (!HeKEY_hek(entry))
295 if (HeHASH(entry) != hash) /* strings can't be equal */
297 if (HeKLEN(entry) != (I32)klen)
299 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
301 /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
302 flags is 1 if utf8. need HeKFLAGS(entry) also 1.
303 xor is true if bits differ, in which case this isn't a match. */
304 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
306 if (lval && HeKFLAGS(entry) != flags) {
307 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
308 But if entry was set previously with HVhek_WASUTF8 and key now
309 doesn't (or vice versa) then we should change the key's flag,
310 as this is assignment. */
311 if (HvSHAREKEYS(hv)) {
312 /* Need to swap the key we have for a key with the flags we
313 need. As keys are shared we can't just write to the flag,
314 so we share the new one, unshare the old one. */
315 int flags_nofree = flags & ~HVhek_FREEKEY;
316 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
317 unshare_hek (HeKEY_hek(entry));
318 HeKEY_hek(entry) = new_hek;
321 HeKFLAGS(entry) = flags;
322 if (flags & HVhek_ENABLEHVKFLAGS)
325 if (flags & HVhek_FREEKEY)
327 /* if we find a placeholder, we pretend we haven't found anything */
328 if (HeVAL(entry) == &PL_sv_placeholder)
330 return &HeVAL(entry);
333 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
334 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
336 char *env = PerlEnv_ENVgetenv_len(key,&len);
338 sv = newSVpvn(env,len);
340 if (flags & HVhek_FREEKEY)
342 return hv_store(hv,key,klen,sv,hash);
346 if (!entry && SvREADONLY(hv)) {
347 S_hv_notallowed(aTHX_ flags, key, klen,
348 "access disallowed key '%"SVf"' in"
351 if (lval) { /* gonna assign to this, so it better be there */
353 return hv_store_flags(hv,key,klen,sv,hash,flags);
355 if (flags & HVhek_FREEKEY)
360 /* returns an HE * structure with the all fields set */
361 /* note that hent_val will be a mortal sv for MAGICAL hashes */
363 =for apidoc hv_fetch_ent
365 Returns the hash entry which corresponds to the specified key in the hash.
366 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
367 if you want the function to compute it. IF C<lval> is set then the fetch
368 will be part of a store. Make sure the return value is non-null before
369 accessing it. The return value when C<tb> is a tied hash is a pointer to a
370 static location, so be sure to make a copy of the structure if you need to
373 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
374 information on how to use this function on tied hashes.
380 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
394 if (SvRMAGICAL(hv)) {
395 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
397 keysv = newSVsv(keysv);
398 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
399 /* grab a fake HE/HEK pair from the pool or make a new one */
400 entry = PL_hv_fetch_ent_mh;
402 PL_hv_fetch_ent_mh = HeNEXT(entry);
406 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
407 HeKEY_hek(entry) = (HEK*)k;
409 HeNEXT(entry) = Nullhe;
410 HeSVKEY_set(entry, keysv);
412 sv_upgrade(sv, SVt_PVLV);
414 LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
417 #ifdef ENV_IS_CASELESS
418 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
420 key = SvPV(keysv, klen);
421 for (i = 0; i < klen; ++i)
422 if (isLOWER(key[i])) {
423 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
424 (void)strupr(SvPVX(nkeysv));
425 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
427 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
434 keysave = key = SvPV(keysv, klen);
435 xhv = (XPVHV*)SvANY(hv);
436 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
438 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
439 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
442 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
443 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
449 is_utf8 = (SvUTF8(keysv)!=0);
452 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
456 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
460 PERL_HASH_INTERNAL(hash, key, klen);
461 /* Yes, you do need this even though you are not "storing" because
462 you can flip the flags below if doing an lval lookup. (And that
463 was put in to give the semantics Andreas was expecting.) */
464 flags |= HVhek_REHASH;
466 if SvIsCOW_shared_hash(keysv) {
469 PERL_HASH(hash, key, klen);
473 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
474 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
475 for (; entry; entry = HeNEXT(entry)) {
476 if (HeHASH(entry) != hash) /* strings can't be equal */
478 if (HeKLEN(entry) != (I32)klen)
480 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
482 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
484 if (lval && HeKFLAGS(entry) != flags) {
485 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
486 But if entry was set previously with HVhek_WASUTF8 and key now
487 doesn't (or vice versa) then we should change the key's flag,
488 as this is assignment. */
489 if (HvSHAREKEYS(hv)) {
490 /* Need to swap the key we have for a key with the flags we
491 need. As keys are shared we can't just write to the flag,
492 so we share the new one, unshare the old one. */
493 int flags_nofree = flags & ~HVhek_FREEKEY;
494 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
495 unshare_hek (HeKEY_hek(entry));
496 HeKEY_hek(entry) = new_hek;
499 HeKFLAGS(entry) = flags;
500 if (flags & HVhek_ENABLEHVKFLAGS)
505 /* if we find a placeholder, we pretend we haven't found anything */
506 if (HeVAL(entry) == &PL_sv_placeholder)
510 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
511 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
513 char *env = PerlEnv_ENVgetenv_len(key,&len);
515 sv = newSVpvn(env,len);
517 return hv_store_ent(hv,keysv,sv,hash);
521 if (!entry && SvREADONLY(hv)) {
522 S_hv_notallowed(aTHX_ flags, key, klen,
523 "access disallowed key '%"SVf"' in"
526 if (flags & HVhek_FREEKEY)
528 if (lval) { /* gonna assign to this, so it better be there */
530 return hv_store_ent(hv,keysv,sv,hash);
536 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
538 MAGIC *mg = SvMAGIC(hv);
542 if (isUPPER(mg->mg_type)) {
544 switch (mg->mg_type) {
545 case PERL_MAGIC_tied:
547 *needs_store = FALSE;
550 mg = mg->mg_moremagic;
557 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
558 the length of the key. The C<hash> parameter is the precomputed hash
559 value; if it is zero then Perl will compute it. The return value will be
560 NULL if the operation failed or if the value did not need to be actually
561 stored within the hash (as in the case of tied hashes). Otherwise it can
562 be dereferenced to get the original C<SV*>. Note that the caller is
563 responsible for suitably incrementing the reference count of C<val> before
564 the call, and decrementing it if the function returned NULL. Effectively
565 a successful hv_store takes ownership of one reference to C<val>. This is
566 usually what you want; a newly created SV has a reference count of one, so
567 if all your code does is create SVs then store them in a hash, hv_store
568 will own the only reference to the new SV, and your code doesn't need to do
569 anything further to tidy up. hv_store is not implemented as a call to
570 hv_store_ent, and does not create a temporary SV for the key, so if your
571 key data is not already in SV form then use hv_store in preference to
574 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
575 information on how to use this function on tied hashes.
581 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
583 bool is_utf8 = FALSE;
584 const char *keysave = key;
593 STRLEN tmplen = klen;
594 /* Just casting the &klen to (STRLEN) won't work well
595 * if STRLEN and I32 are of different widths. --jhi */
596 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
598 /* If we were able to downgrade here, then than means that we were
599 passed in a key which only had chars 0-255, but was utf8 encoded. */
602 /* If we found we were able to downgrade the string to bytes, then
603 we should flag that it needs upgrading on keys or each. */
605 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
608 return hv_store_flags (hv, key, klen, val, hash, flags);
612 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
613 register U32 hash, int flags)
616 register U32 n_links;
618 register HE **oentry;
623 xhv = (XPVHV*)SvANY(hv);
627 hv_magic_check (hv, &needs_copy, &needs_store);
629 mg_copy((SV*)hv, val, key, klen);
630 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
631 if (flags & HVhek_FREEKEY)
635 #ifdef ENV_IS_CASELESS
636 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
637 key = savepvn(key,klen);
638 key = (const char*)strupr((char*)key);
646 HvHASKFLAGS_on((SV*)hv);
649 /* We don't have a pointer to the hv, so we have to replicate the
650 flag into every HEK, so that hv_iterkeysv can see it. */
651 flags |= HVhek_REHASH;
652 PERL_HASH_INTERNAL(hash, key, klen);
654 PERL_HASH(hash, key, klen);
656 if (!xhv->xhv_array /* !HvARRAY(hv) */)
657 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
658 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
661 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
662 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
666 for (entry = *oentry; entry; ++n_links, entry = HeNEXT(entry)) {
667 if (HeHASH(entry) != hash) /* strings can't be equal */
669 if (HeKLEN(entry) != (I32)klen)
671 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
673 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
675 if (HeVAL(entry) == &PL_sv_placeholder)
676 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
678 SvREFCNT_dec(HeVAL(entry));
679 if (flags & HVhek_PLACEHOLD) {
680 /* We have been requested to insert a placeholder. Currently
681 only Storable is allowed to do this. */
682 xhv->xhv_placeholders++;
683 HeVAL(entry) = &PL_sv_placeholder;
687 if (HeKFLAGS(entry) != flags) {
688 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
689 But if entry was set previously with HVhek_WASUTF8 and key now
690 doesn't (or vice versa) then we should change the key's flag,
691 as this is assignment. */
692 if (HvSHAREKEYS(hv)) {
693 /* Need to swap the key we have for a key with the flags we
694 need. As keys are shared we can't just write to the flag,
695 so we share the new one, unshare the old one. */
696 int flags_nofree = flags & ~HVhek_FREEKEY;
697 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
698 unshare_hek (HeKEY_hek(entry));
699 HeKEY_hek(entry) = new_hek;
702 HeKFLAGS(entry) = flags;
704 if (flags & HVhek_FREEKEY)
706 return &HeVAL(entry);
709 if (SvREADONLY(hv)) {
710 S_hv_notallowed(aTHX_ flags, key, klen,
711 "access disallowed key '%"SVf"' to"
716 /* share_hek_flags will do the free for us. This might be considered
719 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
720 else /* gotta do the real thing */
721 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
722 if (flags & HVhek_PLACEHOLD) {
723 /* We have been requested to insert a placeholder. Currently
724 only Storable is allowed to do this. */
725 xhv->xhv_placeholders++;
726 HeVAL(entry) = &PL_sv_placeholder;
729 HeNEXT(entry) = *oentry;
732 xhv->xhv_keys++; /* HvKEYS(hv)++ */
733 if (!n_links) { /* initial entry? */
734 xhv->xhv_fill++; /* HvFILL(hv)++ */
735 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
736 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
737 /* Use the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
738 splits on a rehashed hash, as we're not going to split it again,
739 and if someone is lucky (evil) enough to get all the keys in one
740 list they could exhaust our memory as we repeatedly double the
741 number of buckets on every entry. Linear search feels a less worse
746 return &HeVAL(entry);
750 =for apidoc hv_store_ent
752 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
753 parameter is the precomputed hash value; if it is zero then Perl will
754 compute it. The return value is the new hash entry so created. It will be
755 NULL if the operation failed or if the value did not need to be actually
756 stored within the hash (as in the case of tied hashes). Otherwise the
757 contents of the return value can be accessed using the C<He?> macros
758 described here. Note that the caller is responsible for suitably
759 incrementing the reference count of C<val> before the call, and
760 decrementing it if the function returned NULL. Effectively a successful
761 hv_store_ent takes ownership of one reference to C<val>. This is
762 usually what you want; a newly created SV has a reference count of one, so
763 if all your code does is create SVs then store them in a hash, hv_store
764 will own the only reference to the new SV, and your code doesn't need to do
765 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
766 unlike C<val> it does not take ownership of it, so maintaining the correct
767 reference count on C<key> is entirely the caller's responsibility. hv_store
768 is not implemented as a call to hv_store_ent, and does not create a temporary
769 SV for the key, so if your key data is not already in SV form then use
770 hv_store in preference to hv_store_ent.
772 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
773 information on how to use this function on tied hashes.
779 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
794 xhv = (XPVHV*)SvANY(hv);
798 hv_magic_check (hv, &needs_copy, &needs_store);
800 bool save_taint = PL_tainted;
802 PL_tainted = SvTAINTED(keysv);
803 keysv = sv_2mortal(newSVsv(keysv));
804 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
805 TAINT_IF(save_taint);
806 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
808 #ifdef ENV_IS_CASELESS
809 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
810 key = SvPV(keysv, klen);
811 keysv = sv_2mortal(newSVpvn(key,klen));
812 (void)strupr(SvPVX(keysv));
819 keysave = key = SvPV(keysv, klen);
820 is_utf8 = (SvUTF8(keysv) != 0);
823 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
827 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
828 HvHASKFLAGS_on((SV*)hv);
832 /* We don't have a pointer to the hv, so we have to replicate the
833 flag into every HEK, so that hv_iterkeysv can see it. */
834 flags |= HVhek_REHASH;
835 PERL_HASH_INTERNAL(hash, key, klen);
837 if SvIsCOW_shared_hash(keysv) {
840 PERL_HASH(hash, key, klen);
844 if (!xhv->xhv_array /* !HvARRAY(hv) */)
845 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
846 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
849 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
850 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
853 for (; entry; ++n_links, entry = HeNEXT(entry)) {
854 if (HeHASH(entry) != hash) /* strings can't be equal */
856 if (HeKLEN(entry) != (I32)klen)
858 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
860 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
862 if (HeVAL(entry) == &PL_sv_placeholder)
863 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
865 SvREFCNT_dec(HeVAL(entry));
867 if (HeKFLAGS(entry) != flags) {
868 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
869 But if entry was set previously with HVhek_WASUTF8 and key now
870 doesn't (or vice versa) then we should change the key's flag,
871 as this is assignment. */
872 if (HvSHAREKEYS(hv)) {
873 /* Need to swap the key we have for a key with the flags we
874 need. As keys are shared we can't just write to the flag,
875 so we share the new one, unshare the old one. */
876 int flags_nofree = flags & ~HVhek_FREEKEY;
877 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
878 unshare_hek (HeKEY_hek(entry));
879 HeKEY_hek(entry) = new_hek;
882 HeKFLAGS(entry) = flags;
884 if (flags & HVhek_FREEKEY)
889 if (SvREADONLY(hv)) {
890 S_hv_notallowed(aTHX_ flags, key, klen,
891 "access disallowed key '%"SVf"' to"
896 /* share_hek_flags will do the free for us. This might be considered
899 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
900 else /* gotta do the real thing */
901 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
903 HeNEXT(entry) = *oentry;
906 xhv->xhv_keys++; /* HvKEYS(hv)++ */
907 if (!n_links) { /* initial entry? */
908 xhv->xhv_fill++; /* HvFILL(hv)++ */
909 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
910 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
911 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
912 splits on a rehashed hash, as we're not going to split it again,
913 and if someone is lucky (evil) enough to get all the keys in one
914 list they could exhaust our memory as we repeatedly double the
915 number of buckets on every entry. Linear search feels a less worse
924 =for apidoc hv_delete
926 Deletes a key/value pair in the hash. The value SV is removed from the
927 hash and returned to the caller. The C<klen> is the length of the key.
928 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
935 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
941 register HE **oentry;
944 bool is_utf8 = FALSE;
946 const char *keysave = key;
954 if (SvRMAGICAL(hv)) {
957 hv_magic_check (hv, &needs_copy, &needs_store);
959 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
965 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
966 /* No longer an element */
967 sv_unmagic(sv, PERL_MAGIC_tiedelem);
970 return Nullsv; /* element cannot be deleted */
972 #ifdef ENV_IS_CASELESS
973 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
974 sv = sv_2mortal(newSVpvn(key,klen));
975 key = strupr(SvPVX(sv));
980 xhv = (XPVHV*)SvANY(hv);
981 if (!xhv->xhv_array /* !HvARRAY(hv) */)
985 STRLEN tmplen = klen;
986 /* See the note in hv_fetch(). --jhi */
987 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
990 k_flags = HVhek_UTF8;
992 k_flags |= HVhek_FREEKEY;
996 PERL_HASH_INTERNAL(hash, key, klen);
998 PERL_HASH(hash, key, klen);
1001 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1002 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1005 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1006 if (HeHASH(entry) != hash) /* strings can't be equal */
1008 if (HeKLEN(entry) != (I32)klen)
1010 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1012 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1014 if (k_flags & HVhek_FREEKEY)
1016 /* if placeholder is here, it's already been deleted.... */
1017 if (HeVAL(entry) == &PL_sv_placeholder)
1020 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1022 /* okay, really delete the placeholder... */
1023 *oentry = HeNEXT(entry);
1025 xhv->xhv_fill--; /* HvFILL(hv)-- */
1026 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1029 hv_free_ent(hv, entry);
1030 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1031 if (xhv->xhv_keys == 0)
1032 HvHASKFLAGS_off(hv);
1033 xhv->xhv_placeholders--;
1037 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1038 S_hv_notallowed(aTHX_ k_flags, key, klen,
1039 "delete readonly key '%"SVf"' from"
1043 if (flags & G_DISCARD)
1046 sv = sv_2mortal(HeVAL(entry));
1047 HeVAL(entry) = &PL_sv_placeholder;
1051 * If a restricted hash, rather than really deleting the entry, put
1052 * a placeholder there. This marks the key as being "approved", so
1053 * we can still access via not-really-existing key without raising
1056 if (SvREADONLY(hv)) {
1057 HeVAL(entry) = &PL_sv_placeholder;
1058 /* We'll be saving this slot, so the number of allocated keys
1059 * doesn't go down, but the number placeholders goes up */
1060 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1062 *oentry = HeNEXT(entry);
1064 xhv->xhv_fill--; /* HvFILL(hv)-- */
1065 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1068 hv_free_ent(hv, entry);
1069 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1070 if (xhv->xhv_keys == 0)
1071 HvHASKFLAGS_off(hv);
1075 if (SvREADONLY(hv)) {
1076 S_hv_notallowed(aTHX_ k_flags, key, klen,
1077 "access disallowed key '%"SVf"' from"
1081 if (k_flags & HVhek_FREEKEY)
1087 =for apidoc hv_delete_ent
1089 Deletes a key/value pair in the hash. The value SV is removed from the
1090 hash and returned to the caller. The C<flags> value will normally be zero;
1091 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
1092 precomputed hash value, or 0 to ask for it to be computed.
1098 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1100 register XPVHV* xhv;
1105 register HE **oentry;
1113 if (SvRMAGICAL(hv)) {
1116 hv_magic_check (hv, &needs_copy, &needs_store);
1118 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
1120 if (SvMAGICAL(sv)) {
1124 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1125 /* No longer an element */
1126 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1129 return Nullsv; /* element cannot be deleted */
1131 #ifdef ENV_IS_CASELESS
1132 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1133 key = SvPV(keysv, klen);
1134 keysv = sv_2mortal(newSVpvn(key,klen));
1135 (void)strupr(SvPVX(keysv));
1141 xhv = (XPVHV*)SvANY(hv);
1142 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1145 keysave = key = SvPV(keysv, klen);
1146 is_utf8 = (SvUTF8(keysv) != 0);
1149 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1151 k_flags = HVhek_UTF8;
1153 k_flags |= HVhek_FREEKEY;
1157 PERL_HASH_INTERNAL(hash, key, klen);
1159 PERL_HASH(hash, key, klen);
1162 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1163 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1166 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1167 if (HeHASH(entry) != hash) /* strings can't be equal */
1169 if (HeKLEN(entry) != (I32)klen)
1171 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1173 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1175 if (k_flags & HVhek_FREEKEY)
1178 /* if placeholder is here, it's already been deleted.... */
1179 if (HeVAL(entry) == &PL_sv_placeholder)
1182 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1184 /* okay, really delete the placeholder. */
1185 *oentry = HeNEXT(entry);
1187 xhv->xhv_fill--; /* HvFILL(hv)-- */
1188 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1191 hv_free_ent(hv, entry);
1192 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1193 if (xhv->xhv_keys == 0)
1194 HvHASKFLAGS_off(hv);
1195 xhv->xhv_placeholders--;
1198 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1199 S_hv_notallowed(aTHX_ k_flags, key, klen,
1200 "delete readonly key '%"SVf"' from"
1204 if (flags & G_DISCARD)
1207 sv = sv_2mortal(HeVAL(entry));
1208 HeVAL(entry) = &PL_sv_placeholder;
1212 * If a restricted hash, rather than really deleting the entry, put
1213 * a placeholder there. This marks the key as being "approved", so
1214 * we can still access via not-really-existing key without raising
1217 if (SvREADONLY(hv)) {
1218 HeVAL(entry) = &PL_sv_placeholder;
1219 /* We'll be saving this slot, so the number of allocated keys
1220 * doesn't go down, but the number placeholders goes up */
1221 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1223 *oentry = HeNEXT(entry);
1225 xhv->xhv_fill--; /* HvFILL(hv)-- */
1226 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1229 hv_free_ent(hv, entry);
1230 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1231 if (xhv->xhv_keys == 0)
1232 HvHASKFLAGS_off(hv);
1236 if (SvREADONLY(hv)) {
1237 S_hv_notallowed(aTHX_ k_flags, key, klen,
1238 "delete disallowed key '%"SVf"' from"
1242 if (k_flags & HVhek_FREEKEY)
1248 =for apidoc hv_exists
1250 Returns a boolean indicating whether the specified hash key exists. The
1251 C<klen> is the length of the key.
1257 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
1259 register XPVHV* xhv;
1263 bool is_utf8 = FALSE;
1264 const char *keysave = key;
1275 if (SvRMAGICAL(hv)) {
1276 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1277 sv = sv_newmortal();
1278 mg_copy((SV*)hv, sv, key, klen);
1279 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
1280 return (bool)SvTRUE(sv);
1282 #ifdef ENV_IS_CASELESS
1283 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1284 sv = sv_2mortal(newSVpvn(key,klen));
1285 key = strupr(SvPVX(sv));
1290 xhv = (XPVHV*)SvANY(hv);
1291 #ifndef DYNAMIC_ENV_FETCH
1292 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1297 STRLEN tmplen = klen;
1298 /* See the note in hv_fetch(). --jhi */
1299 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1302 k_flags = HVhek_UTF8;
1304 k_flags |= HVhek_FREEKEY;
1308 PERL_HASH_INTERNAL(hash, key, klen);
1310 PERL_HASH(hash, key, klen);
1313 #ifdef DYNAMIC_ENV_FETCH
1314 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1317 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1318 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1319 for (; entry; entry = HeNEXT(entry)) {
1320 if (HeHASH(entry) != hash) /* strings can't be equal */
1322 if (HeKLEN(entry) != klen)
1324 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1326 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1328 if (k_flags & HVhek_FREEKEY)
1330 /* If we find the key, but the value is a placeholder, return false. */
1331 if (HeVAL(entry) == &PL_sv_placeholder)
1336 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1337 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1339 char *env = PerlEnv_ENVgetenv_len(key,&len);
1341 sv = newSVpvn(env,len);
1343 (void)hv_store(hv,key,klen,sv,hash);
1344 if (k_flags & HVhek_FREEKEY)
1350 if (k_flags & HVhek_FREEKEY)
1357 =for apidoc hv_exists_ent
1359 Returns a boolean indicating whether the specified hash key exists. C<hash>
1360 can be a valid precomputed hash value, or 0 to ask for it to be
1367 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1369 register XPVHV* xhv;
1381 if (SvRMAGICAL(hv)) {
1382 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1383 SV* svret = sv_newmortal();
1384 sv = sv_newmortal();
1385 keysv = sv_2mortal(newSVsv(keysv));
1386 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1387 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1388 return (bool)SvTRUE(svret);
1390 #ifdef ENV_IS_CASELESS
1391 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1392 key = SvPV(keysv, klen);
1393 keysv = sv_2mortal(newSVpvn(key,klen));
1394 (void)strupr(SvPVX(keysv));
1400 xhv = (XPVHV*)SvANY(hv);
1401 #ifndef DYNAMIC_ENV_FETCH
1402 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1406 keysave = key = SvPV(keysv, klen);
1407 is_utf8 = (SvUTF8(keysv) != 0);
1409 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1411 k_flags = HVhek_UTF8;
1413 k_flags |= HVhek_FREEKEY;
1416 PERL_HASH_INTERNAL(hash, key, klen);
1418 PERL_HASH(hash, key, klen);
1420 #ifdef DYNAMIC_ENV_FETCH
1421 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1424 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1425 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1426 for (; entry; entry = HeNEXT(entry)) {
1427 if (HeHASH(entry) != hash) /* strings can't be equal */
1429 if (HeKLEN(entry) != (I32)klen)
1431 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1433 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1435 if (k_flags & HVhek_FREEKEY)
1437 /* If we find the key, but the value is a placeholder, return false. */
1438 if (HeVAL(entry) == &PL_sv_placeholder)
1442 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1443 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1445 char *env = PerlEnv_ENVgetenv_len(key,&len);
1447 sv = newSVpvn(env,len);
1449 (void)hv_store_ent(hv,keysv,sv,hash);
1450 if (k_flags & HVhek_FREEKEY)
1456 if (k_flags & HVhek_FREEKEY)
1462 S_hsplit(pTHX_ HV *hv)
1464 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1465 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1466 register I32 newsize = oldsize * 2;
1468 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1472 register HE **oentry;
1473 int longest_chain = 0;
1477 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1478 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1484 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1489 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1490 if (oldsize >= 64) {
1491 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1492 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1495 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1499 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1500 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1501 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1504 for (i=0; i<oldsize; i++,aep++) {
1505 int left_length = 0;
1506 int right_length = 0;
1508 if (!*aep) /* non-existent */
1511 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1512 if ((HeHASH(entry) & newsize) != (U32)i) {
1513 *oentry = HeNEXT(entry);
1514 HeNEXT(entry) = *bep;
1516 xhv->xhv_fill++; /* HvFILL(hv)++ */
1522 oentry = &HeNEXT(entry);
1526 if (!*aep) /* everything moved */
1527 xhv->xhv_fill--; /* HvFILL(hv)-- */
1528 /* I think we don't actually need to keep track of the longest length,
1529 merely flag if anything is too long. But for the moment while
1530 developing this code I'll track it. */
1531 if (left_length > longest_chain)
1532 longest_chain = left_length;
1533 if (right_length > longest_chain)
1534 longest_chain = right_length;
1538 /* Pick your policy for "hashing isn't working" here: */
1539 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
1544 if (hv == PL_strtab) {
1545 /* Urg. Someone is doing something nasty to the string table.
1550 /* Awooga. Awooga. Pathological data. */
1551 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1552 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1555 Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1556 was_shared = HvSHAREKEYS(hv);
1559 HvSHAREKEYS_off(hv);
1562 aep = (HE **) xhv->xhv_array;
1564 for (i=0; i<newsize; i++,aep++) {
1567 /* We're going to trash this HE's next pointer when we chain it
1568 into the new hash below, so store where we go next. */
1569 HE *next = HeNEXT(entry);
1573 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1578 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1579 hash, HeKFLAGS(entry));
1580 unshare_hek (HeKEY_hek(entry));
1581 HeKEY_hek(entry) = new_hek;
1583 /* Not shared, so simply write the new hash in. */
1584 HeHASH(entry) = hash;
1586 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1587 HEK_REHASH_on(HeKEY_hek(entry));
1588 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1590 /* Copy oentry to the correct new chain. */
1591 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1593 xhv->xhv_fill++; /* HvFILL(hv)++ */
1594 HeNEXT(entry) = *bep;
1600 Safefree (xhv->xhv_array);
1601 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1605 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1607 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1608 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1609 register I32 newsize;
1615 register HE **oentry;
1617 newsize = (I32) newmax; /* possible truncation here */
1618 if (newsize != newmax || newmax <= oldsize)
1620 while ((newsize & (1 + ~newsize)) != newsize) {
1621 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1623 if (newsize < newmax)
1625 if (newsize < newmax)
1626 return; /* overflow detection */
1628 a = xhv->xhv_array; /* HvARRAY(hv) */
1631 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1632 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1638 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1643 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1644 if (oldsize >= 64) {
1645 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1646 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1649 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1652 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1655 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1657 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1658 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1659 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1663 for (i=0; i<oldsize; i++,aep++) {
1664 if (!*aep) /* non-existent */
1666 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1667 if ((j = (HeHASH(entry) & newsize)) != i) {
1669 *oentry = HeNEXT(entry);
1670 if (!(HeNEXT(entry) = aep[j]))
1671 xhv->xhv_fill++; /* HvFILL(hv)++ */
1676 oentry = &HeNEXT(entry);
1678 if (!*aep) /* everything moved */
1679 xhv->xhv_fill--; /* HvFILL(hv)-- */
1686 Creates a new HV. The reference count is set to 1.
1695 register XPVHV* xhv;
1697 hv = (HV*)NEWSV(502,0);
1698 sv_upgrade((SV *)hv, SVt_PVHV);
1699 xhv = (XPVHV*)SvANY(hv);
1702 #ifndef NODEFAULT_SHAREKEYS
1703 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1706 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1707 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1708 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1709 (void)hv_iterinit(hv); /* so each() will start off right */
1714 Perl_newHVhv(pTHX_ HV *ohv)
1717 STRLEN hv_max, hv_fill;
1719 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1721 hv_max = HvMAX(ohv);
1723 if (!SvMAGICAL((SV *)ohv)) {
1724 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1726 bool shared = !!HvSHAREKEYS(ohv);
1727 HE **ents, **oents = (HE **)HvARRAY(ohv);
1729 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1732 /* In each bucket... */
1733 for (i = 0; i <= hv_max; i++) {
1734 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1741 /* Copy the linked list of entries. */
1742 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1743 U32 hash = HeHASH(oent);
1744 char *key = HeKEY(oent);
1745 STRLEN len = HeKLEN(oent);
1746 int flags = HeKFLAGS(oent);
1749 HeVAL(ent) = newSVsv(HeVAL(oent));
1751 = shared ? share_hek_flags(key, len, hash, flags)
1752 : save_hek_flags(key, len, hash, flags);
1763 HvFILL(hv) = hv_fill;
1764 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1768 /* Iterate over ohv, copying keys and values one at a time. */
1770 I32 riter = HvRITER(ohv);
1771 HE *eiter = HvEITER(ohv);
1773 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1774 while (hv_max && hv_max + 1 >= hv_fill * 2)
1775 hv_max = hv_max / 2;
1779 while ((entry = hv_iternext_flags(ohv, 0))) {
1780 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1781 newSVsv(HeVAL(entry)), HeHASH(entry),
1784 HvRITER(ohv) = riter;
1785 HvEITER(ohv) = eiter;
1792 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1799 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1800 PL_sub_generation++; /* may be deletion of method from stash */
1802 if (HeKLEN(entry) == HEf_SVKEY) {
1803 SvREFCNT_dec(HeKEY_sv(entry));
1804 Safefree(HeKEY_hek(entry));
1806 else if (HvSHAREKEYS(hv))
1807 unshare_hek(HeKEY_hek(entry));
1809 Safefree(HeKEY_hek(entry));
1814 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1818 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1819 PL_sub_generation++; /* may be deletion of method from stash */
1820 sv_2mortal(HeVAL(entry)); /* free between statements */
1821 if (HeKLEN(entry) == HEf_SVKEY) {
1822 sv_2mortal(HeKEY_sv(entry));
1823 Safefree(HeKEY_hek(entry));
1825 else if (HvSHAREKEYS(hv))
1826 unshare_hek(HeKEY_hek(entry));
1828 Safefree(HeKEY_hek(entry));
1833 =for apidoc hv_clear
1835 Clears a hash, making it empty.
1841 Perl_hv_clear(pTHX_ HV *hv)
1843 register XPVHV* xhv;
1847 xhv = (XPVHV*)SvANY(hv);
1849 if (SvREADONLY(hv)) {
1850 /* restricted hash: convert all keys to placeholders */
1853 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1854 entry = ((HE**)xhv->xhv_array)[i];
1855 for (; entry; entry = HeNEXT(entry)) {
1856 /* not already placeholder */
1857 if (HeVAL(entry) != &PL_sv_placeholder) {
1858 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1859 SV* keysv = hv_iterkeysv(entry);
1861 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1864 SvREFCNT_dec(HeVAL(entry));
1865 HeVAL(entry) = &PL_sv_placeholder;
1866 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1874 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1875 if (xhv->xhv_array /* HvARRAY(hv) */)
1876 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1877 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1882 HvHASKFLAGS_off(hv);
1887 S_hfreeentries(pTHX_ HV *hv)
1889 register HE **array;
1891 register HE *oentry = Null(HE*);
1902 array = HvARRAY(hv);
1903 /* make everyone else think the array is empty, so that the destructors
1904 * called for freed entries can't recusively mess with us */
1905 HvARRAY(hv) = Null(HE**);
1907 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1913 entry = HeNEXT(entry);
1914 hv_free_ent(hv, oentry);
1919 entry = array[riter];
1922 HvARRAY(hv) = array;
1923 (void)hv_iterinit(hv);
1927 =for apidoc hv_undef
1935 Perl_hv_undef(pTHX_ HV *hv)
1937 register XPVHV* xhv;
1940 xhv = (XPVHV*)SvANY(hv);
1942 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1945 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1946 Safefree(HvNAME(hv));
1949 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1950 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1951 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1958 =for apidoc hv_iterinit
1960 Prepares a starting point to traverse a hash table. Returns the number of
1961 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1962 currently only meaningful for hashes without tie magic.
1964 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1965 hash buckets that happen to be in use. If you still need that esoteric
1966 value, you can get it through the macro C<HvFILL(tb)>.
1973 Perl_hv_iterinit(pTHX_ HV *hv)
1975 register XPVHV* xhv;
1979 Perl_croak(aTHX_ "Bad hash");
1980 xhv = (XPVHV*)SvANY(hv);
1981 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1982 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1984 hv_free_ent(hv, entry);
1986 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1987 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1988 /* used to be xhv->xhv_fill before 5.004_65 */
1989 return XHvTOTALKEYS(xhv);
1992 =for apidoc hv_iternext
1994 Returns entries from a hash iterator. See C<hv_iterinit>.
1996 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1997 iterator currently points to, without losing your place or invalidating your
1998 iterator. Note that in this case the current entry is deleted from the hash
1999 with your iterator holding the last reference to it. Your iterator is flagged
2000 to free the entry on the next call to C<hv_iternext>, so you must not discard
2001 your iterator immediately else the entry will leak - call C<hv_iternext> to
2002 trigger the resource deallocation.
2008 Perl_hv_iternext(pTHX_ HV *hv)
2010 return hv_iternext_flags(hv, 0);
2014 =for apidoc hv_iternext_flags
2016 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
2017 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2018 set the placeholders keys (for restricted hashes) will be returned in addition
2019 to normal keys. By default placeholders are automatically skipped over.
2020 Currently a placeholder is implemented with a value that is
2021 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2022 restricted hashes may change, and the implementation currently is
2023 insufficiently abstracted for any change to be tidy.
2029 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2031 register XPVHV* xhv;
2037 Perl_croak(aTHX_ "Bad hash");
2038 xhv = (XPVHV*)SvANY(hv);
2039 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
2041 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
2042 SV *key = sv_newmortal();
2044 sv_setsv(key, HeSVKEY_force(entry));
2045 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2051 /* one HE per MAGICAL hash */
2052 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2054 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
2056 HeKEY_hek(entry) = hek;
2057 HeKLEN(entry) = HEf_SVKEY;
2059 magic_nextpack((SV*) hv,mg,key);
2061 /* force key to stay around until next time */
2062 HeSVKEY_set(entry, SvREFCNT_inc(key));
2063 return entry; /* beware, hent_val is not set */
2066 SvREFCNT_dec(HeVAL(entry));
2067 Safefree(HeKEY_hek(entry));
2069 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
2072 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
2073 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
2077 if (!xhv->xhv_array /* !HvARRAY(hv) */)
2078 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
2079 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
2081 /* At start of hash, entry is NULL. */
2084 entry = HeNEXT(entry);
2085 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2087 * Skip past any placeholders -- don't want to include them in
2090 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2091 entry = HeNEXT(entry);
2096 /* OK. Come to the end of the current list. Grab the next one. */
2098 xhv->xhv_riter++; /* HvRITER(hv)++ */
2099 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2100 /* There is no next one. End of the hash. */
2101 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
2104 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
2105 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
2107 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2108 /* If we have an entry, but it's a placeholder, don't count it.
2110 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2111 entry = HeNEXT(entry);
2113 /* Will loop again if this linked list starts NULL
2114 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2115 or if we run through it and find only placeholders. */
2118 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2120 hv_free_ent(hv, oldentry);
2123 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2124 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
2126 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
2131 =for apidoc hv_iterkey
2133 Returns the key from the current position of the hash iterator. See
2140 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2142 if (HeKLEN(entry) == HEf_SVKEY) {
2144 char *p = SvPV(HeKEY_sv(entry), len);
2149 *retlen = HeKLEN(entry);
2150 return HeKEY(entry);
2154 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2156 =for apidoc hv_iterkeysv
2158 Returns the key as an C<SV*> from the current position of the hash
2159 iterator. The return value will always be a mortal copy of the key. Also
2166 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2168 if (HeKLEN(entry) != HEf_SVKEY) {
2169 HEK *hek = HeKEY_hek(entry);
2170 int flags = HEK_FLAGS(hek);
2173 if (flags & HVhek_WASUTF8) {
2175 Andreas would like keys he put in as utf8 to come back as utf8
2177 STRLEN utf8_len = HEK_LEN(hek);
2178 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2180 sv = newSVpvn ((char*)as_utf8, utf8_len);
2182 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2183 } else if (flags & HVhek_REHASH) {
2184 /* We don't have a pointer to the hv, so we have to replicate the
2185 flag into every HEK. This hv is using custom a hasing
2186 algorithm. Hence we can't return a shared string scalar, as
2187 that would contain the (wrong) hash value, and might get passed
2188 into an hv routine with a regular hash */
2190 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
2194 sv = newSVpvn_share(HEK_KEY(hek),
2195 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2198 return sv_2mortal(sv);
2200 return sv_mortalcopy(HeKEY_sv(entry));
2204 =for apidoc hv_iterval
2206 Returns the value from the current position of the hash iterator. See
2213 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2215 if (SvRMAGICAL(hv)) {
2216 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2217 SV* sv = sv_newmortal();
2218 if (HeKLEN(entry) == HEf_SVKEY)
2219 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2220 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2224 return HeVAL(entry);
2228 =for apidoc hv_iternextsv
2230 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2237 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2240 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2242 *key = hv_iterkey(he, retlen);
2243 return hv_iterval(hv, he);
2247 =for apidoc hv_magic
2249 Adds magic to a hash. See C<sv_magic>.
2255 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2257 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2260 #if 0 /* use the macro from hv.h instead */
2263 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2265 return HEK_KEY(share_hek(sv, len, hash));
2270 /* possibly free a shared string if no one has access to it
2271 * len and hash must both be valid for str.
2274 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2276 unshare_hek_or_pvn (NULL, str, len, hash);
2281 Perl_unshare_hek(pTHX_ HEK *hek)
2283 unshare_hek_or_pvn(hek, NULL, 0, 0);
2286 /* possibly free a shared string if no one has access to it
2287 hek if non-NULL takes priority over the other 3, else str, len and hash
2288 are used. If so, len and hash must both be valid for str.
2291 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2293 register XPVHV* xhv;
2295 register HE **oentry;
2298 bool is_utf8 = FALSE;
2300 const char *save = str;
2303 hash = HEK_HASH(hek);
2304 } else if (len < 0) {
2305 STRLEN tmplen = -len;
2307 /* See the note in hv_fetch(). --jhi */
2308 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2311 k_flags = HVhek_UTF8;
2313 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2316 /* what follows is the moral equivalent of:
2317 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2318 if (--*Svp == Nullsv)
2319 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2321 xhv = (XPVHV*)SvANY(PL_strtab);
2322 /* assert(xhv_array != 0) */
2324 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2325 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2327 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2328 if (HeKEY_hek(entry) != hek)
2334 int flags_masked = k_flags & HVhek_MASK;
2335 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2336 if (HeHASH(entry) != hash) /* strings can't be equal */
2338 if (HeKLEN(entry) != len)
2340 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2342 if (HeKFLAGS(entry) != flags_masked)
2350 if (--HeVAL(entry) == Nullsv) {
2351 *oentry = HeNEXT(entry);
2353 xhv->xhv_fill--; /* HvFILL(hv)-- */
2354 Safefree(HeKEY_hek(entry));
2356 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2360 UNLOCK_STRTAB_MUTEX;
2361 if (!found && ckWARN_d(WARN_INTERNAL))
2362 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2363 "Attempt to free non-existent shared string '%s'%s",
2364 hek ? HEK_KEY(hek) : str,
2365 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2366 if (k_flags & HVhek_FREEKEY)
2370 /* get a (constant) string ptr from the global string table
2371 * string will get added if it is not already there.
2372 * len and hash must both be valid for str.
2375 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2377 bool is_utf8 = FALSE;
2379 const char *save = str;
2382 STRLEN tmplen = -len;
2384 /* See the note in hv_fetch(). --jhi */
2385 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2387 /* If we were able to downgrade here, then than means that we were passed
2388 in a key which only had chars 0-255, but was utf8 encoded. */
2391 /* If we found we were able to downgrade the string to bytes, then
2392 we should flag that it needs upgrading on keys or each. Also flag
2393 that we need share_hek_flags to free the string. */
2395 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2398 return share_hek_flags (str, len, hash, flags);
2402 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2404 register XPVHV* xhv;
2406 register HE **oentry;
2409 int flags_masked = flags & HVhek_MASK;
2411 /* what follows is the moral equivalent of:
2413 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2414 hv_store(PL_strtab, str, len, Nullsv, hash);
2416 Can't rehash the shared string table, so not sure if it's worth
2417 counting the number of entries in the linked list
2419 xhv = (XPVHV*)SvANY(PL_strtab);
2420 /* assert(xhv_array != 0) */
2422 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2423 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2424 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2425 if (HeHASH(entry) != hash) /* strings can't be equal */
2427 if (HeKLEN(entry) != len)
2429 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2431 if (HeKFLAGS(entry) != flags_masked)
2438 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2439 HeVAL(entry) = Nullsv;
2440 HeNEXT(entry) = *oentry;
2442 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2443 if (i) { /* initial entry? */
2444 xhv->xhv_fill++; /* HvFILL(hv)++ */
2445 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2450 ++HeVAL(entry); /* use value slot as REFCNT */
2451 UNLOCK_STRTAB_MUTEX;
2453 if (flags & HVhek_FREEKEY)
2456 return HeKEY_hek(entry);