3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "I sit beside the fire and think of all that I have seen." --Bilbo
16 =head1 Hash Manipulation Functions
21 #define PERL_HASH_INTERNAL_ACCESS
24 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
34 PL_he_root = HeNEXT(he);
43 HeNEXT(p) = (HE*)PL_he_root;
54 New(54, ptr, 1008/sizeof(XPV), XPV);
55 ptr->xpv_pv = (char*)PL_he_arenaroot;
56 PL_he_arenaroot = ptr;
59 heend = &he[1008 / sizeof(HE) - 1];
62 HeNEXT(he) = (HE*)(he + 1);
70 #define new_HE() (HE*)safemalloc(sizeof(HE))
71 #define del_HE(p) safefree((char*)p)
75 #define new_HE() new_he()
76 #define del_HE(p) del_he(p)
81 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
86 New(54, k, HEK_BASESIZE + len + 2, char);
88 Copy(str, HEK_KEY(hek), len, char);
89 HEK_KEY(hek)[len] = 0;
92 HEK_FLAGS(hek) = (unsigned char)flags;
96 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
100 Perl_free_tied_hv_pool(pTHX)
103 HE *he = PL_hv_fetch_ent_mh;
105 Safefree(HeKEY_hek(he));
110 PL_hv_fetch_ent_mh = Nullhe;
113 #if defined(USE_ITHREADS)
115 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
121 /* look for it in the table first */
122 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
126 /* create anew and remember what it is */
128 ptr_table_store(PL_ptr_table, e, ret);
130 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
131 if (HeKLEN(e) == HEf_SVKEY) {
133 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
134 HeKEY_hek(ret) = (HEK*)k;
135 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
138 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
141 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
143 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
146 #endif /* USE_ITHREADS */
149 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
152 SV *sv = sv_newmortal(), *esv = sv_newmortal();
153 if (!(flags & HVhek_FREEKEY)) {
154 sv_setpvn(sv, key, klen);
157 /* Need to free saved eventually assign to mortal SV */
158 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
159 sv_usepvn(sv, (char *) key, klen);
161 if (flags & HVhek_UTF8) {
164 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
165 Perl_croak(aTHX_ SvPVX(esv), sv);
168 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
174 Returns the SV which corresponds to the specified key in the hash. The
175 C<klen> is the length of the key. If C<lval> is set then the fetch will be
176 part of a store. Check that the return value is non-null before
177 dereferencing it to an C<SV*>.
179 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
180 information on how to use this function on tied hashes.
185 #define HV_FETCH_LVALUE 0x01
186 #define HV_FETCH_JUST_SV 0x02
189 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
202 hek = hv_fetch_common (hv, NULL, key, klen, flags,
203 HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0), 0);
204 return hek ? &HeVAL(hek) : NULL;
207 /* returns an HE * structure with the all fields set */
208 /* note that hent_val will be a mortal sv for MAGICAL hashes */
210 =for apidoc hv_fetch_ent
212 Returns the hash entry which corresponds to the specified key in the hash.
213 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
214 if you want the function to compute it. IF C<lval> is set then the fetch
215 will be part of a store. Make sure the return value is non-null before
216 accessing it. The return value when C<tb> is a tied hash is a pointer to a
217 static location, so be sure to make a copy of the structure if you need to
220 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
221 information on how to use this function on tied hashes.
227 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
229 return hv_fetch_common(hv, keysv, NULL, 0, 0, lval ? HV_FETCH_LVALUE : 0,
234 S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
235 int flags, int action, register U32 hash)
248 key = SvPV(keysv, klen);
250 is_utf8 = (SvUTF8(keysv) != 0);
252 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
256 if (SvRMAGICAL(hv)) {
257 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
260 /* XXX should be able to skimp on the HE/HEK here when
261 HV_FETCH_JUST_SV is true. */
264 keysv = newSVpvn(key, klen);
269 keysv = newSVsv(keysv);
271 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
274 /* grab a fake HE/HEK pair from the pool or make a new one */
275 entry = PL_hv_fetch_ent_mh;
277 PL_hv_fetch_ent_mh = HeNEXT(entry);
281 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
282 HeKEY_hek(entry) = (HEK*)k;
284 HeNEXT(entry) = Nullhe;
285 HeSVKEY_set(entry, keysv);
287 sv_upgrade(sv, SVt_PVLV);
289 LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
291 /* XXX remove at some point? */
292 if (flags & HVhek_FREEKEY)
297 #ifdef ENV_IS_CASELESS
298 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
300 for (i = 0; i < klen; ++i)
301 if (isLOWER(key[i])) {
302 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
303 (void)strupr(SvPVX(nkeysv));
304 entry = hv_fetch_common(hv, nkeysv, NULL, 0, 0, 0);
305 if (!entry && (action & HV_FETCH_LVALUE))
306 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
308 /* XXX remove at some point? */
309 if (flags & HVhek_FREEKEY)
318 xhv = (XPVHV*)SvANY(hv);
319 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
320 if ((action & HV_FETCH_LVALUE)
321 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
322 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
325 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
326 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
329 /* XXX remove at some point? */
330 if (flags & HVhek_FREEKEY)
338 int oldflags = flags;
339 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
343 flags &= ~HVhek_UTF8;
345 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
346 if (oldflags & HVhek_FREEKEY)
352 PERL_HASH_INTERNAL(hash, key, klen);
353 /* Yes, you do need this even though you are not "storing" because
354 you can flip the flags below if doing an lval lookup. (And that
355 was put in to give the semantics Andreas was expecting.) */
356 flags |= HVhek_REHASH;
358 if (keysv && (SvIsCOW_shared_hash(keysv))) {
361 PERL_HASH(hash, key, klen);
365 masked_flags = (flags & HVhek_MASK);
367 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
368 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
369 for (; entry; entry = HeNEXT(entry)) {
370 if (HeHASH(entry) != hash) /* strings can't be equal */
372 if (HeKLEN(entry) != (I32)klen)
374 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
376 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
378 if ((action & HV_FETCH_LVALUE) && HeKFLAGS(entry) != masked_flags) {
379 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
380 But if entry was set previously with HVhek_WASUTF8 and key now
381 doesn't (or vice versa) then we should change the key's flag,
382 as this is assignment. */
383 if (HvSHAREKEYS(hv)) {
384 /* Need to swap the key we have for a key with the flags we
385 need. As keys are shared we can't just write to the flag,
386 so we share the new one, unshare the old one. */
387 HEK *new_hek = share_hek_flags(key, klen, hash, masked_flags);
388 unshare_hek (HeKEY_hek(entry));
389 HeKEY_hek(entry) = new_hek;
392 HeKFLAGS(entry) = masked_flags;
393 if (masked_flags & HVhek_ENABLEHVKFLAGS)
396 /* if we find a placeholder, we pretend we haven't found anything */
397 if (HeVAL(entry) == &PL_sv_placeholder)
399 if (flags & HVhek_FREEKEY)
403 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
404 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
406 char *env = PerlEnv_ENVgetenv_len(key,&len);
408 /* XXX remove once common API complete */
410 nkeysv = sv_2mortal(newSVpvn(key,klen));
413 sv = newSVpvn(env,len);
415 if (flags & HVhek_FREEKEY)
417 return hv_store_ent(hv,keysv,sv,hash);
421 if (!entry && SvREADONLY(hv)) {
422 S_hv_notallowed(aTHX_ flags, key, klen,
423 "access disallowed key '%"SVf"' in"
426 if (action & HV_FETCH_LVALUE) {
427 /* XXX remove once common API complete */
429 keysv = sv_2mortal(newSVpvn(key,klen));
433 if (flags & HVhek_FREEKEY)
435 if (action & HV_FETCH_LVALUE) {
436 /* gonna assign to this, so it better be there */
438 return hv_store_ent(hv,keysv,sv,hash);
444 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
446 MAGIC *mg = SvMAGIC(hv);
450 if (isUPPER(mg->mg_type)) {
452 switch (mg->mg_type) {
453 case PERL_MAGIC_tied:
455 *needs_store = FALSE;
458 mg = mg->mg_moremagic;
465 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
466 the length of the key. The C<hash> parameter is the precomputed hash
467 value; if it is zero then Perl will compute it. The return value will be
468 NULL if the operation failed or if the value did not need to be actually
469 stored within the hash (as in the case of tied hashes). Otherwise it can
470 be dereferenced to get the original C<SV*>. Note that the caller is
471 responsible for suitably incrementing the reference count of C<val> before
472 the call, and decrementing it if the function returned NULL. Effectively
473 a successful hv_store takes ownership of one reference to C<val>. This is
474 usually what you want; a newly created SV has a reference count of one, so
475 if all your code does is create SVs then store them in a hash, hv_store
476 will own the only reference to the new SV, and your code doesn't need to do
477 anything further to tidy up. hv_store is not implemented as a call to
478 hv_store_ent, and does not create a temporary SV for the key, so if your
479 key data is not already in SV form then use hv_store in preference to
482 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
483 information on how to use this function on tied hashes.
489 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
491 HE *hek = hv_store_common (hv, NULL, key, klen, 0, val, hash);
492 return hek ? &HeVAL(hek) : NULL;
496 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
497 register U32 hash, int flags)
499 HE *hek = hv_store_common (hv, NULL, key, klen, flags, val, hash);
500 return hek ? &HeVAL(hek) : NULL;
504 =for apidoc hv_store_ent
506 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
507 parameter is the precomputed hash value; if it is zero then Perl will
508 compute it. The return value is the new hash entry so created. It will be
509 NULL if the operation failed or if the value did not need to be actually
510 stored within the hash (as in the case of tied hashes). Otherwise the
511 contents of the return value can be accessed using the C<He?> macros
512 described here. Note that the caller is responsible for suitably
513 incrementing the reference count of C<val> before the call, and
514 decrementing it if the function returned NULL. Effectively a successful
515 hv_store_ent takes ownership of one reference to C<val>. This is
516 usually what you want; a newly created SV has a reference count of one, so
517 if all your code does is create SVs then store them in a hash, hv_store
518 will own the only reference to the new SV, and your code doesn't need to do
519 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
520 unlike C<val> it does not take ownership of it, so maintaining the correct
521 reference count on C<key> is entirely the caller's responsibility. hv_store
522 is not implemented as a call to hv_store_ent, and does not create a temporary
523 SV for the key, so if your key data is not already in SV form then use
524 hv_store in preference to hv_store_ent.
526 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
527 information on how to use this function on tied hashes.
533 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
535 return hv_store_common(hv, keysv, NULL, 0, 0, val, hash);
539 S_hv_store_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
540 int flags, SV *val, U32 hash)
554 key = SvPV(keysv, klen);
555 is_utf8 = (SvUTF8(keysv) != 0);
562 /* XXX Need to fix this one level out. */
563 is_utf8 = (flags & HVhek_UTF8) ? TRUE : FALSE;
568 xhv = (XPVHV*)SvANY(hv);
572 hv_magic_check (hv, &needs_copy, &needs_store);
574 bool save_taint = PL_tainted;
575 if (keysv || is_utf8) {
577 keysv = newSVpvn(key, klen);
581 PL_tainted = SvTAINTED(keysv);
582 keysv = sv_2mortal(newSVsv(keysv));
583 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
585 mg_copy((SV*)hv, val, key, klen);
588 TAINT_IF(save_taint);
589 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) {
590 if (flags & HVhek_FREEKEY)
594 #ifdef ENV_IS_CASELESS
595 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
596 key = savepvn(key,klen);
597 key = (const char*)strupr((char*)key);
600 if (flags & HVhek_FREEKEY)
609 if (flags & HVhek_PLACEHOLD) {
610 /* We have been requested to insert a placeholder. Currently
611 only Storable is allowed to do this. */
612 val = &PL_sv_placeholder;
616 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
618 if (flags & HVhek_FREEKEY) {
619 /* This shouldn't happen if our caller does what we expect,
620 but strictly the API allows it. */
627 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
628 HvHASKFLAGS_on((SV*)hv);
632 /* We don't have a pointer to the hv, so we have to replicate the
633 flag into every HEK, so that hv_iterkeysv can see it. */
634 flags |= HVhek_REHASH;
635 PERL_HASH_INTERNAL(hash, key, klen);
637 if (keysv && SvIsCOW_shared_hash(keysv)) {
640 PERL_HASH(hash, key, klen);
644 if (!xhv->xhv_array /* !HvARRAY(hv) */)
645 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
646 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
649 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
650 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
653 for (; entry; ++n_links, entry = HeNEXT(entry)) {
654 if (HeHASH(entry) != hash) /* strings can't be equal */
656 if (HeKLEN(entry) != (I32)klen)
658 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
660 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
662 if (HeVAL(entry) == &PL_sv_placeholder)
663 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
665 SvREFCNT_dec(HeVAL(entry));
667 if (val == &PL_sv_placeholder)
668 xhv->xhv_placeholders++;
670 if (HeKFLAGS(entry) != flags) {
671 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
672 But if entry was set previously with HVhek_WASUTF8 and key now
673 doesn't (or vice versa) then we should change the key's flag,
674 as this is assignment. */
675 if (HvSHAREKEYS(hv)) {
676 /* Need to swap the key we have for a key with the flags we
677 need. As keys are shared we can't just write to the flag,
678 so we share the new one, unshare the old one. */
679 int flags_nofree = flags & ~HVhek_FREEKEY;
680 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
681 unshare_hek (HeKEY_hek(entry));
682 HeKEY_hek(entry) = new_hek;
685 HeKFLAGS(entry) = flags;
687 if (flags & HVhek_FREEKEY)
692 if (SvREADONLY(hv)) {
693 S_hv_notallowed(aTHX_ flags, key, klen,
694 "access disallowed key '%"SVf"' to"
699 /* share_hek_flags will do the free for us. This might be considered
702 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
703 else /* gotta do the real thing */
704 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
706 HeNEXT(entry) = *oentry;
709 if (val == &PL_sv_placeholder)
710 xhv->xhv_placeholders++;
712 xhv->xhv_keys++; /* HvKEYS(hv)++ */
713 if (!n_links) { /* initial entry? */
714 xhv->xhv_fill++; /* HvFILL(hv)++ */
715 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
716 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
717 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
718 splits on a rehashed hash, as we're not going to split it again,
719 and if someone is lucky (evil) enough to get all the keys in one
720 list they could exhaust our memory as we repeatedly double the
721 number of buckets on every entry. Linear search feels a less worse
730 =for apidoc hv_delete
732 Deletes a key/value pair in the hash. The value SV is removed from the
733 hash and returned to the caller. The C<klen> is the length of the key.
734 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
741 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
743 return hv_delete_common(hv, NULL, key, klen, flags, 0);
747 =for apidoc hv_delete_ent
749 Deletes a key/value pair in the hash. The value SV is removed from the
750 hash and returned to the caller. The C<flags> value will normally be zero;
751 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
752 precomputed hash value, or 0 to ask for it to be computed.
758 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
760 return hv_delete_common(hv, keysv, NULL, 0, flags, hash);
764 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
771 register HE **oentry;
781 key = SvPV(keysv, klen);
782 is_utf8 = (SvUTF8(keysv) != 0);
794 if (SvRMAGICAL(hv)) {
797 hv_magic_check (hv, &needs_copy, &needs_store);
802 if ((entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
807 if ((svp = hv_fetch(hv, key, is_utf8 ? -klen : klen, TRUE))) {
816 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
817 /* No longer an element */
818 sv_unmagic(sv, PERL_MAGIC_tiedelem);
821 return Nullsv; /* element cannot be deleted */
824 #ifdef ENV_IS_CASELESS
825 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
826 /* XXX This code isn't UTF8 clean. */
827 keysv = sv_2mortal(newSVpvn(key,klen));
828 keysave = key = strupr(SvPVX(keysv));
835 xhv = (XPVHV*)SvANY(hv);
836 if (!xhv->xhv_array /* !HvARRAY(hv) */)
840 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
842 k_flags = HVhek_UTF8;
844 k_flags |= HVhek_FREEKEY;
848 PERL_HASH_INTERNAL(hash, key, klen);
850 PERL_HASH(hash, key, klen);
853 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
854 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
857 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
858 if (HeHASH(entry) != hash) /* strings can't be equal */
860 if (HeKLEN(entry) != (I32)klen)
862 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
864 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
866 if (k_flags & HVhek_FREEKEY)
869 /* if placeholder is here, it's already been deleted.... */
870 if (HeVAL(entry) == &PL_sv_placeholder)
873 return Nullsv; /* if still SvREADONLY, leave it deleted. */
875 /* okay, really delete the placeholder. */
876 *oentry = HeNEXT(entry);
878 xhv->xhv_fill--; /* HvFILL(hv)-- */
879 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
882 hv_free_ent(hv, entry);
883 xhv->xhv_keys--; /* HvKEYS(hv)-- */
884 if (xhv->xhv_keys == 0)
886 xhv->xhv_placeholders--;
889 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
890 S_hv_notallowed(aTHX_ k_flags, key, klen,
891 "delete readonly key '%"SVf"' from"
895 if (flags & G_DISCARD)
898 sv = sv_2mortal(HeVAL(entry));
899 HeVAL(entry) = &PL_sv_placeholder;
903 * If a restricted hash, rather than really deleting the entry, put
904 * a placeholder there. This marks the key as being "approved", so
905 * we can still access via not-really-existing key without raising
908 if (SvREADONLY(hv)) {
909 HeVAL(entry) = &PL_sv_placeholder;
910 /* We'll be saving this slot, so the number of allocated keys
911 * doesn't go down, but the number placeholders goes up */
912 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
914 *oentry = HeNEXT(entry);
916 xhv->xhv_fill--; /* HvFILL(hv)-- */
917 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
920 hv_free_ent(hv, entry);
921 xhv->xhv_keys--; /* HvKEYS(hv)-- */
922 if (xhv->xhv_keys == 0)
927 if (SvREADONLY(hv)) {
928 S_hv_notallowed(aTHX_ k_flags, key, klen,
929 "delete disallowed key '%"SVf"' from"
933 if (k_flags & HVhek_FREEKEY)
939 =for apidoc hv_exists
941 Returns a boolean indicating whether the specified hash key exists. The
942 C<klen> is the length of the key.
948 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
950 return hv_exists_common(hv, NULL, key, klen, 0);
954 =for apidoc hv_exists_ent
956 Returns a boolean indicating whether the specified hash key exists. C<hash>
957 can be a valid precomputed hash value, or 0 to ask for it to be
964 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
966 return hv_exists_common(hv, keysv, NULL, 0, hash);
970 S_hv_exists_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
985 key = SvPV(keysv, klen);
986 is_utf8 = (SvUTF8(keysv) != 0);
998 if (SvRMAGICAL(hv)) {
999 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1002 if (keysv || is_utf8) {
1004 keysv = newSVpvn(key, klen);
1007 keysv = newSVsv(keysv);
1009 key = (char *)sv_2mortal(keysv);
1013 /* I don't understand why hv_exists_ent has svret and sv,
1014 whereas hv_exists only had one. */
1015 svret = sv_newmortal();
1016 sv = sv_newmortal();
1017 mg_copy((SV*)hv, sv, key, klen);
1018 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1019 return (bool)SvTRUE(svret);
1021 #ifdef ENV_IS_CASELESS
1022 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1023 /* XXX This code isn't UTF8 clean. */
1024 keysv = sv_2mortal(newSVpvn(key,klen));
1025 keysave = key = strupr(SvPVX(keysv));
1032 xhv = (XPVHV*)SvANY(hv);
1033 #ifndef DYNAMIC_ENV_FETCH
1034 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1039 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1041 k_flags = HVhek_UTF8;
1043 k_flags |= HVhek_FREEKEY;
1046 PERL_HASH_INTERNAL(hash, key, klen);
1048 PERL_HASH(hash, key, klen);
1050 #ifdef DYNAMIC_ENV_FETCH
1051 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1054 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1055 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1056 for (; entry; entry = HeNEXT(entry)) {
1057 if (HeHASH(entry) != hash) /* strings can't be equal */
1059 if (HeKLEN(entry) != (I32)klen)
1061 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1063 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1065 if (k_flags & HVhek_FREEKEY)
1067 /* If we find the key, but the value is a placeholder, return false. */
1068 if (HeVAL(entry) == &PL_sv_placeholder)
1072 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1073 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1075 char *env = PerlEnv_ENVgetenv_len(key,&len);
1077 sv = newSVpvn(env,len);
1079 (void)hv_store_ent(hv,keysv,sv,hash);
1080 if (k_flags & HVhek_FREEKEY)
1086 if (k_flags & HVhek_FREEKEY)
1093 S_hsplit(pTHX_ HV *hv)
1095 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1096 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1097 register I32 newsize = oldsize * 2;
1099 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1103 register HE **oentry;
1104 int longest_chain = 0;
1108 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1109 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1115 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1120 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1121 if (oldsize >= 64) {
1122 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1123 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1126 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1130 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1131 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1132 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1135 for (i=0; i<oldsize; i++,aep++) {
1136 int left_length = 0;
1137 int right_length = 0;
1139 if (!*aep) /* non-existent */
1142 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1143 if ((HeHASH(entry) & newsize) != (U32)i) {
1144 *oentry = HeNEXT(entry);
1145 HeNEXT(entry) = *bep;
1147 xhv->xhv_fill++; /* HvFILL(hv)++ */
1153 oentry = &HeNEXT(entry);
1157 if (!*aep) /* everything moved */
1158 xhv->xhv_fill--; /* HvFILL(hv)-- */
1159 /* I think we don't actually need to keep track of the longest length,
1160 merely flag if anything is too long. But for the moment while
1161 developing this code I'll track it. */
1162 if (left_length > longest_chain)
1163 longest_chain = left_length;
1164 if (right_length > longest_chain)
1165 longest_chain = right_length;
1169 /* Pick your policy for "hashing isn't working" here: */
1170 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
1175 if (hv == PL_strtab) {
1176 /* Urg. Someone is doing something nasty to the string table.
1181 /* Awooga. Awooga. Pathological data. */
1182 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1183 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1186 Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1187 was_shared = HvSHAREKEYS(hv);
1190 HvSHAREKEYS_off(hv);
1193 aep = (HE **) xhv->xhv_array;
1195 for (i=0; i<newsize; i++,aep++) {
1198 /* We're going to trash this HE's next pointer when we chain it
1199 into the new hash below, so store where we go next. */
1200 HE *next = HeNEXT(entry);
1204 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1209 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1210 hash, HeKFLAGS(entry));
1211 unshare_hek (HeKEY_hek(entry));
1212 HeKEY_hek(entry) = new_hek;
1214 /* Not shared, so simply write the new hash in. */
1215 HeHASH(entry) = hash;
1217 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1218 HEK_REHASH_on(HeKEY_hek(entry));
1219 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1221 /* Copy oentry to the correct new chain. */
1222 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1224 xhv->xhv_fill++; /* HvFILL(hv)++ */
1225 HeNEXT(entry) = *bep;
1231 Safefree (xhv->xhv_array);
1232 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1236 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1238 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1239 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1240 register I32 newsize;
1246 register HE **oentry;
1248 newsize = (I32) newmax; /* possible truncation here */
1249 if (newsize != newmax || newmax <= oldsize)
1251 while ((newsize & (1 + ~newsize)) != newsize) {
1252 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1254 if (newsize < newmax)
1256 if (newsize < newmax)
1257 return; /* overflow detection */
1259 a = xhv->xhv_array; /* HvARRAY(hv) */
1262 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1263 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1269 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1274 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1275 if (oldsize >= 64) {
1276 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1277 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1280 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1283 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1286 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1288 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1289 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1290 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1294 for (i=0; i<oldsize; i++,aep++) {
1295 if (!*aep) /* non-existent */
1297 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1298 if ((j = (HeHASH(entry) & newsize)) != i) {
1300 *oentry = HeNEXT(entry);
1301 if (!(HeNEXT(entry) = aep[j]))
1302 xhv->xhv_fill++; /* HvFILL(hv)++ */
1307 oentry = &HeNEXT(entry);
1309 if (!*aep) /* everything moved */
1310 xhv->xhv_fill--; /* HvFILL(hv)-- */
1317 Creates a new HV. The reference count is set to 1.
1326 register XPVHV* xhv;
1328 hv = (HV*)NEWSV(502,0);
1329 sv_upgrade((SV *)hv, SVt_PVHV);
1330 xhv = (XPVHV*)SvANY(hv);
1333 #ifndef NODEFAULT_SHAREKEYS
1334 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1337 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1338 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1339 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1340 (void)hv_iterinit(hv); /* so each() will start off right */
1345 Perl_newHVhv(pTHX_ HV *ohv)
1348 STRLEN hv_max, hv_fill;
1350 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1352 hv_max = HvMAX(ohv);
1354 if (!SvMAGICAL((SV *)ohv)) {
1355 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1357 bool shared = !!HvSHAREKEYS(ohv);
1358 HE **ents, **oents = (HE **)HvARRAY(ohv);
1360 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1363 /* In each bucket... */
1364 for (i = 0; i <= hv_max; i++) {
1365 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1372 /* Copy the linked list of entries. */
1373 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1374 U32 hash = HeHASH(oent);
1375 char *key = HeKEY(oent);
1376 STRLEN len = HeKLEN(oent);
1377 int flags = HeKFLAGS(oent);
1380 HeVAL(ent) = newSVsv(HeVAL(oent));
1382 = shared ? share_hek_flags(key, len, hash, flags)
1383 : save_hek_flags(key, len, hash, flags);
1394 HvFILL(hv) = hv_fill;
1395 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1399 /* Iterate over ohv, copying keys and values one at a time. */
1401 I32 riter = HvRITER(ohv);
1402 HE *eiter = HvEITER(ohv);
1404 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1405 while (hv_max && hv_max + 1 >= hv_fill * 2)
1406 hv_max = hv_max / 2;
1410 while ((entry = hv_iternext_flags(ohv, 0))) {
1411 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1412 newSVsv(HeVAL(entry)), HeHASH(entry),
1415 HvRITER(ohv) = riter;
1416 HvEITER(ohv) = eiter;
1423 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1430 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1431 PL_sub_generation++; /* may be deletion of method from stash */
1433 if (HeKLEN(entry) == HEf_SVKEY) {
1434 SvREFCNT_dec(HeKEY_sv(entry));
1435 Safefree(HeKEY_hek(entry));
1437 else if (HvSHAREKEYS(hv))
1438 unshare_hek(HeKEY_hek(entry));
1440 Safefree(HeKEY_hek(entry));
1445 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1449 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1450 PL_sub_generation++; /* may be deletion of method from stash */
1451 sv_2mortal(HeVAL(entry)); /* free between statements */
1452 if (HeKLEN(entry) == HEf_SVKEY) {
1453 sv_2mortal(HeKEY_sv(entry));
1454 Safefree(HeKEY_hek(entry));
1456 else if (HvSHAREKEYS(hv))
1457 unshare_hek(HeKEY_hek(entry));
1459 Safefree(HeKEY_hek(entry));
1464 =for apidoc hv_clear
1466 Clears a hash, making it empty.
1472 Perl_hv_clear(pTHX_ HV *hv)
1474 register XPVHV* xhv;
1478 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1480 xhv = (XPVHV*)SvANY(hv);
1482 if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
1483 /* restricted hash: convert all keys to placeholders */
1486 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1487 entry = ((HE**)xhv->xhv_array)[i];
1488 for (; entry; entry = HeNEXT(entry)) {
1489 /* not already placeholder */
1490 if (HeVAL(entry) != &PL_sv_placeholder) {
1491 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1492 SV* keysv = hv_iterkeysv(entry);
1494 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1497 SvREFCNT_dec(HeVAL(entry));
1498 HeVAL(entry) = &PL_sv_placeholder;
1499 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1507 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1508 if (xhv->xhv_array /* HvARRAY(hv) */)
1509 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1510 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1515 HvHASKFLAGS_off(hv);
1520 =for apidoc hv_clear_placeholders
1522 Clears any placeholders from a hash. If a restricted hash has any of its keys
1523 marked as readonly and the key is subsequently deleted, the key is not actually
1524 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1525 it so it will be ignored by future operations such as iterating over the hash,
1526 but will still allow the hash to have a value reaasigned to the key at some
1527 future point. This function clears any such placeholder keys from the hash.
1528 See Hash::Util::lock_keys() for an example of its use.
1534 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1537 items = (I32)HvPLACEHOLDERS(hv);
1540 I32 riter = HvRITER(hv);
1541 HE *eiter = HvEITER(hv);
1543 /* This may look suboptimal with the items *after* the iternext, but
1544 it's quite deliberate. We only get here with items==0 if we've
1545 just deleted the last placeholder in the hash. If we've just done
1546 that then it means that the hash is in lazy delete mode, and the
1547 HE is now only referenced in our iterator. If we just quit the loop
1548 and discarded our iterator then the HE leaks. So we do the && the
1549 other way to ensure iternext is called just one more time, which
1550 has the side effect of triggering the lazy delete. */
1551 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1553 SV *val = hv_iterval(hv, entry);
1555 if (val == &PL_sv_placeholder) {
1557 /* It seems that I have to go back in the front of the hash
1558 API to delete a hash, even though I have a HE structure
1559 pointing to the very entry I want to delete, and could hold
1560 onto the previous HE that points to it. And it's easier to
1561 go in with SVs as I can then specify the precomputed hash,
1562 and don't have fun and games with utf8 keys. */
1563 SV *key = hv_iterkeysv(entry);
1565 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
1569 HvRITER(hv) = riter;
1570 HvEITER(hv) = eiter;
1575 S_hfreeentries(pTHX_ HV *hv)
1577 register HE **array;
1579 register HE *oentry = Null(HE*);
1590 array = HvARRAY(hv);
1591 /* make everyone else think the array is empty, so that the destructors
1592 * called for freed entries can't recusively mess with us */
1593 HvARRAY(hv) = Null(HE**);
1595 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1601 entry = HeNEXT(entry);
1602 hv_free_ent(hv, oentry);
1607 entry = array[riter];
1610 HvARRAY(hv) = array;
1611 (void)hv_iterinit(hv);
1615 =for apidoc hv_undef
1623 Perl_hv_undef(pTHX_ HV *hv)
1625 register XPVHV* xhv;
1628 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1629 xhv = (XPVHV*)SvANY(hv);
1631 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1634 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1635 Safefree(HvNAME(hv));
1638 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1639 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1640 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1647 =for apidoc hv_iterinit
1649 Prepares a starting point to traverse a hash table. Returns the number of
1650 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1651 currently only meaningful for hashes without tie magic.
1653 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1654 hash buckets that happen to be in use. If you still need that esoteric
1655 value, you can get it through the macro C<HvFILL(tb)>.
1662 Perl_hv_iterinit(pTHX_ HV *hv)
1664 register XPVHV* xhv;
1668 Perl_croak(aTHX_ "Bad hash");
1669 xhv = (XPVHV*)SvANY(hv);
1670 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1671 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1673 hv_free_ent(hv, entry);
1675 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1676 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1677 /* used to be xhv->xhv_fill before 5.004_65 */
1678 return XHvTOTALKEYS(xhv);
1681 =for apidoc hv_iternext
1683 Returns entries from a hash iterator. See C<hv_iterinit>.
1685 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1686 iterator currently points to, without losing your place or invalidating your
1687 iterator. Note that in this case the current entry is deleted from the hash
1688 with your iterator holding the last reference to it. Your iterator is flagged
1689 to free the entry on the next call to C<hv_iternext>, so you must not discard
1690 your iterator immediately else the entry will leak - call C<hv_iternext> to
1691 trigger the resource deallocation.
1697 Perl_hv_iternext(pTHX_ HV *hv)
1699 return hv_iternext_flags(hv, 0);
1703 =for apidoc hv_iternext_flags
1705 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1706 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1707 set the placeholders keys (for restricted hashes) will be returned in addition
1708 to normal keys. By default placeholders are automatically skipped over.
1709 Currently a placeholder is implemented with a value that is
1710 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1711 restricted hashes may change, and the implementation currently is
1712 insufficiently abstracted for any change to be tidy.
1718 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1720 register XPVHV* xhv;
1726 Perl_croak(aTHX_ "Bad hash");
1727 xhv = (XPVHV*)SvANY(hv);
1728 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1730 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1731 SV *key = sv_newmortal();
1733 sv_setsv(key, HeSVKEY_force(entry));
1734 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1740 /* one HE per MAGICAL hash */
1741 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1743 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1745 HeKEY_hek(entry) = hek;
1746 HeKLEN(entry) = HEf_SVKEY;
1748 magic_nextpack((SV*) hv,mg,key);
1750 /* force key to stay around until next time */
1751 HeSVKEY_set(entry, SvREFCNT_inc(key));
1752 return entry; /* beware, hent_val is not set */
1755 SvREFCNT_dec(HeVAL(entry));
1756 Safefree(HeKEY_hek(entry));
1758 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1761 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1762 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1766 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1767 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1768 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1770 /* At start of hash, entry is NULL. */
1773 entry = HeNEXT(entry);
1774 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1776 * Skip past any placeholders -- don't want to include them in
1779 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1780 entry = HeNEXT(entry);
1785 /* OK. Come to the end of the current list. Grab the next one. */
1787 xhv->xhv_riter++; /* HvRITER(hv)++ */
1788 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1789 /* There is no next one. End of the hash. */
1790 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1793 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1794 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1796 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1797 /* If we have an entry, but it's a placeholder, don't count it.
1799 while (entry && HeVAL(entry) == &PL_sv_placeholder)
1800 entry = HeNEXT(entry);
1802 /* Will loop again if this linked list starts NULL
1803 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1804 or if we run through it and find only placeholders. */
1807 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1809 hv_free_ent(hv, oldentry);
1812 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1813 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1815 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1820 =for apidoc hv_iterkey
1822 Returns the key from the current position of the hash iterator. See
1829 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1831 if (HeKLEN(entry) == HEf_SVKEY) {
1833 char *p = SvPV(HeKEY_sv(entry), len);
1838 *retlen = HeKLEN(entry);
1839 return HeKEY(entry);
1843 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1845 =for apidoc hv_iterkeysv
1847 Returns the key as an C<SV*> from the current position of the hash
1848 iterator. The return value will always be a mortal copy of the key. Also
1855 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1857 if (HeKLEN(entry) != HEf_SVKEY) {
1858 HEK *hek = HeKEY_hek(entry);
1859 int flags = HEK_FLAGS(hek);
1862 if (flags & HVhek_WASUTF8) {
1864 Andreas would like keys he put in as utf8 to come back as utf8
1866 STRLEN utf8_len = HEK_LEN(hek);
1867 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1869 sv = newSVpvn ((char*)as_utf8, utf8_len);
1871 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1872 } else if (flags & HVhek_REHASH) {
1873 /* We don't have a pointer to the hv, so we have to replicate the
1874 flag into every HEK. This hv is using custom a hasing
1875 algorithm. Hence we can't return a shared string scalar, as
1876 that would contain the (wrong) hash value, and might get passed
1877 into an hv routine with a regular hash */
1879 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
1883 sv = newSVpvn_share(HEK_KEY(hek),
1884 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1887 return sv_2mortal(sv);
1889 return sv_mortalcopy(HeKEY_sv(entry));
1893 =for apidoc hv_iterval
1895 Returns the value from the current position of the hash iterator. See
1902 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1904 if (SvRMAGICAL(hv)) {
1905 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1906 SV* sv = sv_newmortal();
1907 if (HeKLEN(entry) == HEf_SVKEY)
1908 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1909 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1913 return HeVAL(entry);
1917 =for apidoc hv_iternextsv
1919 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1926 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1929 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
1931 *key = hv_iterkey(he, retlen);
1932 return hv_iterval(hv, he);
1936 =for apidoc hv_magic
1938 Adds magic to a hash. See C<sv_magic>.
1944 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1946 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1949 #if 0 /* use the macro from hv.h instead */
1952 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1954 return HEK_KEY(share_hek(sv, len, hash));
1959 /* possibly free a shared string if no one has access to it
1960 * len and hash must both be valid for str.
1963 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1965 unshare_hek_or_pvn (NULL, str, len, hash);
1970 Perl_unshare_hek(pTHX_ HEK *hek)
1972 unshare_hek_or_pvn(hek, NULL, 0, 0);
1975 /* possibly free a shared string if no one has access to it
1976 hek if non-NULL takes priority over the other 3, else str, len and hash
1977 are used. If so, len and hash must both be valid for str.
1980 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
1982 register XPVHV* xhv;
1984 register HE **oentry;
1987 bool is_utf8 = FALSE;
1989 const char *save = str;
1992 hash = HEK_HASH(hek);
1993 } else if (len < 0) {
1994 STRLEN tmplen = -len;
1996 /* See the note in hv_fetch(). --jhi */
1997 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2000 k_flags = HVhek_UTF8;
2002 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2005 /* what follows is the moral equivalent of:
2006 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2007 if (--*Svp == Nullsv)
2008 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2010 xhv = (XPVHV*)SvANY(PL_strtab);
2011 /* assert(xhv_array != 0) */
2013 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2014 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2016 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2017 if (HeKEY_hek(entry) != hek)
2023 int flags_masked = k_flags & HVhek_MASK;
2024 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2025 if (HeHASH(entry) != hash) /* strings can't be equal */
2027 if (HeKLEN(entry) != len)
2029 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2031 if (HeKFLAGS(entry) != flags_masked)
2039 if (--HeVAL(entry) == Nullsv) {
2040 *oentry = HeNEXT(entry);
2042 xhv->xhv_fill--; /* HvFILL(hv)-- */
2043 Safefree(HeKEY_hek(entry));
2045 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2049 UNLOCK_STRTAB_MUTEX;
2050 if (!found && ckWARN_d(WARN_INTERNAL))
2051 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2052 "Attempt to free non-existent shared string '%s'%s",
2053 hek ? HEK_KEY(hek) : str,
2054 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2055 if (k_flags & HVhek_FREEKEY)
2059 /* get a (constant) string ptr from the global string table
2060 * string will get added if it is not already there.
2061 * len and hash must both be valid for str.
2064 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2066 bool is_utf8 = FALSE;
2068 const char *save = str;
2071 STRLEN tmplen = -len;
2073 /* See the note in hv_fetch(). --jhi */
2074 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2076 /* If we were able to downgrade here, then than means that we were passed
2077 in a key which only had chars 0-255, but was utf8 encoded. */
2080 /* If we found we were able to downgrade the string to bytes, then
2081 we should flag that it needs upgrading on keys or each. Also flag
2082 that we need share_hek_flags to free the string. */
2084 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2087 return share_hek_flags (str, len, hash, flags);
2091 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2093 register XPVHV* xhv;
2095 register HE **oentry;
2098 int flags_masked = flags & HVhek_MASK;
2100 /* what follows is the moral equivalent of:
2102 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2103 hv_store(PL_strtab, str, len, Nullsv, hash);
2105 Can't rehash the shared string table, so not sure if it's worth
2106 counting the number of entries in the linked list
2108 xhv = (XPVHV*)SvANY(PL_strtab);
2109 /* assert(xhv_array != 0) */
2111 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2112 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2113 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2114 if (HeHASH(entry) != hash) /* strings can't be equal */
2116 if (HeKLEN(entry) != len)
2118 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2120 if (HeKFLAGS(entry) != flags_masked)
2127 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2128 HeVAL(entry) = Nullsv;
2129 HeNEXT(entry) = *oentry;
2131 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2132 if (i) { /* initial entry? */
2133 xhv->xhv_fill++; /* HvFILL(hv)++ */
2134 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2139 ++HeVAL(entry); /* use value slot as REFCNT */
2140 UNLOCK_STRTAB_MUTEX;
2142 if (flags & HVhek_FREEKEY)
2145 return HeKEY_hek(entry);
2150 =for apidoc hv_assert
2152 Check that a hash is in an internally consistent state.
2158 Perl_hv_assert(pTHX_ HV *hv)
2162 int placeholders = 0;
2165 I32 riter = HvRITER(hv);
2166 HE *eiter = HvEITER(hv);
2168 (void)hv_iterinit(hv);
2170 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2171 /* sanity check the values */
2172 if (HeVAL(entry) == &PL_sv_placeholder) {
2177 /* sanity check the keys */
2178 if (HeSVKEY(entry)) {
2179 /* Don't know what to check on SV keys. */
2180 } else if (HeKUTF8(entry)) {
2182 if (HeKWASUTF8(entry)) {
2183 PerlIO_printf(Perl_debug_log,
2184 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2185 (int) HeKLEN(entry), HeKEY(entry));
2188 } else if (HeKWASUTF8(entry)) {
2192 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2193 if (HvUSEDKEYS(hv) != real) {
2194 PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2195 (int) real, (int) HvUSEDKEYS(hv));
2198 if (HvPLACEHOLDERS(hv) != placeholders) {
2199 PerlIO_printf(Perl_debug_log,
2200 "Count %d placeholder(s), but hash reports %d\n",
2201 (int) placeholders, (int) HvPLACEHOLDERS(hv));
2205 if (withflags && ! HvHASKFLAGS(hv)) {
2206 PerlIO_printf(Perl_debug_log,
2207 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2214 HvRITER(hv) = riter; /* Restore hash iterator state */
2215 HvEITER(hv) = eiter;