3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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
18 A HV structure represents a Perl hash. It consists mainly of an array
19 of pointers, each of which points to a linked list of HE structures. The
20 array is indexed by the hash function of the key, so each linked list
21 represents all the hash entries with the same hash value. Each HE contains
22 a pointer to the actual value, plus a pointer to a HEK structure which
23 holds the key and hash value.
31 #define PERL_HASH_INTERNAL_ACCESS
34 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
41 New(54, he, PERL_ARENA_SIZE/sizeof(HE), HE);
42 HeNEXT(he) = PL_he_arenaroot;
45 heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
48 HeNEXT(he) = (HE*)(he + 1);
62 PL_he_root = HeNEXT(he);
71 HeNEXT(p) = (HE*)PL_he_root;
78 #define new_HE() (HE*)safemalloc(sizeof(HE))
79 #define del_HE(p) safefree((char*)p)
83 #define new_HE() new_he()
84 #define del_HE(p) del_he(p)
89 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
91 const int flags_masked = flags & HVhek_MASK;
95 New(54, k, HEK_BASESIZE + len + 2, char);
97 Copy(str, HEK_KEY(hek), len, char);
98 HEK_KEY(hek)[len] = 0;
100 HEK_HASH(hek) = hash;
101 HEK_FLAGS(hek) = (unsigned char)flags_masked;
103 if (flags & HVhek_FREEKEY)
108 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
112 Perl_free_tied_hv_pool(pTHX)
115 HE *he = PL_hv_fetch_ent_mh;
117 Safefree(HeKEY_hek(he));
122 PL_hv_fetch_ent_mh = Nullhe;
125 #if defined(USE_ITHREADS)
127 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
129 HE *shared = (HE*)ptr_table_fetch(PL_shared_hek_table, source);
132 /* We already shared this hash key. */
136 shared = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
137 HEK_HASH(source), HEK_FLAGS(source));
138 ptr_table_store(PL_shared_hek_table, source, shared);
140 return HeKEY_hek(shared);
144 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
150 /* look for it in the table first */
151 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
155 /* create anew and remember what it is */
157 ptr_table_store(PL_ptr_table, e, ret);
159 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
160 if (HeKLEN(e) == HEf_SVKEY) {
162 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
163 HeKEY_hek(ret) = (HEK*)k;
164 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
167 /* This is hek_dup inlined, which seems to be important for speed
169 HEK *source = HeKEY_hek(e);
170 HE *shared = (HE*)ptr_table_fetch(PL_shared_hek_table, source);
173 /* We already shared this hash key. */
177 shared = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
178 HEK_HASH(source), HEK_FLAGS(source));
179 ptr_table_store(PL_shared_hek_table, source, shared);
181 HeKEY_hek(ret) = HeKEY_hek(shared);
184 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
186 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
189 #endif /* USE_ITHREADS */
192 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
195 SV *sv = sv_newmortal();
196 if (!(flags & HVhek_FREEKEY)) {
197 sv_setpvn(sv, key, klen);
200 /* Need to free saved eventually assign to mortal SV */
201 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
202 sv_usepvn(sv, (char *) key, klen);
204 if (flags & HVhek_UTF8) {
207 Perl_croak(aTHX_ msg, sv);
210 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
213 #define HV_FETCH_ISSTORE 0x01
214 #define HV_FETCH_ISEXISTS 0x02
215 #define HV_FETCH_LVALUE 0x04
216 #define HV_FETCH_JUST_SV 0x08
221 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
222 the length of the key. The C<hash> parameter is the precomputed hash
223 value; if it is zero then Perl will compute it. The return value will be
224 NULL if the operation failed or if the value did not need to be actually
225 stored within the hash (as in the case of tied hashes). Otherwise it can
226 be dereferenced to get the original C<SV*>. Note that the caller is
227 responsible for suitably incrementing the reference count of C<val> before
228 the call, and decrementing it if the function returned NULL. Effectively
229 a successful hv_store takes ownership of one reference to C<val>. This is
230 usually what you want; a newly created SV has a reference count of one, so
231 if all your code does is create SVs then store them in a hash, hv_store
232 will own the only reference to the new SV, and your code doesn't need to do
233 anything further to tidy up. hv_store is not implemented as a call to
234 hv_store_ent, and does not create a temporary SV for the key, so if your
235 key data is not already in SV form then use hv_store in preference to
238 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
239 information on how to use this function on tied hashes.
245 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
258 hek = hv_fetch_common (hv, NULL, key, klen, flags,
259 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
260 return hek ? &HeVAL(hek) : NULL;
264 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
265 register U32 hash, int flags)
267 HE *hek = hv_fetch_common (hv, NULL, key, klen, flags,
268 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
269 return hek ? &HeVAL(hek) : NULL;
273 =for apidoc hv_store_ent
275 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
276 parameter is the precomputed hash value; if it is zero then Perl will
277 compute it. The return value is the new hash entry so created. It will be
278 NULL if the operation failed or if the value did not need to be actually
279 stored within the hash (as in the case of tied hashes). Otherwise the
280 contents of the return value can be accessed using the C<He?> macros
281 described here. Note that the caller is responsible for suitably
282 incrementing the reference count of C<val> before the call, and
283 decrementing it if the function returned NULL. Effectively a successful
284 hv_store_ent takes ownership of one reference to C<val>. This is
285 usually what you want; a newly created SV has a reference count of one, so
286 if all your code does is create SVs then store them in a hash, hv_store
287 will own the only reference to the new SV, and your code doesn't need to do
288 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
289 unlike C<val> it does not take ownership of it, so maintaining the correct
290 reference count on C<key> is entirely the caller's responsibility. hv_store
291 is not implemented as a call to hv_store_ent, and does not create a temporary
292 SV for the key, so if your key data is not already in SV form then use
293 hv_store in preference to hv_store_ent.
295 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
296 information on how to use this function on tied hashes.
302 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
304 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
308 =for apidoc hv_exists
310 Returns a boolean indicating whether the specified hash key exists. The
311 C<klen> is the length of the key.
317 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
329 return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
336 Returns the SV which corresponds to the specified key in the hash. The
337 C<klen> is the length of the key. If C<lval> is set then the fetch will be
338 part of a store. Check that the return value is non-null before
339 dereferencing it to an C<SV*>.
341 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
342 information on how to use this function on tied hashes.
348 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
361 hek = hv_fetch_common (hv, NULL, key, klen, flags,
362 HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0),
364 return hek ? &HeVAL(hek) : NULL;
368 =for apidoc hv_exists_ent
370 Returns a boolean indicating whether the specified hash key exists. C<hash>
371 can be a valid precomputed hash value, or 0 to ask for it to be
378 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
380 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
384 /* returns an HE * structure with the all fields set */
385 /* note that hent_val will be a mortal sv for MAGICAL hashes */
387 =for apidoc hv_fetch_ent
389 Returns the hash entry which corresponds to the specified key in the hash.
390 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
391 if you want the function to compute it. IF C<lval> is set then the fetch
392 will be part of a store. Make sure the return value is non-null before
393 accessing it. The return value when C<tb> is a tied hash is a pointer to a
394 static location, so be sure to make a copy of the structure if you need to
397 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
398 information on how to use this function on tied hashes.
404 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
406 return hv_fetch_common(hv, keysv, NULL, 0, 0,
407 (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
411 S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
412 int flags, int action, SV *val, register U32 hash)
427 if (flags & HVhek_FREEKEY)
429 key = SvPV(keysv, klen);
431 is_utf8 = (SvUTF8(keysv) != 0);
433 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
436 xhv = (XPVHV*)SvANY(hv);
438 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
440 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
443 /* XXX should be able to skimp on the HE/HEK here when
444 HV_FETCH_JUST_SV is true. */
447 keysv = newSVpvn(key, klen);
452 keysv = newSVsv(keysv);
454 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
456 /* grab a fake HE/HEK pair from the pool or make a new one */
457 entry = PL_hv_fetch_ent_mh;
459 PL_hv_fetch_ent_mh = HeNEXT(entry);
463 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
464 HeKEY_hek(entry) = (HEK*)k;
466 HeNEXT(entry) = Nullhe;
467 HeSVKEY_set(entry, keysv);
469 sv_upgrade(sv, SVt_PVLV);
471 /* so we can free entry when freeing sv */
472 LvTARG(sv) = (SV*)entry;
474 /* XXX remove at some point? */
475 if (flags & HVhek_FREEKEY)
480 #ifdef ENV_IS_CASELESS
481 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
483 for (i = 0; i < klen; ++i)
484 if (isLOWER(key[i])) {
485 /* Would be nice if we had a routine to do the
486 copy and upercase in a single pass through. */
487 const char *nkey = strupr(savepvn(key,klen));
488 /* Note that this fetch is for nkey (the uppercased
489 key) whereas the store is for key (the original) */
490 entry = hv_fetch_common(hv, Nullsv, nkey, klen,
491 HVhek_FREEKEY, /* free nkey */
492 0 /* non-LVAL fetch */,
493 Nullsv /* no value */,
494 0 /* compute hash */);
495 if (!entry && (action & HV_FETCH_LVALUE)) {
496 /* This call will free key if necessary.
497 Do it this way to encourage compiler to tail
499 entry = hv_fetch_common(hv, keysv, key, klen,
500 flags, HV_FETCH_ISSTORE,
503 if (flags & HVhek_FREEKEY)
511 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
512 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
514 /* I don't understand why hv_exists_ent has svret and sv,
515 whereas hv_exists only had one. */
516 svret = sv_newmortal();
519 if (keysv || is_utf8) {
521 keysv = newSVpvn(key, klen);
524 keysv = newSVsv(keysv);
526 mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
528 mg_copy((SV*)hv, sv, key, klen);
530 if (flags & HVhek_FREEKEY)
532 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
533 /* This cast somewhat evil, but I'm merely using NULL/
534 not NULL to return the boolean exists.
535 And I know hv is not NULL. */
536 return SvTRUE(svret) ? (HE *)hv : NULL;
538 #ifdef ENV_IS_CASELESS
539 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
540 /* XXX This code isn't UTF8 clean. */
541 const char *keysave = key;
542 /* Will need to free this, so set FREEKEY flag. */
543 key = savepvn(key,klen);
544 key = (const char*)strupr((char*)key);
549 if (flags & HVhek_FREEKEY) {
552 flags |= HVhek_FREEKEY;
556 else if (action & HV_FETCH_ISSTORE) {
559 hv_magic_check (hv, &needs_copy, &needs_store);
561 const bool save_taint = PL_tainted;
562 if (keysv || is_utf8) {
564 keysv = newSVpvn(key, klen);
568 PL_tainted = SvTAINTED(keysv);
569 keysv = sv_2mortal(newSVsv(keysv));
570 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
572 mg_copy((SV*)hv, val, key, klen);
575 TAINT_IF(save_taint);
576 if (!HvARRAY(hv) && !needs_store) {
577 if (flags & HVhek_FREEKEY)
581 #ifdef ENV_IS_CASELESS
582 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
583 /* XXX This code isn't UTF8 clean. */
584 const char *keysave = key;
585 /* Will need to free this, so set FREEKEY flag. */
586 key = savepvn(key,klen);
587 key = (const char*)strupr((char*)key);
592 if (flags & HVhek_FREEKEY) {
595 flags |= HVhek_FREEKEY;
603 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
604 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
605 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
608 Newz(503, HvARRAY(hv),
609 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
611 #ifdef DYNAMIC_ENV_FETCH
612 else if (action & HV_FETCH_ISEXISTS) {
613 /* for an %ENV exists, if we do an insert it's by a recursive
614 store call, so avoid creating HvARRAY(hv) right now. */
618 /* XXX remove at some point? */
619 if (flags & HVhek_FREEKEY)
627 const char *keysave = key;
628 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
632 flags &= ~HVhek_UTF8;
633 if (key != keysave) {
634 if (flags & HVhek_FREEKEY)
636 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
641 PERL_HASH_INTERNAL(hash, key, klen);
642 /* We don't have a pointer to the hv, so we have to replicate the
643 flag into every HEK, so that hv_iterkeysv can see it. */
644 /* And yes, you do need this even though you are not "storing" because
645 you can flip the flags below if doing an lval lookup. (And that
646 was put in to give the semantics Andreas was expecting.) */
647 flags |= HVhek_REHASH;
649 if (keysv && (SvIsCOW_shared_hash(keysv))) {
652 PERL_HASH(hash, key, klen);
656 masked_flags = (flags & HVhek_MASK);
659 #ifdef DYNAMIC_ENV_FETCH
660 if (!HvARRAY(hv)) entry = Null(HE*);
664 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
666 for (; entry; ++n_links, entry = HeNEXT(entry)) {
667 if (HeHASH(entry) != hash) /* strings can't be equal */
669 if (HeKLEN(entry) != (I32)klen)
671 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
673 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
676 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
677 if (HeKFLAGS(entry) != masked_flags) {
678 /* We match if HVhek_UTF8 bit in our flags and hash key's
679 match. But if entry was set previously with HVhek_WASUTF8
680 and key now doesn't (or vice versa) then we should change
681 the key's flag, as this is assignment. */
682 if (HvSHAREKEYS(hv)) {
683 /* Need to swap the key we have for a key with the flags we
684 need. As keys are shared we can't just write to the
685 flag, so we share the new one, unshare the old one. */
686 HEK *new_hek = HeKEY_hek(share_hek_flags(key, klen, hash,
688 unshare_hek (HeKEY_hek(entry));
689 HeKEY_hek(entry) = new_hek;
692 HeKFLAGS(entry) = masked_flags;
693 if (masked_flags & HVhek_ENABLEHVKFLAGS)
696 if (HeVAL(entry) == &PL_sv_placeholder) {
697 /* yes, can store into placeholder slot */
698 if (action & HV_FETCH_LVALUE) {
700 /* This preserves behaviour with the old hv_fetch
701 implementation which at this point would bail out
702 with a break; (at "if we find a placeholder, we
703 pretend we haven't found anything")
705 That break mean that if a placeholder were found, it
706 caused a call into hv_store, which in turn would
707 check magic, and if there is no magic end up pretty
708 much back at this point (in hv_store's code). */
711 /* LVAL fetch which actaully needs a store. */
713 HvPLACEHOLDERS(hv)--;
716 if (val != &PL_sv_placeholder)
717 HvPLACEHOLDERS(hv)--;
720 } else if (action & HV_FETCH_ISSTORE) {
721 SvREFCNT_dec(HeVAL(entry));
724 } else if (HeVAL(entry) == &PL_sv_placeholder) {
725 /* if we find a placeholder, we pretend we haven't found
729 if (flags & HVhek_FREEKEY)
733 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
734 if (!(action & HV_FETCH_ISSTORE)
735 && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
737 char *env = PerlEnv_ENVgetenv_len(key,&len);
739 sv = newSVpvn(env,len);
741 return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
747 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
748 S_hv_notallowed(aTHX_ flags, key, klen,
749 "Attempt to access disallowed key '%"SVf"' in"
750 " a restricted hash");
752 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
753 /* Not doing some form of store, so return failure. */
754 if (flags & HVhek_FREEKEY)
758 if (action & HV_FETCH_LVALUE) {
761 /* At this point the old hv_fetch code would call to hv_store,
762 which in turn might do some tied magic. So we need to make that
763 magic check happen. */
764 /* gonna assign to this, so it better be there */
765 return hv_fetch_common(hv, keysv, key, klen, flags,
766 HV_FETCH_ISSTORE, val, hash);
767 /* XXX Surely that could leak if the fetch-was-store fails?
768 Just like the hv_fetch. */
772 /* Welcome to hv_store... */
775 /* Not sure if we can get here. I think the only case of oentry being
776 NULL is for %ENV with dynamic env fetch. But that should disappear
777 with magic in the previous code. */
778 Newz(503, HvARRAY(hv),
779 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
783 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
786 /* share_hek_flags will do the free for us. This might be considered
789 HeKEY_hek(entry) = HeKEY_hek(share_hek_flags(key, klen, hash, flags));
790 else /* gotta do the real thing */
791 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
793 HeNEXT(entry) = *oentry;
796 if (val == &PL_sv_placeholder)
797 HvPLACEHOLDERS(hv)++;
798 if (masked_flags & HVhek_ENABLEHVKFLAGS)
801 xhv->xhv_keys++; /* HvKEYS(hv)++ */
802 if (!n_links) { /* initial entry? */
803 xhv->xhv_fill++; /* HvFILL(hv)++ */
804 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
805 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
806 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
807 splits on a rehashed hash, as we're not going to split it again,
808 and if someone is lucky (evil) enough to get all the keys in one
809 list they could exhaust our memory as we repeatedly double the
810 number of buckets on every entry. Linear search feels a less worse
819 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
821 const MAGIC *mg = SvMAGIC(hv);
825 if (isUPPER(mg->mg_type)) {
827 switch (mg->mg_type) {
828 case PERL_MAGIC_tied:
830 *needs_store = FALSE;
833 mg = mg->mg_moremagic;
838 =for apidoc hv_scalar
840 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
846 Perl_hv_scalar(pTHX_ HV *hv)
851 if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) {
852 sv = magic_scalarpack(hv, mg);
858 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
859 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
867 =for apidoc hv_delete
869 Deletes a key/value pair in the hash. The value SV is removed from the
870 hash and returned to the caller. The C<klen> is the length of the key.
871 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
878 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
885 k_flags |= HVhek_UTF8;
889 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
893 =for apidoc hv_delete_ent
895 Deletes a key/value pair in the hash. The value SV is removed from the
896 hash and returned to the caller. The C<flags> value will normally be zero;
897 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
898 precomputed hash value, or 0 to ask for it to be computed.
904 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
906 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
910 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
911 int k_flags, I32 d_flags, U32 hash)
917 register HE **oentry;
926 if (k_flags & HVhek_FREEKEY)
928 key = SvPV(keysv, klen);
930 is_utf8 = (SvUTF8(keysv) != 0);
932 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
935 if (SvRMAGICAL(hv)) {
938 hv_magic_check (hv, &needs_copy, &needs_store);
941 entry = hv_fetch_common(hv, keysv, key, klen,
942 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
944 sv = entry ? HeVAL(entry) : NULL;
950 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
951 /* No longer an element */
952 sv_unmagic(sv, PERL_MAGIC_tiedelem);
955 return Nullsv; /* element cannot be deleted */
957 #ifdef ENV_IS_CASELESS
958 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
959 /* XXX This code isn't UTF8 clean. */
960 keysv = sv_2mortal(newSVpvn(key,klen));
961 if (k_flags & HVhek_FREEKEY) {
964 key = strupr(SvPVX(keysv));
973 xhv = (XPVHV*)SvANY(hv);
978 const char *keysave = key;
979 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
982 k_flags |= HVhek_UTF8;
984 k_flags &= ~HVhek_UTF8;
985 if (key != keysave) {
986 if (k_flags & HVhek_FREEKEY) {
987 /* This shouldn't happen if our caller does what we expect,
988 but strictly the API allows it. */
991 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
993 HvHASKFLAGS_on((SV*)hv);
997 PERL_HASH_INTERNAL(hash, key, klen);
999 if (keysv && (SvIsCOW_shared_hash(keysv))) {
1000 hash = SvUVX(keysv);
1002 PERL_HASH(hash, key, klen);
1006 masked_flags = (k_flags & HVhek_MASK);
1008 oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1011 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1012 if (HeHASH(entry) != hash) /* strings can't be equal */
1014 if (HeKLEN(entry) != (I32)klen)
1016 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1018 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1021 /* if placeholder is here, it's already been deleted.... */
1022 if (HeVAL(entry) == &PL_sv_placeholder)
1024 if (k_flags & HVhek_FREEKEY)
1028 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1029 S_hv_notallowed(aTHX_ k_flags, key, klen,
1030 "Attempt to delete readonly key '%"SVf"' from"
1031 " a restricted hash");
1033 if (k_flags & HVhek_FREEKEY)
1036 if (d_flags & G_DISCARD)
1039 sv = sv_2mortal(HeVAL(entry));
1040 HeVAL(entry) = &PL_sv_placeholder;
1044 * If a restricted hash, rather than really deleting the entry, put
1045 * a placeholder there. This marks the key as being "approved", so
1046 * we can still access via not-really-existing key without raising
1049 if (SvREADONLY(hv)) {
1050 SvREFCNT_dec(HeVAL(entry));
1051 HeVAL(entry) = &PL_sv_placeholder;
1052 /* We'll be saving this slot, so the number of allocated keys
1053 * doesn't go down, but the number placeholders goes up */
1054 HvPLACEHOLDERS(hv)++;
1056 *oentry = HeNEXT(entry);
1058 xhv->xhv_fill--; /* HvFILL(hv)-- */
1059 if (xhv->xhv_aux && entry
1060 == ((struct xpvhv_aux *)xhv->xhv_aux)->xhv_eiter /* HvEITER(hv) */)
1063 hv_free_ent(hv, entry);
1064 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1065 if (xhv->xhv_keys == 0)
1066 HvHASKFLAGS_off(hv);
1070 if (SvREADONLY(hv)) {
1071 S_hv_notallowed(aTHX_ k_flags, key, klen,
1072 "Attempt to delete disallowed key '%"SVf"' from"
1073 " a restricted hash");
1076 if (k_flags & HVhek_FREEKEY)
1082 S_hsplit(pTHX_ HV *hv)
1084 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1085 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1086 register I32 newsize = oldsize * 2;
1088 char *a = (char*) HvARRAY(hv);
1090 register HE **oentry;
1091 int longest_chain = 0;
1094 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1095 hv, (int) oldsize);*/
1097 if (HvPLACEHOLDERS(hv) && !SvREADONLY(hv)) {
1098 /* Can make this clear any placeholders first for non-restricted hashes,
1099 even though Storable rebuilds restricted hashes by putting in all the
1100 placeholders (first) before turning on the readonly flag, because
1101 Storable always pre-splits the hash. */
1102 hv_clear_placeholders(hv);
1106 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1107 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1113 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1118 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1119 if (oldsize >= 64) {
1120 offer_nice_chunk(HvARRAY(hv),
1121 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1124 Safefree(HvARRAY(hv));
1128 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1129 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1130 HvARRAY(hv) = (HE**) a;
1133 for (i=0; i<oldsize; i++,aep++) {
1134 int left_length = 0;
1135 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);
1195 for (i=0; i<newsize; i++,aep++) {
1196 register HE *entry = *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);
1205 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1210 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1211 hash, HeKFLAGS(entry));
1212 unshare_hek (HeKEY_hek(entry));
1213 HeKEY_hek(entry) = new_hek;
1215 /* Not shared, so simply write the new hash in. */
1216 HeHASH(entry) = hash;
1218 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1219 HEK_REHASH_on(HeKEY_hek(entry));
1220 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1222 /* Copy oentry to the correct new chain. */
1223 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1225 xhv->xhv_fill++; /* HvFILL(hv)++ */
1226 HeNEXT(entry) = *bep;
1232 Safefree (HvARRAY(hv));
1233 HvARRAY(hv) = (HE **)a;
1237 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1239 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1240 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1241 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 = (char *) 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(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1275 if (oldsize >= 64) {
1276 offer_nice_chunk(HvARRAY(hv),
1277 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1280 Safefree(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 HvARRAY(hv) = (HE **) 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) {
1299 if ((j = (HeHASH(entry) & newsize)) != i) {
1301 *oentry = HeNEXT(entry);
1302 if (!(HeNEXT(entry) = aep[j]))
1303 xhv->xhv_fill++; /* HvFILL(hv)++ */
1308 oentry = &HeNEXT(entry);
1310 if (!*aep) /* everything moved */
1311 xhv->xhv_fill--; /* HvFILL(hv)-- */
1318 Creates a new HV. The reference count is set to 1.
1327 register XPVHV* xhv;
1329 hv = (HV*)NEWSV(502,0);
1330 sv_upgrade((SV *)hv, SVt_PVHV);
1331 xhv = (XPVHV*)SvANY(hv);
1334 #ifndef NODEFAULT_SHAREKEYS
1335 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1338 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1339 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
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 const 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 const U32 hash = HeHASH(oent);
1375 const char * const key = HeKEY(oent);
1376 const STRLEN len = HeKLEN(oent);
1377 const int flags = HeKFLAGS(oent);
1380 HeVAL(ent) = newSVsv(HeVAL(oent));
1382 = shared ? HeKEY_hek(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 const I32 riter = HvRITER_get(ohv);
1402 HE * const eiter = HvEITER_get(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_set(ohv, riter);
1416 HvEITER_set(ohv, eiter);
1423 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1430 if (val && isGV(val) && GvCVu(val) && HvNAME_get(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_get(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)
1475 register XPVHV* xhv;
1479 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1481 xhv = (XPVHV*)SvANY(hv);
1483 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1484 /* restricted hash: convert all keys to placeholders */
1486 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1487 HE *entry = (HvARRAY(hv))[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 HvPLACEHOLDERS(hv)++;
1507 HvPLACEHOLDERS_set(hv, 0);
1509 (void)memzero(HvARRAY(hv),
1510 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1515 HvHASKFLAGS_off(hv);
1519 HvEITER_set(hv, NULL);
1524 =for apidoc hv_clear_placeholders
1526 Clears any placeholders from a hash. If a restricted hash has any of its keys
1527 marked as readonly and the key is subsequently deleted, the key is not actually
1528 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1529 it so it will be ignored by future operations such as iterating over the hash,
1530 but will still allow the hash to have a value reassigned to the key at some
1531 future point. This function clears any such placeholder keys from the hash.
1532 See Hash::Util::lock_keys() for an example of its use.
1538 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1541 I32 items = (I32)HvPLACEHOLDERS(hv);
1548 /* Loop down the linked list heads */
1550 HE **oentry = &(HvARRAY(hv))[i];
1551 HE *entry = *oentry;
1556 for (; entry; entry = *oentry) {
1557 if (HeVAL(entry) == &PL_sv_placeholder) {
1558 *oentry = HeNEXT(entry);
1559 if (first && !*oentry)
1560 HvFILL(hv)--; /* This linked list is now empty. */
1561 if (HvEITER_get(hv))
1564 hv_free_ent(hv, entry);
1568 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS(hv);
1569 if (HvKEYS(hv) == 0)
1570 HvHASKFLAGS_off(hv);
1571 HvPLACEHOLDERS(hv) = 0;
1575 oentry = &HeNEXT(entry);
1580 /* You can't get here, hence assertion should always fail. */
1581 assert (items == 0);
1586 S_hfreeentries(pTHX_ HV *hv)
1588 register HE **array;
1592 struct xpvhv_aux *iter;
1601 array = HvARRAY(hv);
1602 /* make everyone else think the array is empty, so that the destructors
1603 * called for freed entries can't recusively mess with us */
1604 HvARRAY(hv) = Null(HE**);
1606 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1611 register HE *oentry = entry;
1612 entry = HeNEXT(entry);
1613 hv_free_ent(hv, oentry);
1618 entry = array[riter];
1621 HvARRAY(hv) = array;
1623 iter = ((XPVHV*) SvANY(hv))->xhv_aux;
1625 entry = iter->xhv_eiter; /* HvEITER(hv) */
1626 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1628 hv_free_ent(hv, entry);
1631 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
1633 ((XPVHV*) SvANY(hv))->xhv_aux = 0;
1638 =for apidoc hv_undef
1646 Perl_hv_undef(pTHX_ HV *hv)
1648 register XPVHV* xhv;
1652 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1653 xhv = (XPVHV*)SvANY(hv);
1655 Safefree(HvARRAY(hv));
1656 if ((name = HvNAME_get(hv))) {
1658 hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1659 Perl_hv_name_set(aTHX_ hv, 0, 0, 0);
1661 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1663 HvPLACEHOLDERS_set(hv, 0);
1670 S_hv_auxinit(pTHX) {
1671 struct xpvhv_aux *iter;
1673 New(0, iter, 1, struct xpvhv_aux);
1675 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1676 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1683 =for apidoc hv_iterinit
1685 Prepares a starting point to traverse a hash table. Returns the number of
1686 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1687 currently only meaningful for hashes without tie magic.
1689 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1690 hash buckets that happen to be in use. If you still need that esoteric
1691 value, you can get it through the macro C<HvFILL(tb)>.
1698 Perl_hv_iterinit(pTHX_ HV *hv)
1700 register XPVHV* xhv;
1702 struct xpvhv_aux *iter;
1705 Perl_croak(aTHX_ "Bad hash");
1706 xhv = (XPVHV*)SvANY(hv);
1708 iter = xhv->xhv_aux;
1710 entry = iter->xhv_eiter; /* HvEITER(hv) */
1711 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1713 hv_free_ent(hv, entry);
1715 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1716 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1718 xhv->xhv_aux = S_hv_auxinit(aTHX);
1721 /* used to be xhv->xhv_fill before 5.004_65 */
1722 return XHvTOTALKEYS(xhv);
1726 Perl_hv_riter_p(pTHX_ HV *hv) {
1727 struct xpvhv_aux *iter;
1730 Perl_croak(aTHX_ "Bad hash");
1732 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1734 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1736 return &(iter->xhv_riter);
1740 Perl_hv_eiter_p(pTHX_ HV *hv) {
1741 struct xpvhv_aux *iter;
1744 Perl_croak(aTHX_ "Bad hash");
1746 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1748 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1750 return &(iter->xhv_eiter);
1754 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1755 struct xpvhv_aux *iter;
1758 Perl_croak(aTHX_ "Bad hash");
1761 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1766 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1768 iter->xhv_riter = riter;
1772 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1773 struct xpvhv_aux *iter;
1776 Perl_croak(aTHX_ "Bad hash");
1778 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1780 /* 0 is the default so don't go malloc()ing a new structure just to
1785 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1787 iter->xhv_eiter = eiter;
1791 Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags)
1793 struct xpvhv_aux *iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1797 if (iter->xhv_name) {
1798 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
1804 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1806 PERL_HASH(hash, name, len);
1807 iter->xhv_name = name ? share_hek(name, len, hash) : 0;
1811 =for apidoc hv_iternext
1813 Returns entries from a hash iterator. See C<hv_iterinit>.
1815 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1816 iterator currently points to, without losing your place or invalidating your
1817 iterator. Note that in this case the current entry is deleted from the hash
1818 with your iterator holding the last reference to it. Your iterator is flagged
1819 to free the entry on the next call to C<hv_iternext>, so you must not discard
1820 your iterator immediately else the entry will leak - call C<hv_iternext> to
1821 trigger the resource deallocation.
1827 Perl_hv_iternext(pTHX_ HV *hv)
1829 return hv_iternext_flags(hv, 0);
1833 =for apidoc hv_iternext_flags
1835 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1836 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1837 set the placeholders keys (for restricted hashes) will be returned in addition
1838 to normal keys. By default placeholders are automatically skipped over.
1839 Currently a placeholder is implemented with a value that is
1840 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1841 restricted hashes may change, and the implementation currently is
1842 insufficiently abstracted for any change to be tidy.
1848 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1851 register XPVHV* xhv;
1855 struct xpvhv_aux *iter;
1858 Perl_croak(aTHX_ "Bad hash");
1859 xhv = (XPVHV*)SvANY(hv);
1860 iter = xhv->xhv_aux;
1863 /* Too many things (well, pp_each at least) merrily assume that you can
1864 call iv_iternext without calling hv_iterinit, so we'll have to deal
1867 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1870 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
1872 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1873 SV *key = sv_newmortal();
1875 sv_setsv(key, HeSVKEY_force(entry));
1876 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1882 /* one HE per MAGICAL hash */
1883 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1885 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1887 HeKEY_hek(entry) = hek;
1888 HeKLEN(entry) = HEf_SVKEY;
1890 magic_nextpack((SV*) hv,mg,key);
1892 /* force key to stay around until next time */
1893 HeSVKEY_set(entry, SvREFCNT_inc(key));
1894 return entry; /* beware, hent_val is not set */
1897 SvREFCNT_dec(HeVAL(entry));
1898 Safefree(HeKEY_hek(entry));
1900 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1903 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1904 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1911 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1913 HvARRAY(hv) = (HE**) darray;
1915 /* At start of hash, entry is NULL. */
1918 entry = HeNEXT(entry);
1919 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1921 * Skip past any placeholders -- don't want to include them in
1924 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1925 entry = HeNEXT(entry);
1930 /* OK. Come to the end of the current list. Grab the next one. */
1932 iter->xhv_riter++; /* HvRITER(hv)++ */
1933 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1934 /* There is no next one. End of the hash. */
1935 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1938 entry = (HvARRAY(hv))[iter->xhv_riter];
1940 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1941 /* If we have an entry, but it's a placeholder, don't count it.
1943 while (entry && HeVAL(entry) == &PL_sv_placeholder)
1944 entry = HeNEXT(entry);
1946 /* Will loop again if this linked list starts NULL
1947 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1948 or if we run through it and find only placeholders. */
1951 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1953 hv_free_ent(hv, oldentry);
1956 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1957 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1959 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
1964 =for apidoc hv_iterkey
1966 Returns the key from the current position of the hash iterator. See
1973 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1975 if (HeKLEN(entry) == HEf_SVKEY) {
1977 char *p = SvPV(HeKEY_sv(entry), len);
1982 *retlen = HeKLEN(entry);
1983 return HeKEY(entry);
1987 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1989 =for apidoc hv_iterkeysv
1991 Returns the key as an C<SV*> from the current position of the hash
1992 iterator. The return value will always be a mortal copy of the key. Also
1999 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2001 if (HeKLEN(entry) != HEf_SVKEY) {
2002 HEK *hek = HeKEY_hek(entry);
2003 const int flags = HEK_FLAGS(hek);
2006 if (flags & HVhek_WASUTF8) {
2008 Andreas would like keys he put in as utf8 to come back as utf8
2010 STRLEN utf8_len = HEK_LEN(hek);
2011 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2013 sv = newSVpvn ((char*)as_utf8, utf8_len);
2015 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2016 } else if (flags & HVhek_REHASH) {
2017 /* We don't have a pointer to the hv, so we have to replicate the
2018 flag into every HEK. This hv is using custom a hasing
2019 algorithm. Hence we can't return a shared string scalar, as
2020 that would contain the (wrong) hash value, and might get passed
2021 into an hv routine with a regular hash */
2023 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
2027 sv = newSVpvn_share(HEK_KEY(hek),
2028 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2031 return sv_2mortal(sv);
2033 return sv_mortalcopy(HeKEY_sv(entry));
2037 =for apidoc hv_iterval
2039 Returns the value from the current position of the hash iterator. See
2046 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2048 if (SvRMAGICAL(hv)) {
2049 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2050 SV* sv = sv_newmortal();
2051 if (HeKLEN(entry) == HEf_SVKEY)
2052 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2054 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2058 return HeVAL(entry);
2062 =for apidoc hv_iternextsv
2064 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2071 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2074 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2076 *key = hv_iterkey(he, retlen);
2077 return hv_iterval(hv, he);
2081 =for apidoc hv_magic
2083 Adds magic to a hash. See C<sv_magic>.
2089 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2091 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2094 #if 0 /* use the macro from hv.h instead */
2097 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2099 return HEK_KEY(share_hek(sv, len, hash));
2104 /* possibly free a shared string if no one has access to it
2105 * len and hash must both be valid for str.
2108 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2110 unshare_hek_or_pvn (NULL, str, len, hash);
2115 Perl_unshare_hek(pTHX_ HEK *hek)
2117 unshare_hek_or_pvn(hek, NULL, 0, 0);
2120 /* possibly free a shared string if no one has access to it
2121 hek if non-NULL takes priority over the other 3, else str, len and hash
2122 are used. If so, len and hash must both be valid for str.
2125 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2127 register XPVHV* xhv;
2129 register HE **oentry;
2132 bool is_utf8 = FALSE;
2134 const char *save = str;
2137 hash = HEK_HASH(hek);
2138 } else if (len < 0) {
2139 STRLEN tmplen = -len;
2141 /* See the note in hv_fetch(). --jhi */
2142 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2145 k_flags = HVhek_UTF8;
2147 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2150 /* what follows is the moral equivalent of:
2151 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2152 if (--*Svp == Nullsv)
2153 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2155 xhv = (XPVHV*)SvANY(PL_strtab);
2156 /* assert(xhv_array != 0) */
2158 oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2160 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2161 if (HeKEY_hek(entry) != hek)
2167 const int flags_masked = k_flags & HVhek_MASK;
2168 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2169 if (HeHASH(entry) != hash) /* strings can't be equal */
2171 if (HeKLEN(entry) != len)
2173 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2175 if (HeKFLAGS(entry) != flags_masked)
2183 if (--HeVAL(entry) == Nullsv) {
2184 *oentry = HeNEXT(entry);
2186 xhv->xhv_fill--; /* HvFILL(hv)-- */
2187 Safefree(HeKEY_hek(entry));
2189 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2193 UNLOCK_STRTAB_MUTEX;
2194 if (!found && ckWARN_d(WARN_INTERNAL))
2195 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2196 "Attempt to free non-existent shared string '%s'%s"
2198 hek ? HEK_KEY(hek) : str,
2199 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2200 if (k_flags & HVhek_FREEKEY)
2204 /* get a (constant) string ptr from the global string table
2205 * string will get added if it is not already there.
2206 * len and hash must both be valid for str.
2209 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2211 bool is_utf8 = FALSE;
2213 const char *save = str;
2216 STRLEN tmplen = -len;
2218 /* See the note in hv_fetch(). --jhi */
2219 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2221 /* If we were able to downgrade here, then than means that we were passed
2222 in a key which only had chars 0-255, but was utf8 encoded. */
2225 /* If we found we were able to downgrade the string to bytes, then
2226 we should flag that it needs upgrading on keys or each. Also flag
2227 that we need share_hek_flags to free the string. */
2229 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2232 return HeKEY_hek(share_hek_flags (str, len, hash, flags));
2236 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2238 register XPVHV* xhv;
2240 register HE **oentry;
2243 const int flags_masked = flags & HVhek_MASK;
2245 /* what follows is the moral equivalent of:
2247 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2248 hv_store(PL_strtab, str, len, Nullsv, hash);
2250 Can't rehash the shared string table, so not sure if it's worth
2251 counting the number of entries in the linked list
2253 xhv = (XPVHV*)SvANY(PL_strtab);
2254 /* assert(xhv_array != 0) */
2256 oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2257 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2258 if (HeHASH(entry) != hash) /* strings can't be equal */
2260 if (HeKLEN(entry) != len)
2262 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2264 if (HeKFLAGS(entry) != flags_masked)
2271 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked);
2272 HeVAL(entry) = Nullsv;
2273 HeNEXT(entry) = *oentry;
2275 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2276 if (i) { /* initial entry? */
2277 xhv->xhv_fill++; /* HvFILL(hv)++ */
2278 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2283 ++HeVAL(entry); /* use value slot as REFCNT */
2284 UNLOCK_STRTAB_MUTEX;
2286 if (flags & HVhek_FREEKEY)
2293 Perl_hv_placeholders_p(pTHX_ HV *hv)
2296 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2299 mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2302 Perl_die(aTHX_ "panic: hv_placeholders_p");
2305 return &(mg->mg_len);
2310 Perl_hv_placeholders_get(pTHX_ HV *hv)
2313 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2315 return mg ? mg->mg_len : 0;
2319 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2322 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2327 if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2328 Perl_die(aTHX_ "panic: hv_placeholders_set");
2330 /* else we don't need to add magic to record 0 placeholders. */
2334 =for apidoc hv_assert
2336 Check that a hash is in an internally consistent state.
2342 Perl_hv_assert(pTHX_ HV *hv)
2347 int placeholders = 0;
2350 const I32 riter = HvRITER_get(hv);
2351 HE *eiter = HvEITER_get(hv);
2353 (void)hv_iterinit(hv);
2355 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2356 /* sanity check the values */
2357 if (HeVAL(entry) == &PL_sv_placeholder) {
2362 /* sanity check the keys */
2363 if (HeSVKEY(entry)) {
2364 /* Don't know what to check on SV keys. */
2365 } else if (HeKUTF8(entry)) {
2367 if (HeKWASUTF8(entry)) {
2368 PerlIO_printf(Perl_debug_log,
2369 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2370 (int) HeKLEN(entry), HeKEY(entry));
2373 } else if (HeKWASUTF8(entry)) {
2377 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2378 if (HvUSEDKEYS(hv) != real) {
2379 PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2380 (int) real, (int) HvUSEDKEYS(hv));
2383 if (HvPLACEHOLDERS(hv) != placeholders) {
2384 PerlIO_printf(Perl_debug_log,
2385 "Count %d placeholder(s), but hash reports %d\n",
2386 (int) placeholders, (int) HvPLACEHOLDERS(hv));
2390 if (withflags && ! HvHASKFLAGS(hv)) {
2391 PerlIO_printf(Perl_debug_log,
2392 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2399 HvRITER_set(hv, riter); /* Restore hash iterator state */
2400 HvEITER_set(hv, eiter);
2405 * c-indentation-style: bsd
2407 * indent-tabs-mode: t
2410 * ex: set ts=8 sts=4 sw=4 noet: