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
31 PL_he_root = HeNEXT(he);
40 HeNEXT(p) = (HE*)PL_he_root;
51 New(54, ptr, 1008/sizeof(XPV), XPV);
52 ptr->xpv_pv = (char*)PL_he_arenaroot;
53 PL_he_arenaroot = ptr;
56 heend = &he[1008 / sizeof(HE) - 1];
59 HeNEXT(he) = (HE*)(he + 1);
67 #define new_HE() (HE*)safemalloc(sizeof(HE))
68 #define del_HE(p) safefree((char*)p)
72 #define new_HE() new_he()
73 #define del_HE(p) del_he(p)
78 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
83 New(54, k, HEK_BASESIZE + len + 2, char);
85 Copy(str, HEK_KEY(hek), len, char);
86 HEK_KEY(hek)[len] = 0;
89 HEK_FLAGS(hek) = (unsigned char)flags;
93 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
97 Perl_free_tied_hv_pool(pTHX)
100 HE *he = PL_hv_fetch_ent_mh;
102 Safefree(HeKEY_hek(he));
109 #if defined(USE_ITHREADS)
111 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
117 /* look for it in the table first */
118 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
122 /* create anew and remember what it is */
124 ptr_table_store(PL_ptr_table, e, ret);
126 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
127 if (HeKLEN(e) == HEf_SVKEY) {
129 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
130 HeKEY_hek(ret) = (HEK*)k;
131 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
134 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
137 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
139 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
142 #endif /* USE_ITHREADS */
145 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
148 SV *sv = sv_newmortal(), *esv = sv_newmortal();
149 if (!(flags & HVhek_FREEKEY)) {
150 sv_setpvn(sv, key, klen);
153 /* Need to free saved eventually assign to mortal SV */
154 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
155 sv_usepvn(sv, (char *) key, klen);
157 if (flags & HVhek_UTF8) {
160 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
161 Perl_croak(aTHX_ SvPVX(esv), sv);
164 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
170 Returns the SV which corresponds to the specified key in the hash. The
171 C<klen> is the length of the key. If C<lval> is set then the fetch will be
172 part of a store. Check that the return value is non-null before
173 dereferencing it to an C<SV*>.
175 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
176 information on how to use this function on tied hashes.
183 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
185 bool is_utf8 = FALSE;
186 const char *keysave = key;
195 STRLEN tmplen = klen;
196 /* Just casting the &klen to (STRLEN) won't work well
197 * if STRLEN and I32 are of different widths. --jhi */
198 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
200 /* If we were able to downgrade here, then than means that we were
201 passed in a key which only had chars 0-255, but was utf8 encoded. */
204 /* If we found we were able to downgrade the string to bytes, then
205 we should flag that it needs upgrading on keys or each. */
207 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
210 return hv_fetch_flags (hv, key, klen, lval, flags);
214 S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
224 if (SvRMAGICAL(hv)) {
225 /* All this clause seems to be utf8 unaware.
226 By moving the utf8 stuff out to hv_fetch_flags I need to ensure
227 key doesn't leak. I've not tried solving the utf8-ness.
230 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
232 sv_upgrade(sv, SVt_PVLV);
233 mg_copy((SV*)hv, sv, key, klen);
234 if (flags & HVhek_FREEKEY)
237 LvTARG(sv) = sv; /* fake (SV**) */
238 return &(LvTARG(sv));
240 #ifdef ENV_IS_CASELESS
241 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
243 for (i = 0; i < klen; ++i)
244 if (isLOWER(key[i])) {
245 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
246 SV **ret = hv_fetch(hv, nkey, klen, 0);
248 ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0,
250 } else if (flags & HVhek_FREEKEY)
258 /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to
259 avoid unnecessary pointer dereferencing. */
260 xhv = (XPVHV*)SvANY(hv);
261 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
263 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
264 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
267 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
268 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
271 if (flags & HVhek_FREEKEY)
278 PERL_HASH_INTERNAL(hash, key, klen);
280 PERL_HASH(hash, key, klen);
283 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
284 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
285 for (; entry; entry = HeNEXT(entry)) {
286 if (!HeKEY_hek(entry))
288 if (HeHASH(entry) != hash) /* strings can't be equal */
290 if (HeKLEN(entry) != (I32)klen)
292 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
294 /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0.
295 flags is 1 if utf8. need HeKFLAGS(entry) also 1.
296 xor is true if bits differ, in which case this isn't a match. */
297 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
299 if (lval && HeKFLAGS(entry) != flags) {
300 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
301 But if entry was set previously with HVhek_WASUTF8 and key now
302 doesn't (or vice versa) then we should change the key's flag,
303 as this is assignment. */
304 if (HvSHAREKEYS(hv)) {
305 /* Need to swap the key we have for a key with the flags we
306 need. As keys are shared we can't just write to the flag,
307 so we share the new one, unshare the old one. */
308 int flags_nofree = flags & ~HVhek_FREEKEY;
309 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
310 unshare_hek (HeKEY_hek(entry));
311 HeKEY_hek(entry) = new_hek;
314 HeKFLAGS(entry) = flags;
318 if (flags & HVhek_FREEKEY)
320 /* if we find a placeholder, we pretend we haven't found anything */
321 if (HeVAL(entry) == &PL_sv_placeholder)
323 return &HeVAL(entry);
326 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
327 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
329 char *env = PerlEnv_ENVgetenv_len(key,&len);
331 sv = newSVpvn(env,len);
333 if (flags & HVhek_FREEKEY)
335 return hv_store(hv,key,klen,sv,hash);
339 if (!entry && SvREADONLY(hv)) {
340 S_hv_notallowed(aTHX_ flags, key, klen,
341 "access disallowed key '%"SVf"' in"
344 if (lval) { /* gonna assign to this, so it better be there */
346 return hv_store_flags(hv,key,klen,sv,hash,flags);
348 if (flags & HVhek_FREEKEY)
353 /* returns an HE * structure with the all fields set */
354 /* note that hent_val will be a mortal sv for MAGICAL hashes */
356 =for apidoc hv_fetch_ent
358 Returns the hash entry which corresponds to the specified key in the hash.
359 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
360 if you want the function to compute it. IF C<lval> is set then the fetch
361 will be part of a store. Make sure the return value is non-null before
362 accessing it. The return value when C<tb> is a tied hash is a pointer to a
363 static location, so be sure to make a copy of the structure if you need to
366 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
367 information on how to use this function on tied hashes.
373 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
387 if (SvRMAGICAL(hv)) {
388 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
390 keysv = newSVsv(keysv);
391 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
392 /* grab a fake HE/HEK pair from the pool or make a new one */
393 entry = PL_hv_fetch_ent_mh;
395 PL_hv_fetch_ent_mh = HeNEXT(entry);
399 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
400 HeKEY_hek(entry) = (HEK*)k;
402 HeNEXT(entry) = Nullhe;
403 HeSVKEY_set(entry, keysv);
405 sv_upgrade(sv, SVt_PVLV);
407 LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
410 #ifdef ENV_IS_CASELESS
411 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
413 key = SvPV(keysv, klen);
414 for (i = 0; i < klen; ++i)
415 if (isLOWER(key[i])) {
416 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
417 (void)strupr(SvPVX(nkeysv));
418 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
420 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
427 keysave = key = SvPV(keysv, klen);
428 xhv = (XPVHV*)SvANY(hv);
429 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
431 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
432 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
435 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
436 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
442 is_utf8 = (SvUTF8(keysv)!=0);
445 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
449 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
453 PERL_HASH_INTERNAL(hash, key, klen);
455 if SvIsCOW_shared_hash(keysv) {
458 PERL_HASH(hash, key, klen);
462 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
463 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
464 for (; entry; entry = HeNEXT(entry)) {
465 if (HeHASH(entry) != hash) /* strings can't be equal */
467 if (HeKLEN(entry) != (I32)klen)
469 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
471 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
473 if (lval && HeKFLAGS(entry) != flags) {
474 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
475 But if entry was set previously with HVhek_WASUTF8 and key now
476 doesn't (or vice versa) then we should change the key's flag,
477 as this is assignment. */
478 if (HvSHAREKEYS(hv)) {
479 /* Need to swap the key we have for a key with the flags we
480 need. As keys are shared we can't just write to the flag,
481 so we share the new one, unshare the old one. */
482 int flags_nofree = flags & ~HVhek_FREEKEY;
483 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
484 unshare_hek (HeKEY_hek(entry));
485 HeKEY_hek(entry) = new_hek;
488 HeKFLAGS(entry) = flags;
494 /* if we find a placeholder, we pretend we haven't found anything */
495 if (HeVAL(entry) == &PL_sv_placeholder)
499 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
500 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
502 char *env = PerlEnv_ENVgetenv_len(key,&len);
504 sv = newSVpvn(env,len);
506 return hv_store_ent(hv,keysv,sv,hash);
510 if (!entry && SvREADONLY(hv)) {
511 S_hv_notallowed(aTHX_ flags, key, klen,
512 "access disallowed key '%"SVf"' in"
515 if (flags & HVhek_FREEKEY)
517 if (lval) { /* gonna assign to this, so it better be there */
519 return hv_store_ent(hv,keysv,sv,hash);
525 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
527 MAGIC *mg = SvMAGIC(hv);
531 if (isUPPER(mg->mg_type)) {
533 switch (mg->mg_type) {
534 case PERL_MAGIC_tied:
536 *needs_store = FALSE;
539 mg = mg->mg_moremagic;
546 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
547 the length of the key. The C<hash> parameter is the precomputed hash
548 value; if it is zero then Perl will compute it. The return value will be
549 NULL if the operation failed or if the value did not need to be actually
550 stored within the hash (as in the case of tied hashes). Otherwise it can
551 be dereferenced to get the original C<SV*>. Note that the caller is
552 responsible for suitably incrementing the reference count of C<val> before
553 the call, and decrementing it if the function returned NULL. Effectively
554 a successful hv_store takes ownership of one reference to C<val>. This is
555 usually what you want; a newly created SV has a reference count of one, so
556 if all your code does is create SVs then store them in a hash, hv_store
557 will own the only reference to the new SV, and your code doesn't need to do
558 anything further to tidy up. hv_store is not implemented as a call to
559 hv_store_ent, and does not create a temporary SV for the key, so if your
560 key data is not already in SV form then use hv_store in preference to
563 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
564 information on how to use this function on tied hashes.
570 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
572 bool is_utf8 = FALSE;
573 const char *keysave = key;
582 STRLEN tmplen = klen;
583 /* Just casting the &klen to (STRLEN) won't work well
584 * if STRLEN and I32 are of different widths. --jhi */
585 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
587 /* If we were able to downgrade here, then than means that we were
588 passed in a key which only had chars 0-255, but was utf8 encoded. */
591 /* If we found we were able to downgrade the string to bytes, then
592 we should flag that it needs upgrading on keys or each. */
594 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
597 return hv_store_flags (hv, key, klen, val, hash, flags);
601 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
602 register U32 hash, int flags)
607 register HE **oentry;
612 xhv = (XPVHV*)SvANY(hv);
616 hv_magic_check (hv, &needs_copy, &needs_store);
618 mg_copy((SV*)hv, val, key, klen);
619 if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
620 if (flags & HVhek_FREEKEY)
624 #ifdef ENV_IS_CASELESS
625 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
626 key = savepvn(key,klen);
627 key = (const char*)strupr((char*)key);
635 HvHASKFLAGS_on((SV*)hv);
638 /* We don't have a pointer to the hv, so we have to replicate the
639 flag into every HEK, so that hv_iterkeysv can see it. */
640 flags |= HVhek_REHASH;
641 PERL_HASH_INTERNAL(hash, key, klen);
643 PERL_HASH(hash, key, klen);
645 if (!xhv->xhv_array /* !HvARRAY(hv) */)
646 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
647 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
650 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
651 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
654 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
655 if (HeHASH(entry) != hash) /* strings can't be equal */
657 if (HeKLEN(entry) != (I32)klen)
659 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
661 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
663 if (HeVAL(entry) == &PL_sv_placeholder)
664 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
666 SvREFCNT_dec(HeVAL(entry));
667 if (flags & HVhek_PLACEHOLD) {
668 /* We have been requested to insert a placeholder. Currently
669 only Storable is allowed to do this. */
670 xhv->xhv_placeholders++;
671 HeVAL(entry) = &PL_sv_placeholder;
675 if (HeKFLAGS(entry) != flags) {
676 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
677 But if entry was set previously with HVhek_WASUTF8 and key now
678 doesn't (or vice versa) then we should change the key's flag,
679 as this is assignment. */
680 if (HvSHAREKEYS(hv)) {
681 /* Need to swap the key we have for a key with the flags we
682 need. As keys are shared we can't just write to the flag,
683 so we share the new one, unshare the old one. */
684 int flags_nofree = flags & ~HVhek_FREEKEY;
685 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
686 unshare_hek (HeKEY_hek(entry));
687 HeKEY_hek(entry) = new_hek;
690 HeKFLAGS(entry) = flags;
692 if (flags & HVhek_FREEKEY)
694 return &HeVAL(entry);
697 if (SvREADONLY(hv)) {
698 S_hv_notallowed(aTHX_ flags, key, klen,
699 "access disallowed key '%"SVf"' to"
704 /* share_hek_flags will do the free for us. This might be considered
707 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
708 else /* gotta do the real thing */
709 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
710 if (flags & HVhek_PLACEHOLD) {
711 /* We have been requested to insert a placeholder. Currently
712 only Storable is allowed to do this. */
713 xhv->xhv_placeholders++;
714 HeVAL(entry) = &PL_sv_placeholder;
717 HeNEXT(entry) = *oentry;
720 xhv->xhv_keys++; /* HvKEYS(hv)++ */
721 if (i) { /* initial entry? */
722 xhv->xhv_fill++; /* HvFILL(hv)++ */
723 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
727 return &HeVAL(entry);
731 =for apidoc hv_store_ent
733 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
734 parameter is the precomputed hash value; if it is zero then Perl will
735 compute it. The return value is the new hash entry so created. It will be
736 NULL if the operation failed or if the value did not need to be actually
737 stored within the hash (as in the case of tied hashes). Otherwise the
738 contents of the return value can be accessed using the C<He?> macros
739 described here. Note that the caller is responsible for suitably
740 incrementing the reference count of C<val> before the call, and
741 decrementing it if the function returned NULL. Effectively a successful
742 hv_store_ent takes ownership of one reference to C<val>. This is
743 usually what you want; a newly created SV has a reference count of one, so
744 if all your code does is create SVs then store them in a hash, hv_store
745 will own the only reference to the new SV, and your code doesn't need to do
746 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
747 unlike C<val> it does not take ownership of it, so maintaining the correct
748 reference count on C<key> is entirely the caller's responsibility. hv_store
749 is not implemented as a call to hv_store_ent, and does not create a temporary
750 SV for the key, so if your key data is not already in SV form then use
751 hv_store in preference to hv_store_ent.
753 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
754 information on how to use this function on tied hashes.
760 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
775 xhv = (XPVHV*)SvANY(hv);
779 hv_magic_check (hv, &needs_copy, &needs_store);
781 bool save_taint = PL_tainted;
783 PL_tainted = SvTAINTED(keysv);
784 keysv = sv_2mortal(newSVsv(keysv));
785 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
786 TAINT_IF(save_taint);
787 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
789 #ifdef ENV_IS_CASELESS
790 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
791 key = SvPV(keysv, klen);
792 keysv = sv_2mortal(newSVpvn(key,klen));
793 (void)strupr(SvPVX(keysv));
800 keysave = key = SvPV(keysv, klen);
801 is_utf8 = (SvUTF8(keysv) != 0);
804 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
808 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
809 HvHASKFLAGS_on((SV*)hv);
813 /* We don't have a pointer to the hv, so we have to replicate the
814 flag into every HEK, so that hv_iterkeysv can see it. */
815 flags |= HVhek_REHASH;
816 PERL_HASH_INTERNAL(hash, key, klen);
818 if SvIsCOW_shared_hash(keysv) {
821 PERL_HASH(hash, key, klen);
825 if (!xhv->xhv_array /* !HvARRAY(hv) */)
826 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
827 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
830 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
831 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
834 for (; entry; i=0, entry = HeNEXT(entry)) {
835 if (HeHASH(entry) != hash) /* strings can't be equal */
837 if (HeKLEN(entry) != (I32)klen)
839 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
841 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
843 if (HeVAL(entry) == &PL_sv_placeholder)
844 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
846 SvREFCNT_dec(HeVAL(entry));
848 if (HeKFLAGS(entry) != flags) {
849 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
850 But if entry was set previously with HVhek_WASUTF8 and key now
851 doesn't (or vice versa) then we should change the key's flag,
852 as this is assignment. */
853 if (HvSHAREKEYS(hv)) {
854 /* Need to swap the key we have for a key with the flags we
855 need. As keys are shared we can't just write to the flag,
856 so we share the new one, unshare the old one. */
857 int flags_nofree = flags & ~HVhek_FREEKEY;
858 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
859 unshare_hek (HeKEY_hek(entry));
860 HeKEY_hek(entry) = new_hek;
863 HeKFLAGS(entry) = flags;
865 if (flags & HVhek_FREEKEY)
870 if (SvREADONLY(hv)) {
871 S_hv_notallowed(aTHX_ flags, key, klen,
872 "access disallowed key '%"SVf"' to"
877 /* share_hek_flags will do the free for us. This might be considered
880 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
881 else /* gotta do the real thing */
882 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
884 HeNEXT(entry) = *oentry;
887 xhv->xhv_keys++; /* HvKEYS(hv)++ */
888 if (i) { /* initial entry? */
889 xhv->xhv_fill++; /* HvFILL(hv)++ */
890 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
898 =for apidoc hv_delete
900 Deletes a key/value pair in the hash. The value SV is removed from the
901 hash and returned to the caller. The C<klen> is the length of the key.
902 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
909 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
915 register HE **oentry;
918 bool is_utf8 = FALSE;
920 const char *keysave = key;
928 if (SvRMAGICAL(hv)) {
931 hv_magic_check (hv, &needs_copy, &needs_store);
933 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
939 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
940 /* No longer an element */
941 sv_unmagic(sv, PERL_MAGIC_tiedelem);
944 return Nullsv; /* element cannot be deleted */
946 #ifdef ENV_IS_CASELESS
947 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
948 sv = sv_2mortal(newSVpvn(key,klen));
949 key = strupr(SvPVX(sv));
954 xhv = (XPVHV*)SvANY(hv);
955 if (!xhv->xhv_array /* !HvARRAY(hv) */)
959 STRLEN tmplen = klen;
960 /* See the note in hv_fetch(). --jhi */
961 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
964 k_flags = HVhek_UTF8;
966 k_flags |= HVhek_FREEKEY;
970 PERL_HASH_INTERNAL(hash, key, klen);
972 PERL_HASH(hash, key, klen);
975 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
976 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
979 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
980 if (HeHASH(entry) != hash) /* strings can't be equal */
982 if (HeKLEN(entry) != (I32)klen)
984 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
986 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
988 if (k_flags & HVhek_FREEKEY)
990 /* if placeholder is here, it's already been deleted.... */
991 if (HeVAL(entry) == &PL_sv_placeholder)
994 return Nullsv; /* if still SvREADONLY, leave it deleted. */
996 /* okay, really delete the placeholder... */
997 *oentry = HeNEXT(entry);
999 xhv->xhv_fill--; /* HvFILL(hv)-- */
1000 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1003 hv_free_ent(hv, entry);
1004 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1005 if (xhv->xhv_keys == 0)
1006 HvHASKFLAGS_off(hv);
1007 xhv->xhv_placeholders--;
1011 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1012 S_hv_notallowed(aTHX_ k_flags, key, klen,
1013 "delete readonly key '%"SVf"' from"
1017 if (flags & G_DISCARD)
1020 sv = sv_2mortal(HeVAL(entry));
1021 HeVAL(entry) = &PL_sv_placeholder;
1025 * If a restricted hash, rather than really deleting the entry, put
1026 * a placeholder there. This marks the key as being "approved", so
1027 * we can still access via not-really-existing key without raising
1030 if (SvREADONLY(hv)) {
1031 HeVAL(entry) = &PL_sv_placeholder;
1032 /* We'll be saving this slot, so the number of allocated keys
1033 * doesn't go down, but the number placeholders goes up */
1034 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1036 *oentry = HeNEXT(entry);
1038 xhv->xhv_fill--; /* HvFILL(hv)-- */
1039 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1042 hv_free_ent(hv, entry);
1043 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1044 if (xhv->xhv_keys == 0)
1045 HvHASKFLAGS_off(hv);
1049 if (SvREADONLY(hv)) {
1050 S_hv_notallowed(aTHX_ k_flags, key, klen,
1051 "access disallowed key '%"SVf"' from"
1055 if (k_flags & HVhek_FREEKEY)
1061 =for apidoc hv_delete_ent
1063 Deletes a key/value pair in the hash. The value SV is removed from the
1064 hash and returned to the caller. The C<flags> value will normally be zero;
1065 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
1066 precomputed hash value, or 0 to ask for it to be computed.
1072 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
1074 register XPVHV* xhv;
1079 register HE **oentry;
1087 if (SvRMAGICAL(hv)) {
1090 hv_magic_check (hv, &needs_copy, &needs_store);
1092 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
1094 if (SvMAGICAL(sv)) {
1098 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1099 /* No longer an element */
1100 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1103 return Nullsv; /* element cannot be deleted */
1105 #ifdef ENV_IS_CASELESS
1106 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1107 key = SvPV(keysv, klen);
1108 keysv = sv_2mortal(newSVpvn(key,klen));
1109 (void)strupr(SvPVX(keysv));
1115 xhv = (XPVHV*)SvANY(hv);
1116 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1119 keysave = key = SvPV(keysv, klen);
1120 is_utf8 = (SvUTF8(keysv) != 0);
1123 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1125 k_flags = HVhek_UTF8;
1127 k_flags |= HVhek_FREEKEY;
1131 PERL_HASH_INTERNAL(hash, key, klen);
1133 PERL_HASH(hash, key, klen);
1136 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1137 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1140 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1141 if (HeHASH(entry) != hash) /* strings can't be equal */
1143 if (HeKLEN(entry) != (I32)klen)
1145 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1147 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1149 if (k_flags & HVhek_FREEKEY)
1152 /* if placeholder is here, it's already been deleted.... */
1153 if (HeVAL(entry) == &PL_sv_placeholder)
1156 return Nullsv; /* if still SvREADONLY, leave it deleted. */
1158 /* okay, really delete the placeholder. */
1159 *oentry = HeNEXT(entry);
1161 xhv->xhv_fill--; /* HvFILL(hv)-- */
1162 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1165 hv_free_ent(hv, entry);
1166 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1167 if (xhv->xhv_keys == 0)
1168 HvHASKFLAGS_off(hv);
1169 xhv->xhv_placeholders--;
1172 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1173 S_hv_notallowed(aTHX_ k_flags, key, klen,
1174 "delete readonly key '%"SVf"' from"
1178 if (flags & G_DISCARD)
1181 sv = sv_2mortal(HeVAL(entry));
1182 HeVAL(entry) = &PL_sv_placeholder;
1186 * If a restricted hash, rather than really deleting the entry, put
1187 * a placeholder there. This marks the key as being "approved", so
1188 * we can still access via not-really-existing key without raising
1191 if (SvREADONLY(hv)) {
1192 HeVAL(entry) = &PL_sv_placeholder;
1193 /* We'll be saving this slot, so the number of allocated keys
1194 * doesn't go down, but the number placeholders goes up */
1195 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1197 *oentry = HeNEXT(entry);
1199 xhv->xhv_fill--; /* HvFILL(hv)-- */
1200 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1203 hv_free_ent(hv, entry);
1204 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1205 if (xhv->xhv_keys == 0)
1206 HvHASKFLAGS_off(hv);
1210 if (SvREADONLY(hv)) {
1211 S_hv_notallowed(aTHX_ k_flags, key, klen,
1212 "delete disallowed key '%"SVf"' from"
1216 if (k_flags & HVhek_FREEKEY)
1222 =for apidoc hv_exists
1224 Returns a boolean indicating whether the specified hash key exists. The
1225 C<klen> is the length of the key.
1231 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
1233 register XPVHV* xhv;
1237 bool is_utf8 = FALSE;
1238 const char *keysave = key;
1249 if (SvRMAGICAL(hv)) {
1250 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1251 sv = sv_newmortal();
1252 mg_copy((SV*)hv, sv, key, klen);
1253 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
1254 return (bool)SvTRUE(sv);
1256 #ifdef ENV_IS_CASELESS
1257 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1258 sv = sv_2mortal(newSVpvn(key,klen));
1259 key = strupr(SvPVX(sv));
1264 xhv = (XPVHV*)SvANY(hv);
1265 #ifndef DYNAMIC_ENV_FETCH
1266 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1271 STRLEN tmplen = klen;
1272 /* See the note in hv_fetch(). --jhi */
1273 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
1276 k_flags = HVhek_UTF8;
1278 k_flags |= HVhek_FREEKEY;
1282 PERL_HASH_INTERNAL(hash, key, klen);
1284 PERL_HASH(hash, key, klen);
1287 #ifdef DYNAMIC_ENV_FETCH
1288 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1291 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1292 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1293 for (; entry; entry = HeNEXT(entry)) {
1294 if (HeHASH(entry) != hash) /* strings can't be equal */
1296 if (HeKLEN(entry) != klen)
1298 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1300 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1302 if (k_flags & HVhek_FREEKEY)
1304 /* If we find the key, but the value is a placeholder, return false. */
1305 if (HeVAL(entry) == &PL_sv_placeholder)
1310 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1311 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1313 char *env = PerlEnv_ENVgetenv_len(key,&len);
1315 sv = newSVpvn(env,len);
1317 (void)hv_store(hv,key,klen,sv,hash);
1318 if (k_flags & HVhek_FREEKEY)
1324 if (k_flags & HVhek_FREEKEY)
1331 =for apidoc hv_exists_ent
1333 Returns a boolean indicating whether the specified hash key exists. C<hash>
1334 can be a valid precomputed hash value, or 0 to ask for it to be
1341 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1343 register XPVHV* xhv;
1355 if (SvRMAGICAL(hv)) {
1356 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1357 SV* svret = sv_newmortal();
1358 sv = sv_newmortal();
1359 keysv = sv_2mortal(newSVsv(keysv));
1360 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
1361 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1362 return (bool)SvTRUE(svret);
1364 #ifdef ENV_IS_CASELESS
1365 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1366 key = SvPV(keysv, klen);
1367 keysv = sv_2mortal(newSVpvn(key,klen));
1368 (void)strupr(SvPVX(keysv));
1374 xhv = (XPVHV*)SvANY(hv);
1375 #ifndef DYNAMIC_ENV_FETCH
1376 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1380 keysave = key = SvPV(keysv, klen);
1381 is_utf8 = (SvUTF8(keysv) != 0);
1383 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1385 k_flags = HVhek_UTF8;
1387 k_flags |= HVhek_FREEKEY;
1390 PERL_HASH_INTERNAL(hash, key, klen);
1392 PERL_HASH(hash, key, klen);
1394 #ifdef DYNAMIC_ENV_FETCH
1395 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1398 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1399 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1400 for (; entry; entry = HeNEXT(entry)) {
1401 if (HeHASH(entry) != hash) /* strings can't be equal */
1403 if (HeKLEN(entry) != (I32)klen)
1405 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1407 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1409 if (k_flags & HVhek_FREEKEY)
1411 /* If we find the key, but the value is a placeholder, return false. */
1412 if (HeVAL(entry) == &PL_sv_placeholder)
1416 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1417 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1419 char *env = PerlEnv_ENVgetenv_len(key,&len);
1421 sv = newSVpvn(env,len);
1423 (void)hv_store_ent(hv,keysv,sv,hash);
1424 if (k_flags & HVhek_FREEKEY)
1430 if (k_flags & HVhek_FREEKEY)
1436 S_hsplit(pTHX_ HV *hv)
1438 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1439 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1440 register I32 newsize = oldsize * 2;
1442 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1446 register HE **oentry;
1447 int longest_chain = 0;
1451 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1452 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1458 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1463 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1464 if (oldsize >= 64) {
1465 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1466 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1469 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1473 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1474 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1475 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1478 for (i=0; i<oldsize; i++,aep++) {
1479 int left_length = 0;
1480 int right_length = 0;
1482 if (!*aep) /* non-existent */
1485 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1486 if ((HeHASH(entry) & newsize) != (U32)i) {
1487 *oentry = HeNEXT(entry);
1488 HeNEXT(entry) = *bep;
1490 xhv->xhv_fill++; /* HvFILL(hv)++ */
1496 oentry = &HeNEXT(entry);
1500 if (!*aep) /* everything moved */
1501 xhv->xhv_fill--; /* HvFILL(hv)-- */
1502 /* I think we don't actually need to keep track of the longest length,
1503 merely flag if anything is too long. But for the moment while
1504 developing this code I'll track it. */
1505 if (left_length > longest_chain)
1506 longest_chain = left_length;
1507 if (right_length > longest_chain)
1508 longest_chain = right_length;
1512 /* Pick your policy for "hashing isn't working" here: */
1513 if (longest_chain < 8 || longest_chain * 2 < HvTOTALKEYS(hv)
1518 if (hv == PL_strtab) {
1519 /* Urg. Someone is doing something nasty to the string table.
1524 /* Awooga. Awooga. Pathological data. */
1525 /*PerlIO_printf(PerlIO_stderr(), "Awooga %d of %d with %d/%d buckets\n",
1526 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1529 Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1530 was_shared = HvSHAREKEYS(hv);
1533 HvSHAREKEYS_off(hv);
1536 aep = (HE **) xhv->xhv_array;
1538 for (i=0; i<newsize; i++,aep++) {
1541 /* We're going to trash this HE's next pointer when we chain it
1542 into the new hash below, so store where we go next. */
1543 HE *next = HeNEXT(entry);
1547 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1552 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1553 hash, HeKFLAGS(entry));
1554 unshare_hek (HeKEY_hek(entry));
1555 HeKEY_hek(entry) = new_hek;
1557 /* Not shared, so simply write the new hash in. */
1558 HeHASH(entry) = hash;
1560 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1561 HEK_REHASH_on(HeKEY_hek(entry));
1562 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1564 /* Copy oentry to the correct new chain. */
1565 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1567 xhv->xhv_fill++; /* HvFILL(hv)++ */
1568 HeNEXT(entry) = *bep;
1574 Safefree (xhv->xhv_array);
1575 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1579 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1581 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1582 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1583 register I32 newsize;
1589 register HE **oentry;
1591 newsize = (I32) newmax; /* possible truncation here */
1592 if (newsize != newmax || newmax <= oldsize)
1594 while ((newsize & (1 + ~newsize)) != newsize) {
1595 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1597 if (newsize < newmax)
1599 if (newsize < newmax)
1600 return; /* overflow detection */
1602 a = xhv->xhv_array; /* HvARRAY(hv) */
1605 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1606 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1612 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1617 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1618 if (oldsize >= 64) {
1619 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1620 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1623 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1626 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1629 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1631 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1632 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1633 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1637 for (i=0; i<oldsize; i++,aep++) {
1638 if (!*aep) /* non-existent */
1640 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1641 if ((j = (HeHASH(entry) & newsize)) != i) {
1643 *oentry = HeNEXT(entry);
1644 if (!(HeNEXT(entry) = aep[j]))
1645 xhv->xhv_fill++; /* HvFILL(hv)++ */
1650 oentry = &HeNEXT(entry);
1652 if (!*aep) /* everything moved */
1653 xhv->xhv_fill--; /* HvFILL(hv)-- */
1660 Creates a new HV. The reference count is set to 1.
1669 register XPVHV* xhv;
1671 hv = (HV*)NEWSV(502,0);
1672 sv_upgrade((SV *)hv, SVt_PVHV);
1673 xhv = (XPVHV*)SvANY(hv);
1676 #ifndef NODEFAULT_SHAREKEYS
1677 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1680 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1681 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1682 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1683 (void)hv_iterinit(hv); /* so each() will start off right */
1688 Perl_newHVhv(pTHX_ HV *ohv)
1691 STRLEN hv_max, hv_fill;
1693 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1695 hv_max = HvMAX(ohv);
1697 if (!SvMAGICAL((SV *)ohv)) {
1698 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1700 bool shared = !!HvSHAREKEYS(ohv);
1701 HE **ents, **oents = (HE **)HvARRAY(ohv);
1703 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1706 /* In each bucket... */
1707 for (i = 0; i <= hv_max; i++) {
1708 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1715 /* Copy the linked list of entries. */
1716 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1717 U32 hash = HeHASH(oent);
1718 char *key = HeKEY(oent);
1719 STRLEN len = HeKLEN(oent);
1720 int flags = HeKFLAGS(oent);
1723 HeVAL(ent) = newSVsv(HeVAL(oent));
1725 = shared ? share_hek_flags(key, len, hash, flags)
1726 : save_hek_flags(key, len, hash, flags);
1737 HvFILL(hv) = hv_fill;
1738 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1742 /* Iterate over ohv, copying keys and values one at a time. */
1744 I32 riter = HvRITER(ohv);
1745 HE *eiter = HvEITER(ohv);
1747 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1748 while (hv_max && hv_max + 1 >= hv_fill * 2)
1749 hv_max = hv_max / 2;
1753 while ((entry = hv_iternext_flags(ohv, 0))) {
1754 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1755 newSVsv(HeVAL(entry)), HeHASH(entry),
1758 HvRITER(ohv) = riter;
1759 HvEITER(ohv) = eiter;
1766 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1773 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1774 PL_sub_generation++; /* may be deletion of method from stash */
1776 if (HeKLEN(entry) == HEf_SVKEY) {
1777 SvREFCNT_dec(HeKEY_sv(entry));
1778 Safefree(HeKEY_hek(entry));
1780 else if (HvSHAREKEYS(hv))
1781 unshare_hek(HeKEY_hek(entry));
1783 Safefree(HeKEY_hek(entry));
1788 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1792 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1793 PL_sub_generation++; /* may be deletion of method from stash */
1794 sv_2mortal(HeVAL(entry)); /* free between statements */
1795 if (HeKLEN(entry) == HEf_SVKEY) {
1796 sv_2mortal(HeKEY_sv(entry));
1797 Safefree(HeKEY_hek(entry));
1799 else if (HvSHAREKEYS(hv))
1800 unshare_hek(HeKEY_hek(entry));
1802 Safefree(HeKEY_hek(entry));
1807 =for apidoc hv_clear
1809 Clears a hash, making it empty.
1815 Perl_hv_clear(pTHX_ HV *hv)
1817 register XPVHV* xhv;
1821 xhv = (XPVHV*)SvANY(hv);
1823 if (SvREADONLY(hv)) {
1824 /* restricted hash: convert all keys to placeholders */
1827 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1828 entry = ((HE**)xhv->xhv_array)[i];
1829 for (; entry; entry = HeNEXT(entry)) {
1830 /* not already placeholder */
1831 if (HeVAL(entry) != &PL_sv_placeholder) {
1832 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1833 SV* keysv = hv_iterkeysv(entry);
1835 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1838 SvREFCNT_dec(HeVAL(entry));
1839 HeVAL(entry) = &PL_sv_placeholder;
1840 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1848 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1849 if (xhv->xhv_array /* HvARRAY(hv) */)
1850 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1851 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1856 HvHASKFLAGS_off(hv);
1860 S_hfreeentries(pTHX_ HV *hv)
1862 register HE **array;
1864 register HE *oentry = Null(HE*);
1875 array = HvARRAY(hv);
1876 /* make everyone else think the array is empty, so that the destructors
1877 * called for freed entries can't recusively mess with us */
1878 HvARRAY(hv) = Null(HE**);
1880 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1886 entry = HeNEXT(entry);
1887 hv_free_ent(hv, oentry);
1892 entry = array[riter];
1895 HvARRAY(hv) = array;
1896 (void)hv_iterinit(hv);
1900 =for apidoc hv_undef
1908 Perl_hv_undef(pTHX_ HV *hv)
1910 register XPVHV* xhv;
1913 xhv = (XPVHV*)SvANY(hv);
1915 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1918 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1919 Safefree(HvNAME(hv));
1922 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1923 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1924 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1931 =for apidoc hv_iterinit
1933 Prepares a starting point to traverse a hash table. Returns the number of
1934 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1935 currently only meaningful for hashes without tie magic.
1937 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1938 hash buckets that happen to be in use. If you still need that esoteric
1939 value, you can get it through the macro C<HvFILL(tb)>.
1946 Perl_hv_iterinit(pTHX_ HV *hv)
1948 register XPVHV* xhv;
1952 Perl_croak(aTHX_ "Bad hash");
1953 xhv = (XPVHV*)SvANY(hv);
1954 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1955 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1957 hv_free_ent(hv, entry);
1959 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1960 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1961 /* used to be xhv->xhv_fill before 5.004_65 */
1962 return XHvTOTALKEYS(xhv);
1965 =for apidoc hv_iternext
1967 Returns entries from a hash iterator. See C<hv_iterinit>.
1969 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1970 iterator currently points to, without losing your place or invalidating your
1971 iterator. Note that in this case the current entry is deleted from the hash
1972 with your iterator holding the last reference to it. Your iterator is flagged
1973 to free the entry on the next call to C<hv_iternext>, so you must not discard
1974 your iterator immediately else the entry will leak - call C<hv_iternext> to
1975 trigger the resource deallocation.
1981 Perl_hv_iternext(pTHX_ HV *hv)
1983 return hv_iternext_flags(hv, 0);
1987 =for apidoc hv_iternext_flags
1989 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1990 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1991 set the placeholders keys (for restricted hashes) will be returned in addition
1992 to normal keys. By default placeholders are automatically skipped over.
1993 Currently a placeholder is implemented with a value that is
1994 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1995 restricted hashes may change, and the implementation currently is
1996 insufficiently abstracted for any change to be tidy.
2002 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2004 register XPVHV* xhv;
2010 Perl_croak(aTHX_ "Bad hash");
2011 xhv = (XPVHV*)SvANY(hv);
2012 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
2014 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
2015 SV *key = sv_newmortal();
2017 sv_setsv(key, HeSVKEY_force(entry));
2018 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2024 /* one HE per MAGICAL hash */
2025 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2027 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
2029 HeKEY_hek(entry) = hek;
2030 HeKLEN(entry) = HEf_SVKEY;
2032 magic_nextpack((SV*) hv,mg,key);
2034 /* force key to stay around until next time */
2035 HeSVKEY_set(entry, SvREFCNT_inc(key));
2036 return entry; /* beware, hent_val is not set */
2039 SvREFCNT_dec(HeVAL(entry));
2040 Safefree(HeKEY_hek(entry));
2042 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
2045 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
2046 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
2050 if (!xhv->xhv_array /* !HvARRAY(hv) */)
2051 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
2052 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
2054 /* At start of hash, entry is NULL. */
2057 entry = HeNEXT(entry);
2058 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2060 * Skip past any placeholders -- don't want to include them in
2063 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2064 entry = HeNEXT(entry);
2069 /* OK. Come to the end of the current list. Grab the next one. */
2071 xhv->xhv_riter++; /* HvRITER(hv)++ */
2072 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2073 /* There is no next one. End of the hash. */
2074 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
2077 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
2078 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
2080 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2081 /* If we have an entry, but it's a placeholder, don't count it.
2083 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2084 entry = HeNEXT(entry);
2086 /* Will loop again if this linked list starts NULL
2087 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2088 or if we run through it and find only placeholders. */
2091 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2093 hv_free_ent(hv, oldentry);
2096 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
2101 =for apidoc hv_iterkey
2103 Returns the key from the current position of the hash iterator. See
2110 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2112 if (HeKLEN(entry) == HEf_SVKEY) {
2114 char *p = SvPV(HeKEY_sv(entry), len);
2119 *retlen = HeKLEN(entry);
2120 return HeKEY(entry);
2124 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2126 =for apidoc hv_iterkeysv
2128 Returns the key as an C<SV*> from the current position of the hash
2129 iterator. The return value will always be a mortal copy of the key. Also
2136 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2138 if (HeKLEN(entry) != HEf_SVKEY) {
2139 HEK *hek = HeKEY_hek(entry);
2140 int flags = HEK_FLAGS(hek);
2143 if (flags & HVhek_WASUTF8) {
2145 Andreas would like keys he put in as utf8 to come back as utf8
2147 STRLEN utf8_len = HEK_LEN(hek);
2148 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2150 sv = newSVpvn ((char*)as_utf8, utf8_len);
2152 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2153 } else if (flags & HVhek_REHASH) {
2154 /* We don't have a pointer to the hv, so we have to replicate the
2155 flag into every HEK. This hv is using custom a hasing
2156 algorithm. Hence we can't return a shared string scalar, as
2157 that would contain the (wrong) hash value, and might get passed
2158 into an hv routine with a regular hash */
2160 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
2164 sv = newSVpvn_share(HEK_KEY(hek),
2165 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2168 return sv_2mortal(sv);
2170 return sv_mortalcopy(HeKEY_sv(entry));
2174 =for apidoc hv_iterval
2176 Returns the value from the current position of the hash iterator. See
2183 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2185 if (SvRMAGICAL(hv)) {
2186 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2187 SV* sv = sv_newmortal();
2188 if (HeKLEN(entry) == HEf_SVKEY)
2189 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2190 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2194 return HeVAL(entry);
2198 =for apidoc hv_iternextsv
2200 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2207 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2210 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2212 *key = hv_iterkey(he, retlen);
2213 return hv_iterval(hv, he);
2217 =for apidoc hv_magic
2219 Adds magic to a hash. See C<sv_magic>.
2225 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2227 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2230 #if 0 /* use the macro from hv.h instead */
2233 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2235 return HEK_KEY(share_hek(sv, len, hash));
2240 /* possibly free a shared string if no one has access to it
2241 * len and hash must both be valid for str.
2244 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2246 unshare_hek_or_pvn (NULL, str, len, hash);
2251 Perl_unshare_hek(pTHX_ HEK *hek)
2253 unshare_hek_or_pvn(hek, NULL, 0, 0);
2256 /* possibly free a shared string if no one has access to it
2257 hek if non-NULL takes priority over the other 3, else str, len and hash
2258 are used. If so, len and hash must both be valid for str.
2261 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2263 register XPVHV* xhv;
2265 register HE **oentry;
2268 bool is_utf8 = FALSE;
2270 const char *save = str;
2273 hash = HEK_HASH(hek);
2274 } else if (len < 0) {
2275 STRLEN tmplen = -len;
2277 /* See the note in hv_fetch(). --jhi */
2278 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2281 k_flags = HVhek_UTF8;
2283 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2286 /* what follows is the moral equivalent of:
2287 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2288 if (--*Svp == Nullsv)
2289 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2291 xhv = (XPVHV*)SvANY(PL_strtab);
2292 /* assert(xhv_array != 0) */
2294 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2295 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2297 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2298 if (HeKEY_hek(entry) != hek)
2304 int flags_masked = k_flags & HVhek_MASK;
2305 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2306 if (HeHASH(entry) != hash) /* strings can't be equal */
2308 if (HeKLEN(entry) != len)
2310 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2312 if (HeKFLAGS(entry) != flags_masked)
2320 if (--HeVAL(entry) == Nullsv) {
2321 *oentry = HeNEXT(entry);
2323 xhv->xhv_fill--; /* HvFILL(hv)-- */
2324 Safefree(HeKEY_hek(entry));
2326 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2330 UNLOCK_STRTAB_MUTEX;
2331 if (!found && ckWARN_d(WARN_INTERNAL))
2332 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2333 "Attempt to free non-existent shared string '%s'%s",
2334 hek ? HEK_KEY(hek) : str,
2335 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2336 if (k_flags & HVhek_FREEKEY)
2340 /* get a (constant) string ptr from the global string table
2341 * string will get added if it is not already there.
2342 * len and hash must both be valid for str.
2345 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2347 bool is_utf8 = FALSE;
2349 const char *save = str;
2352 STRLEN tmplen = -len;
2354 /* See the note in hv_fetch(). --jhi */
2355 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2357 /* If we were able to downgrade here, then than means that we were passed
2358 in a key which only had chars 0-255, but was utf8 encoded. */
2361 /* If we found we were able to downgrade the string to bytes, then
2362 we should flag that it needs upgrading on keys or each. Also flag
2363 that we need share_hek_flags to free the string. */
2365 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2368 return share_hek_flags (str, len, hash, flags);
2372 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2374 register XPVHV* xhv;
2376 register HE **oentry;
2379 int flags_masked = flags & HVhek_MASK;
2381 /* what follows is the moral equivalent of:
2383 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2384 hv_store(PL_strtab, str, len, Nullsv, hash);
2386 xhv = (XPVHV*)SvANY(PL_strtab);
2387 /* assert(xhv_array != 0) */
2389 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2390 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2391 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2392 if (HeHASH(entry) != hash) /* strings can't be equal */
2394 if (HeKLEN(entry) != len)
2396 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2398 if (HeKFLAGS(entry) != flags_masked)
2405 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2406 HeVAL(entry) = Nullsv;
2407 HeNEXT(entry) = *oentry;
2409 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2410 if (i) { /* initial entry? */
2411 xhv->xhv_fill++; /* HvFILL(hv)++ */
2412 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2417 ++HeVAL(entry); /* use value slot as REFCNT */
2418 UNLOCK_STRTAB_MUTEX;
2420 if (flags & HVhek_FREEKEY)
2423 return HeKEY_hek(entry);