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;
831 return; /* We've set all there is to set. */
834 mg = mg->mg_moremagic;
839 =for apidoc hv_scalar
841 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
847 Perl_hv_scalar(pTHX_ HV *hv)
852 if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) {
853 sv = magic_scalarpack(hv, mg);
859 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
860 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
868 =for apidoc hv_delete
870 Deletes a key/value pair in the hash. The value SV is removed from the
871 hash and returned to the caller. The C<klen> is the length of the key.
872 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
879 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
886 k_flags |= HVhek_UTF8;
890 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
894 =for apidoc hv_delete_ent
896 Deletes a key/value pair in the hash. The value SV is removed from the
897 hash and returned to the caller. The C<flags> value will normally be zero;
898 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
899 precomputed hash value, or 0 to ask for it to be computed.
905 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
907 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
911 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
912 int k_flags, I32 d_flags, U32 hash)
917 register HE **oentry;
918 HE *const *first_entry;
927 if (k_flags & HVhek_FREEKEY)
929 key = SvPV(keysv, klen);
931 is_utf8 = (SvUTF8(keysv) != 0);
933 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
936 if (SvRMAGICAL(hv)) {
939 hv_magic_check (hv, &needs_copy, &needs_store);
942 entry = hv_fetch_common(hv, keysv, key, klen,
943 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
945 sv = entry ? HeVAL(entry) : NULL;
951 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
952 /* No longer an element */
953 sv_unmagic(sv, PERL_MAGIC_tiedelem);
956 return Nullsv; /* element cannot be deleted */
958 #ifdef ENV_IS_CASELESS
959 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
960 /* XXX This code isn't UTF8 clean. */
961 keysv = sv_2mortal(newSVpvn(key,klen));
962 if (k_flags & HVhek_FREEKEY) {
965 key = strupr(SvPVX(keysv));
974 xhv = (XPVHV*)SvANY(hv);
979 const char *keysave = key;
980 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
983 k_flags |= HVhek_UTF8;
985 k_flags &= ~HVhek_UTF8;
986 if (key != keysave) {
987 if (k_flags & HVhek_FREEKEY) {
988 /* This shouldn't happen if our caller does what we expect,
989 but strictly the API allows it. */
992 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
994 HvHASKFLAGS_on((SV*)hv);
998 PERL_HASH_INTERNAL(hash, key, klen);
1000 if (keysv && (SvIsCOW_shared_hash(keysv))) {
1001 hash = SvUVX(keysv);
1003 PERL_HASH(hash, key, klen);
1007 masked_flags = (k_flags & HVhek_MASK);
1009 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1011 for (; entry; 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)-- */
1060 if (xhv->xhv_aux && entry
1061 == ((struct xpvhv_aux *)xhv->xhv_aux)->xhv_eiter /* HvEITER(hv) */)
1064 hv_free_ent(hv, entry);
1065 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1066 if (xhv->xhv_keys == 0)
1067 HvHASKFLAGS_off(hv);
1071 if (SvREADONLY(hv)) {
1072 S_hv_notallowed(aTHX_ k_flags, key, klen,
1073 "Attempt to delete disallowed key '%"SVf"' from"
1074 " a restricted hash");
1077 if (k_flags & HVhek_FREEKEY)
1083 S_hsplit(pTHX_ HV *hv)
1085 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1086 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1087 register I32 newsize = oldsize * 2;
1089 char *a = (char*) HvARRAY(hv);
1091 register HE **oentry;
1092 int longest_chain = 0;
1095 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1096 hv, (int) oldsize);*/
1098 if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1099 /* Can make this clear any placeholders first for non-restricted hashes,
1100 even though Storable rebuilds restricted hashes by putting in all the
1101 placeholders (first) before turning on the readonly flag, because
1102 Storable always pre-splits the hash. */
1103 hv_clear_placeholders(hv);
1107 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1108 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1114 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1119 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1120 if (oldsize >= 64) {
1121 offer_nice_chunk(HvARRAY(hv),
1122 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1125 Safefree(HvARRAY(hv));
1129 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1130 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1131 HvARRAY(hv) = (HE**) a;
1134 for (i=0; i<oldsize; i++,aep++) {
1135 int left_length = 0;
1136 int right_length = 0;
1140 if (!*aep) /* non-existent */
1143 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1144 if ((HeHASH(entry) & newsize) != (U32)i) {
1145 *oentry = HeNEXT(entry);
1146 HeNEXT(entry) = *bep;
1148 xhv->xhv_fill++; /* HvFILL(hv)++ */
1154 oentry = &HeNEXT(entry);
1158 if (!*aep) /* everything moved */
1159 xhv->xhv_fill--; /* HvFILL(hv)-- */
1160 /* I think we don't actually need to keep track of the longest length,
1161 merely flag if anything is too long. But for the moment while
1162 developing this code I'll track it. */
1163 if (left_length > longest_chain)
1164 longest_chain = left_length;
1165 if (right_length > longest_chain)
1166 longest_chain = right_length;
1170 /* Pick your policy for "hashing isn't working" here: */
1171 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
1176 if (hv == PL_strtab) {
1177 /* Urg. Someone is doing something nasty to the string table.
1182 /* Awooga. Awooga. Pathological data. */
1183 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1184 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1187 Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1188 was_shared = HvSHAREKEYS(hv);
1191 HvSHAREKEYS_off(hv);
1196 for (i=0; i<newsize; i++,aep++) {
1197 register HE *entry = *aep;
1199 /* We're going to trash this HE's next pointer when we chain it
1200 into the new hash below, so store where we go next. */
1201 HE *next = HeNEXT(entry);
1206 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1211 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1212 hash, HeKFLAGS(entry));
1213 unshare_hek (HeKEY_hek(entry));
1214 HeKEY_hek(entry) = new_hek;
1216 /* Not shared, so simply write the new hash in. */
1217 HeHASH(entry) = hash;
1219 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1220 HEK_REHASH_on(HeKEY_hek(entry));
1221 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1223 /* Copy oentry to the correct new chain. */
1224 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1226 xhv->xhv_fill++; /* HvFILL(hv)++ */
1227 HeNEXT(entry) = *bep;
1233 Safefree (HvARRAY(hv));
1234 HvARRAY(hv) = (HE **)a;
1238 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1240 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1241 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1242 register I32 newsize;
1247 register HE **oentry;
1249 newsize = (I32) newmax; /* possible truncation here */
1250 if (newsize != newmax || newmax <= oldsize)
1252 while ((newsize & (1 + ~newsize)) != newsize) {
1253 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1255 if (newsize < newmax)
1257 if (newsize < newmax)
1258 return; /* overflow detection */
1260 a = (char *) HvARRAY(hv);
1263 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1264 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1270 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1275 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1276 if (oldsize >= 64) {
1277 offer_nice_chunk(HvARRAY(hv),
1278 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1281 Safefree(HvARRAY(hv));
1284 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1287 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1289 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1290 HvARRAY(hv) = (HE **) a;
1291 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1295 for (i=0; i<oldsize; i++,aep++) {
1296 if (!*aep) /* non-existent */
1298 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1300 if ((j = (HeHASH(entry) & newsize)) != i) {
1302 *oentry = HeNEXT(entry);
1303 if (!(HeNEXT(entry) = aep[j]))
1304 xhv->xhv_fill++; /* HvFILL(hv)++ */
1309 oentry = &HeNEXT(entry);
1311 if (!*aep) /* everything moved */
1312 xhv->xhv_fill--; /* HvFILL(hv)-- */
1319 Creates a new HV. The reference count is set to 1.
1328 register XPVHV* xhv;
1330 hv = (HV*)NEWSV(502,0);
1331 sv_upgrade((SV *)hv, SVt_PVHV);
1332 xhv = (XPVHV*)SvANY(hv);
1335 #ifndef NODEFAULT_SHAREKEYS
1336 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1339 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1340 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1346 Perl_newHVhv(pTHX_ HV *ohv)
1349 STRLEN hv_max, hv_fill;
1351 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1353 hv_max = HvMAX(ohv);
1355 if (!SvMAGICAL((SV *)ohv)) {
1356 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1358 const bool shared = !!HvSHAREKEYS(ohv);
1359 HE **ents, **oents = (HE **)HvARRAY(ohv);
1361 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1364 /* In each bucket... */
1365 for (i = 0; i <= hv_max; i++) {
1366 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1373 /* Copy the linked list of entries. */
1374 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1375 const U32 hash = HeHASH(oent);
1376 const char * const key = HeKEY(oent);
1377 const STRLEN len = HeKLEN(oent);
1378 const int flags = HeKFLAGS(oent);
1381 HeVAL(ent) = newSVsv(HeVAL(oent));
1383 = shared ? HeKEY_hek(share_hek_flags(key, len, hash, flags))
1384 : save_hek_flags(key, len, hash, flags);
1395 HvFILL(hv) = hv_fill;
1396 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1400 /* Iterate over ohv, copying keys and values one at a time. */
1402 const I32 riter = HvRITER_get(ohv);
1403 HE * const eiter = HvEITER_get(ohv);
1405 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1406 while (hv_max && hv_max + 1 >= hv_fill * 2)
1407 hv_max = hv_max / 2;
1411 while ((entry = hv_iternext_flags(ohv, 0))) {
1412 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1413 newSVsv(HeVAL(entry)), HeHASH(entry),
1416 HvRITER_set(ohv, riter);
1417 HvEITER_set(ohv, eiter);
1424 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1431 if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
1432 PL_sub_generation++; /* may be deletion of method from stash */
1434 if (HeKLEN(entry) == HEf_SVKEY) {
1435 SvREFCNT_dec(HeKEY_sv(entry));
1436 Safefree(HeKEY_hek(entry));
1438 else if (HvSHAREKEYS(hv))
1439 unshare_hek(HeKEY_hek(entry));
1441 Safefree(HeKEY_hek(entry));
1446 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1450 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME_get(hv))
1451 PL_sub_generation++; /* may be deletion of method from stash */
1452 sv_2mortal(HeVAL(entry)); /* free between statements */
1453 if (HeKLEN(entry) == HEf_SVKEY) {
1454 sv_2mortal(HeKEY_sv(entry));
1455 Safefree(HeKEY_hek(entry));
1457 else if (HvSHAREKEYS(hv))
1458 unshare_hek(HeKEY_hek(entry));
1460 Safefree(HeKEY_hek(entry));
1465 =for apidoc hv_clear
1467 Clears a hash, making it empty.
1473 Perl_hv_clear(pTHX_ HV *hv)
1476 register XPVHV* xhv;
1480 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1482 xhv = (XPVHV*)SvANY(hv);
1484 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1485 /* restricted hash: convert all keys to placeholders */
1487 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1488 HE *entry = (HvARRAY(hv))[i];
1489 for (; entry; entry = HeNEXT(entry)) {
1490 /* not already placeholder */
1491 if (HeVAL(entry) != &PL_sv_placeholder) {
1492 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1493 SV* keysv = hv_iterkeysv(entry);
1495 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1498 SvREFCNT_dec(HeVAL(entry));
1499 HeVAL(entry) = &PL_sv_placeholder;
1500 HvPLACEHOLDERS(hv)++;
1508 HvPLACEHOLDERS_set(hv, 0);
1510 (void)memzero(HvARRAY(hv),
1511 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1516 HvHASKFLAGS_off(hv);
1520 HvEITER_set(hv, NULL);
1525 =for apidoc hv_clear_placeholders
1527 Clears any placeholders from a hash. If a restricted hash has any of its keys
1528 marked as readonly and the key is subsequently deleted, the key is not actually
1529 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1530 it so it will be ignored by future operations such as iterating over the hash,
1531 but will still allow the hash to have a value reassigned to the key at some
1532 future point. This function clears any such placeholder keys from the hash.
1533 See Hash::Util::lock_keys() for an example of its use.
1539 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1542 I32 items = (I32)HvPLACEHOLDERS_get(hv);
1549 /* Loop down the linked list heads */
1551 HE **oentry = &(HvARRAY(hv))[i];
1552 HE *entry = *oentry;
1557 for (; entry; entry = *oentry) {
1558 if (HeVAL(entry) == &PL_sv_placeholder) {
1559 *oentry = HeNEXT(entry);
1560 if (first && !*oentry)
1561 HvFILL(hv)--; /* This linked list is now empty. */
1562 if (HvEITER_get(hv))
1565 hv_free_ent(hv, entry);
1569 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1570 if (HvKEYS(hv) == 0)
1571 HvHASKFLAGS_off(hv);
1572 HvPLACEHOLDERS_set(hv, 0);
1576 oentry = &HeNEXT(entry);
1581 /* You can't get here, hence assertion should always fail. */
1582 assert (items == 0);
1587 S_hfreeentries(pTHX_ HV *hv)
1589 register HE **array;
1593 struct xpvhv_aux *iter;
1602 array = HvARRAY(hv);
1603 /* make everyone else think the array is empty, so that the destructors
1604 * called for freed entries can't recusively mess with us */
1605 HvARRAY(hv) = Null(HE**);
1607 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1612 register HE *oentry = entry;
1613 entry = HeNEXT(entry);
1614 hv_free_ent(hv, oentry);
1619 entry = array[riter];
1622 HvARRAY(hv) = array;
1624 iter = ((XPVHV*) SvANY(hv))->xhv_aux;
1626 entry = iter->xhv_eiter; /* HvEITER(hv) */
1627 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1629 hv_free_ent(hv, entry);
1632 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
1634 ((XPVHV*) SvANY(hv))->xhv_aux = 0;
1639 =for apidoc hv_undef
1647 Perl_hv_undef(pTHX_ HV *hv)
1649 register XPVHV* xhv;
1653 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1654 xhv = (XPVHV*)SvANY(hv);
1656 Safefree(HvARRAY(hv));
1657 if ((name = HvNAME_get(hv))) {
1659 hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1660 Perl_hv_name_set(aTHX_ hv, 0, 0, 0);
1662 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1664 HvPLACEHOLDERS_set(hv, 0);
1671 S_hv_auxinit(pTHX) {
1672 struct xpvhv_aux *iter;
1674 New(0, iter, 1, struct xpvhv_aux);
1676 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1677 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1684 =for apidoc hv_iterinit
1686 Prepares a starting point to traverse a hash table. Returns the number of
1687 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1688 currently only meaningful for hashes without tie magic.
1690 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1691 hash buckets that happen to be in use. If you still need that esoteric
1692 value, you can get it through the macro C<HvFILL(tb)>.
1699 Perl_hv_iterinit(pTHX_ HV *hv)
1701 register XPVHV* xhv;
1703 struct xpvhv_aux *iter;
1706 Perl_croak(aTHX_ "Bad hash");
1707 xhv = (XPVHV*)SvANY(hv);
1709 iter = xhv->xhv_aux;
1711 entry = iter->xhv_eiter; /* HvEITER(hv) */
1712 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1714 hv_free_ent(hv, entry);
1716 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1717 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1719 xhv->xhv_aux = S_hv_auxinit(aTHX);
1722 /* used to be xhv->xhv_fill before 5.004_65 */
1723 return HvTOTALKEYS(hv);
1727 Perl_hv_riter_p(pTHX_ HV *hv) {
1728 struct xpvhv_aux *iter;
1731 Perl_croak(aTHX_ "Bad hash");
1733 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1735 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1737 return &(iter->xhv_riter);
1741 Perl_hv_eiter_p(pTHX_ HV *hv) {
1742 struct xpvhv_aux *iter;
1745 Perl_croak(aTHX_ "Bad hash");
1747 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1749 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1751 return &(iter->xhv_eiter);
1755 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1756 struct xpvhv_aux *iter;
1759 Perl_croak(aTHX_ "Bad hash");
1762 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1767 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1769 iter->xhv_riter = riter;
1773 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1774 struct xpvhv_aux *iter;
1777 Perl_croak(aTHX_ "Bad hash");
1779 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1781 /* 0 is the default so don't go malloc()ing a new structure just to
1786 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1788 iter->xhv_eiter = eiter;
1792 Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags)
1794 struct xpvhv_aux *iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1798 if (iter->xhv_name) {
1799 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
1805 ((XPVHV *)SvANY(hv))->xhv_aux = iter = S_hv_auxinit(aTHX);
1807 PERL_HASH(hash, name, len);
1808 iter->xhv_name = name ? share_hek(name, len, hash) : 0;
1812 =for apidoc hv_iternext
1814 Returns entries from a hash iterator. See C<hv_iterinit>.
1816 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1817 iterator currently points to, without losing your place or invalidating your
1818 iterator. Note that in this case the current entry is deleted from the hash
1819 with your iterator holding the last reference to it. Your iterator is flagged
1820 to free the entry on the next call to C<hv_iternext>, so you must not discard
1821 your iterator immediately else the entry will leak - call C<hv_iternext> to
1822 trigger the resource deallocation.
1828 Perl_hv_iternext(pTHX_ HV *hv)
1830 return hv_iternext_flags(hv, 0);
1834 =for apidoc hv_iternext_flags
1836 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1837 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1838 set the placeholders keys (for restricted hashes) will be returned in addition
1839 to normal keys. By default placeholders are automatically skipped over.
1840 Currently a placeholder is implemented with a value that is
1841 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1842 restricted hashes may change, and the implementation currently is
1843 insufficiently abstracted for any change to be tidy.
1849 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1852 register XPVHV* xhv;
1856 struct xpvhv_aux *iter;
1859 Perl_croak(aTHX_ "Bad hash");
1860 xhv = (XPVHV*)SvANY(hv);
1861 iter = xhv->xhv_aux;
1864 /* Too many things (well, pp_each at least) merrily assume that you can
1865 call iv_iternext without calling hv_iterinit, so we'll have to deal
1868 iter = ((XPVHV *)SvANY(hv))->xhv_aux;
1871 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
1873 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1874 SV *key = sv_newmortal();
1876 sv_setsv(key, HeSVKEY_force(entry));
1877 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1883 /* one HE per MAGICAL hash */
1884 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1886 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1888 HeKEY_hek(entry) = hek;
1889 HeKLEN(entry) = HEf_SVKEY;
1891 magic_nextpack((SV*) hv,mg,key);
1893 /* force key to stay around until next time */
1894 HeSVKEY_set(entry, SvREFCNT_inc(key));
1895 return entry; /* beware, hent_val is not set */
1898 SvREFCNT_dec(HeVAL(entry));
1899 Safefree(HeKEY_hek(entry));
1901 iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1904 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1905 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1912 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1914 HvARRAY(hv) = (HE**) darray;
1916 /* At start of hash, entry is NULL. */
1919 entry = HeNEXT(entry);
1920 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1922 * Skip past any placeholders -- don't want to include them in
1925 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1926 entry = HeNEXT(entry);
1931 /* OK. Come to the end of the current list. Grab the next one. */
1933 iter->xhv_riter++; /* HvRITER(hv)++ */
1934 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1935 /* There is no next one. End of the hash. */
1936 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1939 entry = (HvARRAY(hv))[iter->xhv_riter];
1941 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1942 /* If we have an entry, but it's a placeholder, don't count it.
1944 while (entry && HeVAL(entry) == &PL_sv_placeholder)
1945 entry = HeNEXT(entry);
1947 /* Will loop again if this linked list starts NULL
1948 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1949 or if we run through it and find only placeholders. */
1952 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1954 hv_free_ent(hv, oldentry);
1957 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1958 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1960 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
1965 =for apidoc hv_iterkey
1967 Returns the key from the current position of the hash iterator. See
1974 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1976 if (HeKLEN(entry) == HEf_SVKEY) {
1978 char *p = SvPV(HeKEY_sv(entry), len);
1983 *retlen = HeKLEN(entry);
1984 return HeKEY(entry);
1988 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1990 =for apidoc hv_iterkeysv
1992 Returns the key as an C<SV*> from the current position of the hash
1993 iterator. The return value will always be a mortal copy of the key. Also
2000 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2002 if (HeKLEN(entry) != HEf_SVKEY) {
2003 HEK *hek = HeKEY_hek(entry);
2004 const int flags = HEK_FLAGS(hek);
2007 if (flags & HVhek_WASUTF8) {
2009 Andreas would like keys he put in as utf8 to come back as utf8
2011 STRLEN utf8_len = HEK_LEN(hek);
2012 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
2014 sv = newSVpvn ((char*)as_utf8, utf8_len);
2016 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
2017 } else if (flags & HVhek_REHASH) {
2018 /* We don't have a pointer to the hv, so we have to replicate the
2019 flag into every HEK. This hv is using custom a hasing
2020 algorithm. Hence we can't return a shared string scalar, as
2021 that would contain the (wrong) hash value, and might get passed
2022 into an hv routine with a regular hash */
2024 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
2028 sv = newSVpvn_share(HEK_KEY(hek),
2029 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
2032 return sv_2mortal(sv);
2034 return sv_mortalcopy(HeKEY_sv(entry));
2038 =for apidoc hv_iterval
2040 Returns the value from the current position of the hash iterator. See
2047 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2049 if (SvRMAGICAL(hv)) {
2050 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2051 SV* sv = sv_newmortal();
2052 if (HeKLEN(entry) == HEf_SVKEY)
2053 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2055 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2059 return HeVAL(entry);
2063 =for apidoc hv_iternextsv
2065 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2072 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2075 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
2077 *key = hv_iterkey(he, retlen);
2078 return hv_iterval(hv, he);
2082 =for apidoc hv_magic
2084 Adds magic to a hash. See C<sv_magic>.
2090 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
2092 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
2095 #if 0 /* use the macro from hv.h instead */
2098 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
2100 return HEK_KEY(share_hek(sv, len, hash));
2105 /* possibly free a shared string if no one has access to it
2106 * len and hash must both be valid for str.
2109 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2111 unshare_hek_or_pvn (NULL, str, len, hash);
2116 Perl_unshare_hek(pTHX_ HEK *hek)
2118 unshare_hek_or_pvn(hek, NULL, 0, 0);
2121 /* possibly free a shared string if no one has access to it
2122 hek if non-NULL takes priority over the other 3, else str, len and hash
2123 are used. If so, len and hash must both be valid for str.
2126 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2128 register XPVHV* xhv;
2130 register HE **oentry;
2133 bool is_utf8 = FALSE;
2135 const char *save = str;
2138 hash = HEK_HASH(hek);
2139 } else if (len < 0) {
2140 STRLEN tmplen = -len;
2142 /* See the note in hv_fetch(). --jhi */
2143 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2146 k_flags = HVhek_UTF8;
2148 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2151 /* what follows is the moral equivalent of:
2152 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2153 if (--*Svp == Nullsv)
2154 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2156 xhv = (XPVHV*)SvANY(PL_strtab);
2157 /* assert(xhv_array != 0) */
2159 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2161 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2162 if (HeKEY_hek(entry) != hek)
2168 const int flags_masked = k_flags & HVhek_MASK;
2169 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2170 if (HeHASH(entry) != hash) /* strings can't be equal */
2172 if (HeKLEN(entry) != len)
2174 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2176 if (HeKFLAGS(entry) != flags_masked)
2184 if (--HeVAL(entry) == Nullsv) {
2185 *oentry = HeNEXT(entry);
2187 /* There are now no entries in our slot. */
2188 xhv->xhv_fill--; /* HvFILL(hv)-- */
2190 Safefree(HeKEY_hek(entry));
2192 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2196 UNLOCK_STRTAB_MUTEX;
2197 if (!found && ckWARN_d(WARN_INTERNAL))
2198 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2199 "Attempt to free non-existent shared string '%s'%s"
2201 hek ? HEK_KEY(hek) : str,
2202 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2203 if (k_flags & HVhek_FREEKEY)
2207 /* get a (constant) string ptr from the global string table
2208 * string will get added if it is not already there.
2209 * len and hash must both be valid for str.
2212 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2214 bool is_utf8 = FALSE;
2216 const char *save = str;
2219 STRLEN tmplen = -len;
2221 /* See the note in hv_fetch(). --jhi */
2222 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2224 /* If we were able to downgrade here, then than means that we were passed
2225 in a key which only had chars 0-255, but was utf8 encoded. */
2228 /* If we found we were able to downgrade the string to bytes, then
2229 we should flag that it needs upgrading on keys or each. Also flag
2230 that we need share_hek_flags to free the string. */
2232 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2235 return HeKEY_hek(share_hek_flags (str, len, hash, flags));
2239 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2241 register XPVHV* xhv;
2243 register HE **oentry;
2245 const int flags_masked = flags & HVhek_MASK;
2247 /* what follows is the moral equivalent of:
2249 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2250 hv_store(PL_strtab, str, len, Nullsv, hash);
2252 Can't rehash the shared string table, so not sure if it's worth
2253 counting the number of entries in the linked list
2255 xhv = (XPVHV*)SvANY(PL_strtab);
2256 /* assert(xhv_array != 0) */
2258 oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2259 for (entry = *oentry; entry; entry = HeNEXT(entry)) {
2260 if (HeHASH(entry) != hash) /* strings can't be equal */
2262 if (HeKLEN(entry) != len)
2264 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2266 if (HeKFLAGS(entry) != flags_masked)
2272 /* What used to be head of the list.
2273 If this is NULL, then we're the first entry for this slot, which
2274 means we need to increate fill. */
2275 const HE *old_first = *oentry;
2277 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked);
2278 HeVAL(entry) = Nullsv;
2279 HeNEXT(entry) = *oentry;
2281 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2282 if (!old_first) { /* initial entry? */
2283 xhv->xhv_fill++; /* HvFILL(hv)++ */
2284 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2289 ++HeVAL(entry); /* use value slot as REFCNT */
2290 UNLOCK_STRTAB_MUTEX;
2292 if (flags & HVhek_FREEKEY)
2299 Perl_hv_placeholders_p(pTHX_ HV *hv)
2302 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2305 mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2308 Perl_die(aTHX_ "panic: hv_placeholders_p");
2311 return &(mg->mg_len);
2316 Perl_hv_placeholders_get(pTHX_ HV *hv)
2319 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2321 return mg ? mg->mg_len : 0;
2325 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2328 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2333 if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2334 Perl_die(aTHX_ "panic: hv_placeholders_set");
2336 /* else we don't need to add magic to record 0 placeholders. */
2340 =for apidoc hv_assert
2342 Check that a hash is in an internally consistent state.
2348 Perl_hv_assert(pTHX_ HV *hv)
2353 int placeholders = 0;
2356 const I32 riter = HvRITER_get(hv);
2357 HE *eiter = HvEITER_get(hv);
2359 (void)hv_iterinit(hv);
2361 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2362 /* sanity check the values */
2363 if (HeVAL(entry) == &PL_sv_placeholder) {
2368 /* sanity check the keys */
2369 if (HeSVKEY(entry)) {
2370 /* Don't know what to check on SV keys. */
2371 } else if (HeKUTF8(entry)) {
2373 if (HeKWASUTF8(entry)) {
2374 PerlIO_printf(Perl_debug_log,
2375 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2376 (int) HeKLEN(entry), HeKEY(entry));
2379 } else if (HeKWASUTF8(entry)) {
2383 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2384 if (HvUSEDKEYS(hv) != real) {
2385 PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2386 (int) real, (int) HvUSEDKEYS(hv));
2389 if (HvPLACEHOLDERS_get(hv) != placeholders) {
2390 PerlIO_printf(Perl_debug_log,
2391 "Count %d placeholder(s), but hash reports %d\n",
2392 (int) placeholders, (int) HvPLACEHOLDERS_get(hv));
2396 if (withflags && ! HvHASKFLAGS(hv)) {
2397 PerlIO_printf(Perl_debug_log,
2398 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2405 HvRITER_set(hv, riter); /* Restore hash iterator state */
2406 HvEITER_set(hv, eiter);
2411 * c-indentation-style: bsd
2413 * indent-tabs-mode: t
2416 * ex: set ts=8 sts=4 sw=4 noet: