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, I32 flags)
748 k_flags |= HVhek_UTF8;
752 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
756 =for apidoc hv_delete_ent
758 Deletes a key/value pair in the hash. The value SV is removed from the
759 hash and returned to the caller. The C<flags> value will normally be zero;
760 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
761 precomputed hash value, or 0 to ask for it to be computed.
767 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
769 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
773 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
774 int k_flags, I32 d_flags, U32 hash)
779 register HE **oentry;
789 key = SvPV(keysv, klen);
791 is_utf8 = (SvUTF8(keysv) != 0);
793 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
797 if (SvRMAGICAL(hv)) {
800 hv_magic_check (hv, &needs_copy, &needs_store);
803 entry = hv_fetch_common(hv, keysv, key, klen,
804 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
806 sv = entry ? HeVAL(entry) : NULL;
812 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
813 /* No longer an element */
814 sv_unmagic(sv, PERL_MAGIC_tiedelem);
817 return Nullsv; /* element cannot be deleted */
820 #ifdef ENV_IS_CASELESS
821 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
822 /* XXX This code isn't UTF8 clean. */
823 keysv = sv_2mortal(newSVpvn(key,klen));
824 keysave = key = strupr(SvPVX(keysv));
832 xhv = (XPVHV*)SvANY(hv);
833 if (!xhv->xhv_array /* !HvARRAY(hv) */)
837 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
839 if (k_flags & HVhek_FREEKEY) {
840 /* This shouldn't happen if our caller does what we expect,
841 but strictly the API allows it. */
846 k_flags |= HVhek_UTF8;
848 k_flags &= ~HVhek_UTF8;
850 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
851 HvHASKFLAGS_on((SV*)hv);
855 PERL_HASH_INTERNAL(hash, key, klen);
857 if (keysv && (SvIsCOW_shared_hash(keysv))) {
860 PERL_HASH(hash, key, klen);
862 PERL_HASH(hash, key, klen);
865 masked_flags = (k_flags & HVhek_MASK);
867 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
868 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
871 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
872 if (HeHASH(entry) != hash) /* strings can't be equal */
874 if (HeKLEN(entry) != (I32)klen)
876 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
878 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
880 if (k_flags & HVhek_FREEKEY)
883 /* if placeholder is here, it's already been deleted.... */
884 if (HeVAL(entry) == &PL_sv_placeholder)
887 return Nullsv; /* if still SvREADONLY, leave it deleted. */
889 /* okay, really delete the placeholder. */
890 *oentry = HeNEXT(entry);
892 xhv->xhv_fill--; /* HvFILL(hv)-- */
893 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
896 hv_free_ent(hv, entry);
897 xhv->xhv_keys--; /* HvKEYS(hv)-- */
898 if (xhv->xhv_keys == 0)
900 xhv->xhv_placeholders--;
903 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
904 S_hv_notallowed(aTHX_ k_flags, key, klen,
905 "delete readonly key '%"SVf"' from"
909 if (d_flags & G_DISCARD)
912 sv = sv_2mortal(HeVAL(entry));
913 HeVAL(entry) = &PL_sv_placeholder;
917 * If a restricted hash, rather than really deleting the entry, put
918 * a placeholder there. This marks the key as being "approved", so
919 * we can still access via not-really-existing key without raising
922 if (SvREADONLY(hv)) {
923 HeVAL(entry) = &PL_sv_placeholder;
924 /* We'll be saving this slot, so the number of allocated keys
925 * doesn't go down, but the number placeholders goes up */
926 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
928 *oentry = HeNEXT(entry);
930 xhv->xhv_fill--; /* HvFILL(hv)-- */
931 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
934 hv_free_ent(hv, entry);
935 xhv->xhv_keys--; /* HvKEYS(hv)-- */
936 if (xhv->xhv_keys == 0)
941 if (SvREADONLY(hv)) {
942 S_hv_notallowed(aTHX_ k_flags, key, klen,
943 "delete disallowed key '%"SVf"' from"
947 if (k_flags & HVhek_FREEKEY)
953 =for apidoc hv_exists
955 Returns a boolean indicating whether the specified hash key exists. The
956 C<klen> is the length of the key.
962 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
964 return hv_exists_common(hv, NULL, key, klen, 0);
968 =for apidoc hv_exists_ent
970 Returns a boolean indicating whether the specified hash key exists. C<hash>
971 can be a valid precomputed hash value, or 0 to ask for it to be
978 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
980 return hv_exists_common(hv, keysv, NULL, 0, hash);
984 S_hv_exists_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
999 key = SvPV(keysv, klen);
1000 is_utf8 = (SvUTF8(keysv) != 0);
1012 if (SvRMAGICAL(hv)) {
1013 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1016 if (keysv || is_utf8) {
1018 keysv = newSVpvn(key, klen);
1021 keysv = newSVsv(keysv);
1023 key = (char *)sv_2mortal(keysv);
1027 /* I don't understand why hv_exists_ent has svret and sv,
1028 whereas hv_exists only had one. */
1029 svret = sv_newmortal();
1030 sv = sv_newmortal();
1031 mg_copy((SV*)hv, sv, key, klen);
1032 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1033 return (bool)SvTRUE(svret);
1035 #ifdef ENV_IS_CASELESS
1036 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1037 /* XXX This code isn't UTF8 clean. */
1038 keysv = sv_2mortal(newSVpvn(key,klen));
1039 keysave = key = strupr(SvPVX(keysv));
1046 xhv = (XPVHV*)SvANY(hv);
1047 #ifndef DYNAMIC_ENV_FETCH
1048 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1053 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1055 k_flags = HVhek_UTF8;
1057 k_flags |= HVhek_FREEKEY;
1060 PERL_HASH_INTERNAL(hash, key, klen);
1062 PERL_HASH(hash, key, klen);
1064 #ifdef DYNAMIC_ENV_FETCH
1065 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1068 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1069 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1070 for (; entry; entry = HeNEXT(entry)) {
1071 if (HeHASH(entry) != hash) /* strings can't be equal */
1073 if (HeKLEN(entry) != (I32)klen)
1075 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1077 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1079 if (k_flags & HVhek_FREEKEY)
1081 /* If we find the key, but the value is a placeholder, return false. */
1082 if (HeVAL(entry) == &PL_sv_placeholder)
1086 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1087 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1089 char *env = PerlEnv_ENVgetenv_len(key,&len);
1091 sv = newSVpvn(env,len);
1093 (void)hv_store_ent(hv,keysv,sv,hash);
1094 if (k_flags & HVhek_FREEKEY)
1100 if (k_flags & HVhek_FREEKEY)
1107 S_hsplit(pTHX_ HV *hv)
1109 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1110 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1111 register I32 newsize = oldsize * 2;
1113 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1117 register HE **oentry;
1118 int longest_chain = 0;
1122 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1123 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1129 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1134 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1135 if (oldsize >= 64) {
1136 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1137 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1140 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1144 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1145 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1146 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1149 for (i=0; i<oldsize; i++,aep++) {
1150 int left_length = 0;
1151 int right_length = 0;
1153 if (!*aep) /* non-existent */
1156 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1157 if ((HeHASH(entry) & newsize) != (U32)i) {
1158 *oentry = HeNEXT(entry);
1159 HeNEXT(entry) = *bep;
1161 xhv->xhv_fill++; /* HvFILL(hv)++ */
1167 oentry = &HeNEXT(entry);
1171 if (!*aep) /* everything moved */
1172 xhv->xhv_fill--; /* HvFILL(hv)-- */
1173 /* I think we don't actually need to keep track of the longest length,
1174 merely flag if anything is too long. But for the moment while
1175 developing this code I'll track it. */
1176 if (left_length > longest_chain)
1177 longest_chain = left_length;
1178 if (right_length > longest_chain)
1179 longest_chain = right_length;
1183 /* Pick your policy for "hashing isn't working" here: */
1184 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
1189 if (hv == PL_strtab) {
1190 /* Urg. Someone is doing something nasty to the string table.
1195 /* Awooga. Awooga. Pathological data. */
1196 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1197 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1200 Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1201 was_shared = HvSHAREKEYS(hv);
1204 HvSHAREKEYS_off(hv);
1207 aep = (HE **) xhv->xhv_array;
1209 for (i=0; i<newsize; i++,aep++) {
1212 /* We're going to trash this HE's next pointer when we chain it
1213 into the new hash below, so store where we go next. */
1214 HE *next = HeNEXT(entry);
1218 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1223 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1224 hash, HeKFLAGS(entry));
1225 unshare_hek (HeKEY_hek(entry));
1226 HeKEY_hek(entry) = new_hek;
1228 /* Not shared, so simply write the new hash in. */
1229 HeHASH(entry) = hash;
1231 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1232 HEK_REHASH_on(HeKEY_hek(entry));
1233 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1235 /* Copy oentry to the correct new chain. */
1236 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1238 xhv->xhv_fill++; /* HvFILL(hv)++ */
1239 HeNEXT(entry) = *bep;
1245 Safefree (xhv->xhv_array);
1246 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1250 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1252 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1253 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1254 register I32 newsize;
1260 register HE **oentry;
1262 newsize = (I32) newmax; /* possible truncation here */
1263 if (newsize != newmax || newmax <= oldsize)
1265 while ((newsize & (1 + ~newsize)) != newsize) {
1266 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1268 if (newsize < newmax)
1270 if (newsize < newmax)
1271 return; /* overflow detection */
1273 a = xhv->xhv_array; /* HvARRAY(hv) */
1276 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1277 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1283 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1288 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1289 if (oldsize >= 64) {
1290 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1291 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1294 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1297 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1300 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1302 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1303 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1304 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1308 for (i=0; i<oldsize; i++,aep++) {
1309 if (!*aep) /* non-existent */
1311 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1312 if ((j = (HeHASH(entry) & newsize)) != i) {
1314 *oentry = HeNEXT(entry);
1315 if (!(HeNEXT(entry) = aep[j]))
1316 xhv->xhv_fill++; /* HvFILL(hv)++ */
1321 oentry = &HeNEXT(entry);
1323 if (!*aep) /* everything moved */
1324 xhv->xhv_fill--; /* HvFILL(hv)-- */
1331 Creates a new HV. The reference count is set to 1.
1340 register XPVHV* xhv;
1342 hv = (HV*)NEWSV(502,0);
1343 sv_upgrade((SV *)hv, SVt_PVHV);
1344 xhv = (XPVHV*)SvANY(hv);
1347 #ifndef NODEFAULT_SHAREKEYS
1348 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1351 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1352 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1353 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1354 (void)hv_iterinit(hv); /* so each() will start off right */
1359 Perl_newHVhv(pTHX_ HV *ohv)
1362 STRLEN hv_max, hv_fill;
1364 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1366 hv_max = HvMAX(ohv);
1368 if (!SvMAGICAL((SV *)ohv)) {
1369 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1371 bool shared = !!HvSHAREKEYS(ohv);
1372 HE **ents, **oents = (HE **)HvARRAY(ohv);
1374 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1377 /* In each bucket... */
1378 for (i = 0; i <= hv_max; i++) {
1379 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1386 /* Copy the linked list of entries. */
1387 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1388 U32 hash = HeHASH(oent);
1389 char *key = HeKEY(oent);
1390 STRLEN len = HeKLEN(oent);
1391 int flags = HeKFLAGS(oent);
1394 HeVAL(ent) = newSVsv(HeVAL(oent));
1396 = shared ? share_hek_flags(key, len, hash, flags)
1397 : save_hek_flags(key, len, hash, flags);
1408 HvFILL(hv) = hv_fill;
1409 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1413 /* Iterate over ohv, copying keys and values one at a time. */
1415 I32 riter = HvRITER(ohv);
1416 HE *eiter = HvEITER(ohv);
1418 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1419 while (hv_max && hv_max + 1 >= hv_fill * 2)
1420 hv_max = hv_max / 2;
1424 while ((entry = hv_iternext_flags(ohv, 0))) {
1425 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1426 newSVsv(HeVAL(entry)), HeHASH(entry),
1429 HvRITER(ohv) = riter;
1430 HvEITER(ohv) = eiter;
1437 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1444 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1445 PL_sub_generation++; /* may be deletion of method from stash */
1447 if (HeKLEN(entry) == HEf_SVKEY) {
1448 SvREFCNT_dec(HeKEY_sv(entry));
1449 Safefree(HeKEY_hek(entry));
1451 else if (HvSHAREKEYS(hv))
1452 unshare_hek(HeKEY_hek(entry));
1454 Safefree(HeKEY_hek(entry));
1459 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1463 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1464 PL_sub_generation++; /* may be deletion of method from stash */
1465 sv_2mortal(HeVAL(entry)); /* free between statements */
1466 if (HeKLEN(entry) == HEf_SVKEY) {
1467 sv_2mortal(HeKEY_sv(entry));
1468 Safefree(HeKEY_hek(entry));
1470 else if (HvSHAREKEYS(hv))
1471 unshare_hek(HeKEY_hek(entry));
1473 Safefree(HeKEY_hek(entry));
1478 =for apidoc hv_clear
1480 Clears a hash, making it empty.
1486 Perl_hv_clear(pTHX_ HV *hv)
1488 register XPVHV* xhv;
1492 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1494 xhv = (XPVHV*)SvANY(hv);
1496 if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
1497 /* restricted hash: convert all keys to placeholders */
1500 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1501 entry = ((HE**)xhv->xhv_array)[i];
1502 for (; entry; entry = HeNEXT(entry)) {
1503 /* not already placeholder */
1504 if (HeVAL(entry) != &PL_sv_placeholder) {
1505 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1506 SV* keysv = hv_iterkeysv(entry);
1508 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1511 SvREFCNT_dec(HeVAL(entry));
1512 HeVAL(entry) = &PL_sv_placeholder;
1513 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1521 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1522 if (xhv->xhv_array /* HvARRAY(hv) */)
1523 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1524 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1529 HvHASKFLAGS_off(hv);
1534 =for apidoc hv_clear_placeholders
1536 Clears any placeholders from a hash. If a restricted hash has any of its keys
1537 marked as readonly and the key is subsequently deleted, the key is not actually
1538 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1539 it so it will be ignored by future operations such as iterating over the hash,
1540 but will still allow the hash to have a value reaasigned to the key at some
1541 future point. This function clears any such placeholder keys from the hash.
1542 See Hash::Util::lock_keys() for an example of its use.
1548 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1551 items = (I32)HvPLACEHOLDERS(hv);
1554 I32 riter = HvRITER(hv);
1555 HE *eiter = HvEITER(hv);
1557 /* This may look suboptimal with the items *after* the iternext, but
1558 it's quite deliberate. We only get here with items==0 if we've
1559 just deleted the last placeholder in the hash. If we've just done
1560 that then it means that the hash is in lazy delete mode, and the
1561 HE is now only referenced in our iterator. If we just quit the loop
1562 and discarded our iterator then the HE leaks. So we do the && the
1563 other way to ensure iternext is called just one more time, which
1564 has the side effect of triggering the lazy delete. */
1565 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1567 SV *val = hv_iterval(hv, entry);
1569 if (val == &PL_sv_placeholder) {
1571 /* It seems that I have to go back in the front of the hash
1572 API to delete a hash, even though I have a HE structure
1573 pointing to the very entry I want to delete, and could hold
1574 onto the previous HE that points to it. And it's easier to
1575 go in with SVs as I can then specify the precomputed hash,
1576 and don't have fun and games with utf8 keys. */
1577 SV *key = hv_iterkeysv(entry);
1579 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
1583 HvRITER(hv) = riter;
1584 HvEITER(hv) = eiter;
1589 S_hfreeentries(pTHX_ HV *hv)
1591 register HE **array;
1593 register HE *oentry = Null(HE*);
1604 array = HvARRAY(hv);
1605 /* make everyone else think the array is empty, so that the destructors
1606 * called for freed entries can't recusively mess with us */
1607 HvARRAY(hv) = Null(HE**);
1609 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1615 entry = HeNEXT(entry);
1616 hv_free_ent(hv, oentry);
1621 entry = array[riter];
1624 HvARRAY(hv) = array;
1625 (void)hv_iterinit(hv);
1629 =for apidoc hv_undef
1637 Perl_hv_undef(pTHX_ HV *hv)
1639 register XPVHV* xhv;
1642 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1643 xhv = (XPVHV*)SvANY(hv);
1645 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1648 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1649 Safefree(HvNAME(hv));
1652 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1653 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1654 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1661 =for apidoc hv_iterinit
1663 Prepares a starting point to traverse a hash table. Returns the number of
1664 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1665 currently only meaningful for hashes without tie magic.
1667 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1668 hash buckets that happen to be in use. If you still need that esoteric
1669 value, you can get it through the macro C<HvFILL(tb)>.
1676 Perl_hv_iterinit(pTHX_ HV *hv)
1678 register XPVHV* xhv;
1682 Perl_croak(aTHX_ "Bad hash");
1683 xhv = (XPVHV*)SvANY(hv);
1684 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1685 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1687 hv_free_ent(hv, entry);
1689 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1690 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1691 /* used to be xhv->xhv_fill before 5.004_65 */
1692 return XHvTOTALKEYS(xhv);
1695 =for apidoc hv_iternext
1697 Returns entries from a hash iterator. See C<hv_iterinit>.
1699 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1700 iterator currently points to, without losing your place or invalidating your
1701 iterator. Note that in this case the current entry is deleted from the hash
1702 with your iterator holding the last reference to it. Your iterator is flagged
1703 to free the entry on the next call to C<hv_iternext>, so you must not discard
1704 your iterator immediately else the entry will leak - call C<hv_iternext> to
1705 trigger the resource deallocation.
1711 Perl_hv_iternext(pTHX_ HV *hv)
1713 return hv_iternext_flags(hv, 0);
1717 =for apidoc hv_iternext_flags
1719 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1720 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1721 set the placeholders keys (for restricted hashes) will be returned in addition
1722 to normal keys. By default placeholders are automatically skipped over.
1723 Currently a placeholder is implemented with a value that is
1724 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1725 restricted hashes may change, and the implementation currently is
1726 insufficiently abstracted for any change to be tidy.
1732 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1734 register XPVHV* xhv;
1740 Perl_croak(aTHX_ "Bad hash");
1741 xhv = (XPVHV*)SvANY(hv);
1742 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1744 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1745 SV *key = sv_newmortal();
1747 sv_setsv(key, HeSVKEY_force(entry));
1748 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1754 /* one HE per MAGICAL hash */
1755 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1757 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1759 HeKEY_hek(entry) = hek;
1760 HeKLEN(entry) = HEf_SVKEY;
1762 magic_nextpack((SV*) hv,mg,key);
1764 /* force key to stay around until next time */
1765 HeSVKEY_set(entry, SvREFCNT_inc(key));
1766 return entry; /* beware, hent_val is not set */
1769 SvREFCNT_dec(HeVAL(entry));
1770 Safefree(HeKEY_hek(entry));
1772 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1775 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1776 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1780 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1781 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1782 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1784 /* At start of hash, entry is NULL. */
1787 entry = HeNEXT(entry);
1788 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1790 * Skip past any placeholders -- don't want to include them in
1793 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1794 entry = HeNEXT(entry);
1799 /* OK. Come to the end of the current list. Grab the next one. */
1801 xhv->xhv_riter++; /* HvRITER(hv)++ */
1802 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1803 /* There is no next one. End of the hash. */
1804 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1807 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1808 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1810 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1811 /* If we have an entry, but it's a placeholder, don't count it.
1813 while (entry && HeVAL(entry) == &PL_sv_placeholder)
1814 entry = HeNEXT(entry);
1816 /* Will loop again if this linked list starts NULL
1817 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1818 or if we run through it and find only placeholders. */
1821 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1823 hv_free_ent(hv, oldentry);
1826 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1827 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1829 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1834 =for apidoc hv_iterkey
1836 Returns the key from the current position of the hash iterator. See
1843 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1845 if (HeKLEN(entry) == HEf_SVKEY) {
1847 char *p = SvPV(HeKEY_sv(entry), len);
1852 *retlen = HeKLEN(entry);
1853 return HeKEY(entry);
1857 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1859 =for apidoc hv_iterkeysv
1861 Returns the key as an C<SV*> from the current position of the hash
1862 iterator. The return value will always be a mortal copy of the key. Also
1869 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1871 if (HeKLEN(entry) != HEf_SVKEY) {
1872 HEK *hek = HeKEY_hek(entry);
1873 int flags = HEK_FLAGS(hek);
1876 if (flags & HVhek_WASUTF8) {
1878 Andreas would like keys he put in as utf8 to come back as utf8
1880 STRLEN utf8_len = HEK_LEN(hek);
1881 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1883 sv = newSVpvn ((char*)as_utf8, utf8_len);
1885 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1886 } else if (flags & HVhek_REHASH) {
1887 /* We don't have a pointer to the hv, so we have to replicate the
1888 flag into every HEK. This hv is using custom a hasing
1889 algorithm. Hence we can't return a shared string scalar, as
1890 that would contain the (wrong) hash value, and might get passed
1891 into an hv routine with a regular hash */
1893 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
1897 sv = newSVpvn_share(HEK_KEY(hek),
1898 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1901 return sv_2mortal(sv);
1903 return sv_mortalcopy(HeKEY_sv(entry));
1907 =for apidoc hv_iterval
1909 Returns the value from the current position of the hash iterator. See
1916 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1918 if (SvRMAGICAL(hv)) {
1919 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1920 SV* sv = sv_newmortal();
1921 if (HeKLEN(entry) == HEf_SVKEY)
1922 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1923 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1927 return HeVAL(entry);
1931 =for apidoc hv_iternextsv
1933 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1940 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1943 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
1945 *key = hv_iterkey(he, retlen);
1946 return hv_iterval(hv, he);
1950 =for apidoc hv_magic
1952 Adds magic to a hash. See C<sv_magic>.
1958 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1960 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1963 #if 0 /* use the macro from hv.h instead */
1966 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1968 return HEK_KEY(share_hek(sv, len, hash));
1973 /* possibly free a shared string if no one has access to it
1974 * len and hash must both be valid for str.
1977 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1979 unshare_hek_or_pvn (NULL, str, len, hash);
1984 Perl_unshare_hek(pTHX_ HEK *hek)
1986 unshare_hek_or_pvn(hek, NULL, 0, 0);
1989 /* possibly free a shared string if no one has access to it
1990 hek if non-NULL takes priority over the other 3, else str, len and hash
1991 are used. If so, len and hash must both be valid for str.
1994 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
1996 register XPVHV* xhv;
1998 register HE **oentry;
2001 bool is_utf8 = FALSE;
2003 const char *save = str;
2006 hash = HEK_HASH(hek);
2007 } else if (len < 0) {
2008 STRLEN tmplen = -len;
2010 /* See the note in hv_fetch(). --jhi */
2011 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2014 k_flags = HVhek_UTF8;
2016 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2019 /* what follows is the moral equivalent of:
2020 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2021 if (--*Svp == Nullsv)
2022 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2024 xhv = (XPVHV*)SvANY(PL_strtab);
2025 /* assert(xhv_array != 0) */
2027 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2028 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2030 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2031 if (HeKEY_hek(entry) != hek)
2037 int flags_masked = k_flags & HVhek_MASK;
2038 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2039 if (HeHASH(entry) != hash) /* strings can't be equal */
2041 if (HeKLEN(entry) != len)
2043 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2045 if (HeKFLAGS(entry) != flags_masked)
2053 if (--HeVAL(entry) == Nullsv) {
2054 *oentry = HeNEXT(entry);
2056 xhv->xhv_fill--; /* HvFILL(hv)-- */
2057 Safefree(HeKEY_hek(entry));
2059 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2063 UNLOCK_STRTAB_MUTEX;
2064 if (!found && ckWARN_d(WARN_INTERNAL))
2065 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2066 "Attempt to free non-existent shared string '%s'%s",
2067 hek ? HEK_KEY(hek) : str,
2068 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2069 if (k_flags & HVhek_FREEKEY)
2073 /* get a (constant) string ptr from the global string table
2074 * string will get added if it is not already there.
2075 * len and hash must both be valid for str.
2078 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2080 bool is_utf8 = FALSE;
2082 const char *save = str;
2085 STRLEN tmplen = -len;
2087 /* See the note in hv_fetch(). --jhi */
2088 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2090 /* If we were able to downgrade here, then than means that we were passed
2091 in a key which only had chars 0-255, but was utf8 encoded. */
2094 /* If we found we were able to downgrade the string to bytes, then
2095 we should flag that it needs upgrading on keys or each. Also flag
2096 that we need share_hek_flags to free the string. */
2098 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2101 return share_hek_flags (str, len, hash, flags);
2105 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2107 register XPVHV* xhv;
2109 register HE **oentry;
2112 int flags_masked = flags & HVhek_MASK;
2114 /* what follows is the moral equivalent of:
2116 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2117 hv_store(PL_strtab, str, len, Nullsv, hash);
2119 Can't rehash the shared string table, so not sure if it's worth
2120 counting the number of entries in the linked list
2122 xhv = (XPVHV*)SvANY(PL_strtab);
2123 /* assert(xhv_array != 0) */
2125 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2126 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2127 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2128 if (HeHASH(entry) != hash) /* strings can't be equal */
2130 if (HeKLEN(entry) != len)
2132 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2134 if (HeKFLAGS(entry) != flags_masked)
2141 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2142 HeVAL(entry) = Nullsv;
2143 HeNEXT(entry) = *oentry;
2145 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2146 if (i) { /* initial entry? */
2147 xhv->xhv_fill++; /* HvFILL(hv)++ */
2148 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2153 ++HeVAL(entry); /* use value slot as REFCNT */
2154 UNLOCK_STRTAB_MUTEX;
2156 if (flags & HVhek_FREEKEY)
2159 return HeKEY_hek(entry);
2164 =for apidoc hv_assert
2166 Check that a hash is in an internally consistent state.
2172 Perl_hv_assert(pTHX_ HV *hv)
2176 int placeholders = 0;
2179 I32 riter = HvRITER(hv);
2180 HE *eiter = HvEITER(hv);
2182 (void)hv_iterinit(hv);
2184 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2185 /* sanity check the values */
2186 if (HeVAL(entry) == &PL_sv_placeholder) {
2191 /* sanity check the keys */
2192 if (HeSVKEY(entry)) {
2193 /* Don't know what to check on SV keys. */
2194 } else if (HeKUTF8(entry)) {
2196 if (HeKWASUTF8(entry)) {
2197 PerlIO_printf(Perl_debug_log,
2198 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2199 (int) HeKLEN(entry), HeKEY(entry));
2202 } else if (HeKWASUTF8(entry)) {
2206 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2207 if (HvUSEDKEYS(hv) != real) {
2208 PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2209 (int) real, (int) HvUSEDKEYS(hv));
2212 if (HvPLACEHOLDERS(hv) != placeholders) {
2213 PerlIO_printf(Perl_debug_log,
2214 "Count %d placeholder(s), but hash reports %d\n",
2215 (int) placeholders, (int) HvPLACEHOLDERS(hv));
2219 if (withflags && ! HvHASKFLAGS(hv)) {
2220 PerlIO_printf(Perl_debug_log,
2221 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2228 HvRITER(hv) = riter; /* Restore hash iterator state */
2229 HvEITER(hv) = eiter;