3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "I sit beside the fire and think of all that I have seen." --Bilbo
16 =head1 Hash Manipulation Functions
21 #define PERL_HASH_INTERNAL_ACCESS
24 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
34 PL_he_root = HeNEXT(he);
43 HeNEXT(p) = (HE*)PL_he_root;
54 New(54, ptr, 1008/sizeof(XPV), XPV);
55 ptr->xpv_pv = (char*)PL_he_arenaroot;
56 PL_he_arenaroot = ptr;
59 heend = &he[1008 / sizeof(HE) - 1];
62 HeNEXT(he) = (HE*)(he + 1);
70 #define new_HE() (HE*)safemalloc(sizeof(HE))
71 #define del_HE(p) safefree((char*)p)
75 #define new_HE() new_he()
76 #define del_HE(p) del_he(p)
81 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
86 New(54, k, HEK_BASESIZE + len + 2, char);
88 Copy(str, HEK_KEY(hek), len, char);
89 HEK_KEY(hek)[len] = 0;
92 HEK_FLAGS(hek) = (unsigned char)flags;
96 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
100 Perl_free_tied_hv_pool(pTHX)
103 HE *he = PL_hv_fetch_ent_mh;
105 Safefree(HeKEY_hek(he));
110 PL_hv_fetch_ent_mh = Nullhe;
113 #if defined(USE_ITHREADS)
115 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
121 /* look for it in the table first */
122 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
126 /* create anew and remember what it is */
128 ptr_table_store(PL_ptr_table, e, ret);
130 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
131 if (HeKLEN(e) == HEf_SVKEY) {
133 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
134 HeKEY_hek(ret) = (HEK*)k;
135 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
138 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
141 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
143 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
146 #endif /* USE_ITHREADS */
149 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
152 SV *sv = sv_newmortal(), *esv = sv_newmortal();
153 if (!(flags & HVhek_FREEKEY)) {
154 sv_setpvn(sv, key, klen);
157 /* Need to free saved eventually assign to mortal SV */
158 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
159 sv_usepvn(sv, (char *) key, klen);
161 if (flags & HVhek_UTF8) {
164 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
165 Perl_croak(aTHX_ SvPVX(esv), sv);
168 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
174 Returns the SV which corresponds to the specified key in the hash. The
175 C<klen> is the length of the key. If C<lval> is set then the fetch will be
176 part of a store. Check that the return value is non-null before
177 dereferencing it to an C<SV*>.
179 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
180 information on how to use this function on tied hashes.
185 #define HV_FETCH_LVALUE 0x01
186 #define HV_FETCH_JUST_SV 0x02
189 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
202 hek = hv_fetch_common (hv, NULL, key, klen, flags,
203 HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0), 0);
204 return hek ? &HeVAL(hek) : NULL;
207 /* returns an HE * structure with the all fields set */
208 /* note that hent_val will be a mortal sv for MAGICAL hashes */
210 =for apidoc hv_fetch_ent
212 Returns the hash entry which corresponds to the specified key in the hash.
213 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
214 if you want the function to compute it. IF C<lval> is set then the fetch
215 will be part of a store. Make sure the return value is non-null before
216 accessing it. The return value when C<tb> is a tied hash is a pointer to a
217 static location, so be sure to make a copy of the structure if you need to
220 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
221 information on how to use this function on tied hashes.
227 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
229 return hv_fetch_common(hv, keysv, NULL, 0, 0, lval ? HV_FETCH_LVALUE : 0,
234 S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
235 int flags, int action, register U32 hash)
248 key = SvPV(keysv, klen);
250 is_utf8 = (SvUTF8(keysv) != 0);
252 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
256 if (SvRMAGICAL(hv)) {
257 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
260 /* XXX should be able to skimp on the HE/HEK here when
261 HV_FETCH_JUST_SV is true. */
264 keysv = newSVpvn(key, klen);
269 keysv = newSVsv(keysv);
271 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
274 /* grab a fake HE/HEK pair from the pool or make a new one */
275 entry = PL_hv_fetch_ent_mh;
277 PL_hv_fetch_ent_mh = HeNEXT(entry);
281 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
282 HeKEY_hek(entry) = (HEK*)k;
284 HeNEXT(entry) = Nullhe;
285 HeSVKEY_set(entry, keysv);
287 sv_upgrade(sv, SVt_PVLV);
289 LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
291 /* XXX remove at some point? */
292 if (flags & HVhek_FREEKEY)
297 #ifdef ENV_IS_CASELESS
298 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
300 for (i = 0; i < klen; ++i)
301 if (isLOWER(key[i])) {
302 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
303 (void)strupr(SvPVX(nkeysv));
304 entry = hv_fetch_common(hv, nkeysv, NULL, 0, 0, 0);
305 if (!entry && (action & HV_FETCH_LVALUE))
306 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
308 /* XXX remove at some point? */
309 if (flags & HVhek_FREEKEY)
318 xhv = (XPVHV*)SvANY(hv);
319 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
320 if ((action & HV_FETCH_LVALUE)
321 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
322 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
325 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
326 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
329 /* XXX remove at some point? */
330 if (flags & HVhek_FREEKEY)
338 int oldflags = flags;
339 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
343 flags &= ~HVhek_UTF8;
345 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
346 if (oldflags & HVhek_FREEKEY)
352 PERL_HASH_INTERNAL(hash, key, klen);
353 /* Yes, you do need this even though you are not "storing" because
354 you can flip the flags below if doing an lval lookup. (And that
355 was put in to give the semantics Andreas was expecting.) */
356 flags |= HVhek_REHASH;
358 if (keysv && (SvIsCOW_shared_hash(keysv))) {
361 PERL_HASH(hash, key, klen);
365 masked_flags = (flags & HVhek_MASK);
367 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
368 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
369 for (; entry; entry = HeNEXT(entry)) {
370 if (HeHASH(entry) != hash) /* strings can't be equal */
372 if (HeKLEN(entry) != (I32)klen)
374 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
376 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
378 if ((action & HV_FETCH_LVALUE) && HeKFLAGS(entry) != masked_flags) {
379 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
380 But if entry was set previously with HVhek_WASUTF8 and key now
381 doesn't (or vice versa) then we should change the key's flag,
382 as this is assignment. */
383 if (HvSHAREKEYS(hv)) {
384 /* Need to swap the key we have for a key with the flags we
385 need. As keys are shared we can't just write to the flag,
386 so we share the new one, unshare the old one. */
387 HEK *new_hek = share_hek_flags(key, klen, hash, masked_flags);
388 unshare_hek (HeKEY_hek(entry));
389 HeKEY_hek(entry) = new_hek;
392 HeKFLAGS(entry) = masked_flags;
393 if (masked_flags & HVhek_ENABLEHVKFLAGS)
396 /* if we find a placeholder, we pretend we haven't found anything */
397 if (HeVAL(entry) == &PL_sv_placeholder)
399 if (flags & HVhek_FREEKEY)
403 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
404 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
406 char *env = PerlEnv_ENVgetenv_len(key,&len);
408 /* XXX remove once common API complete */
410 nkeysv = sv_2mortal(newSVpvn(key,klen));
413 sv = newSVpvn(env,len);
415 if (flags & HVhek_FREEKEY)
417 return hv_store_ent(hv,keysv,sv,hash);
421 if (!entry && SvREADONLY(hv)) {
422 S_hv_notallowed(aTHX_ flags, key, klen,
423 "access disallowed key '%"SVf"' in"
426 if (action & HV_FETCH_LVALUE) {
427 /* XXX remove once common API complete */
429 keysv = sv_2mortal(newSVpvn(key,klen));
433 if (flags & HVhek_FREEKEY)
435 if (action & HV_FETCH_LVALUE) {
436 /* gonna assign to this, so it better be there */
438 return hv_store_ent(hv,keysv,sv,hash);
444 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
446 MAGIC *mg = SvMAGIC(hv);
450 if (isUPPER(mg->mg_type)) {
452 switch (mg->mg_type) {
453 case PERL_MAGIC_tied:
455 *needs_store = FALSE;
458 mg = mg->mg_moremagic;
465 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
466 the length of the key. The C<hash> parameter is the precomputed hash
467 value; if it is zero then Perl will compute it. The return value will be
468 NULL if the operation failed or if the value did not need to be actually
469 stored within the hash (as in the case of tied hashes). Otherwise it can
470 be dereferenced to get the original C<SV*>. Note that the caller is
471 responsible for suitably incrementing the reference count of C<val> before
472 the call, and decrementing it if the function returned NULL. Effectively
473 a successful hv_store takes ownership of one reference to C<val>. This is
474 usually what you want; a newly created SV has a reference count of one, so
475 if all your code does is create SVs then store them in a hash, hv_store
476 will own the only reference to the new SV, and your code doesn't need to do
477 anything further to tidy up. hv_store is not implemented as a call to
478 hv_store_ent, and does not create a temporary SV for the key, so if your
479 key data is not already in SV form then use hv_store in preference to
482 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
483 information on how to use this function on tied hashes.
489 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash)
491 HE *hek = hv_store_common (hv, NULL, key, klen, 0, val, hash);
492 return hek ? &HeVAL(hek) : NULL;
496 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
497 register U32 hash, int flags)
499 HE *hek = hv_store_common (hv, NULL, key, klen, flags, val, hash);
500 return hek ? &HeVAL(hek) : NULL;
504 =for apidoc hv_store_ent
506 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
507 parameter is the precomputed hash value; if it is zero then Perl will
508 compute it. The return value is the new hash entry so created. It will be
509 NULL if the operation failed or if the value did not need to be actually
510 stored within the hash (as in the case of tied hashes). Otherwise the
511 contents of the return value can be accessed using the C<He?> macros
512 described here. Note that the caller is responsible for suitably
513 incrementing the reference count of C<val> before the call, and
514 decrementing it if the function returned NULL. Effectively a successful
515 hv_store_ent takes ownership of one reference to C<val>. This is
516 usually what you want; a newly created SV has a reference count of one, so
517 if all your code does is create SVs then store them in a hash, hv_store
518 will own the only reference to the new SV, and your code doesn't need to do
519 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
520 unlike C<val> it does not take ownership of it, so maintaining the correct
521 reference count on C<key> is entirely the caller's responsibility. hv_store
522 is not implemented as a call to hv_store_ent, and does not create a temporary
523 SV for the key, so if your key data is not already in SV form then use
524 hv_store in preference to hv_store_ent.
526 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
527 information on how to use this function on tied hashes.
533 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
535 return hv_store_common(hv, keysv, NULL, 0, 0, val, hash);
539 S_hv_store_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
540 int flags, SV *val, U32 hash)
554 key = SvPV(keysv, klen);
555 is_utf8 = (SvUTF8(keysv) != 0);
562 /* XXX Need to fix this one level out. */
563 is_utf8 = (flags & HVhek_UTF8) ? TRUE : FALSE;
568 xhv = (XPVHV*)SvANY(hv);
572 hv_magic_check (hv, &needs_copy, &needs_store);
574 bool save_taint = PL_tainted;
575 if (keysv || is_utf8) {
577 keysv = newSVpvn(key, klen);
581 PL_tainted = SvTAINTED(keysv);
582 keysv = sv_2mortal(newSVsv(keysv));
583 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
585 mg_copy((SV*)hv, val, key, klen);
588 TAINT_IF(save_taint);
589 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) {
590 if (flags & HVhek_FREEKEY)
594 #ifdef ENV_IS_CASELESS
595 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
596 key = savepvn(key,klen);
597 key = (const char*)strupr((char*)key);
600 if (flags & HVhek_FREEKEY)
609 if (flags & HVhek_PLACEHOLD) {
610 /* We have been requested to insert a placeholder. Currently
611 only Storable is allowed to do this. */
612 val = &PL_sv_placeholder;
616 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
618 if (flags & HVhek_FREEKEY) {
619 /* This shouldn't happen if our caller does what we expect,
620 but strictly the API allows it. */
627 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
628 HvHASKFLAGS_on((SV*)hv);
632 /* We don't have a pointer to the hv, so we have to replicate the
633 flag into every HEK, so that hv_iterkeysv can see it. */
634 flags |= HVhek_REHASH;
635 PERL_HASH_INTERNAL(hash, key, klen);
637 if (keysv && SvIsCOW_shared_hash(keysv)) {
640 PERL_HASH(hash, key, klen);
644 if (!xhv->xhv_array /* !HvARRAY(hv) */)
645 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
646 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
649 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
650 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
653 for (; entry; ++n_links, entry = HeNEXT(entry)) {
654 if (HeHASH(entry) != hash) /* strings can't be equal */
656 if (HeKLEN(entry) != (I32)klen)
658 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
660 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
662 if (HeVAL(entry) == &PL_sv_placeholder)
663 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
665 SvREFCNT_dec(HeVAL(entry));
667 if (val == &PL_sv_placeholder)
668 xhv->xhv_placeholders++;
670 if (HeKFLAGS(entry) != flags) {
671 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
672 But if entry was set previously with HVhek_WASUTF8 and key now
673 doesn't (or vice versa) then we should change the key's flag,
674 as this is assignment. */
675 if (HvSHAREKEYS(hv)) {
676 /* Need to swap the key we have for a key with the flags we
677 need. As keys are shared we can't just write to the flag,
678 so we share the new one, unshare the old one. */
679 int flags_nofree = flags & ~HVhek_FREEKEY;
680 HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree);
681 unshare_hek (HeKEY_hek(entry));
682 HeKEY_hek(entry) = new_hek;
685 HeKFLAGS(entry) = flags;
687 if (flags & HVhek_FREEKEY)
692 if (SvREADONLY(hv)) {
693 S_hv_notallowed(aTHX_ flags, key, klen,
694 "access disallowed key '%"SVf"' to"
699 /* share_hek_flags will do the free for us. This might be considered
702 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
703 else /* gotta do the real thing */
704 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
706 HeNEXT(entry) = *oentry;
709 if (val == &PL_sv_placeholder)
710 xhv->xhv_placeholders++;
712 xhv->xhv_keys++; /* HvKEYS(hv)++ */
713 if (!n_links) { /* initial entry? */
714 xhv->xhv_fill++; /* HvFILL(hv)++ */
715 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
716 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
717 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
718 splits on a rehashed hash, as we're not going to split it again,
719 and if someone is lucky (evil) enough to get all the keys in one
720 list they could exhaust our memory as we repeatedly double the
721 number of buckets on every entry. Linear search feels a less worse
730 =for apidoc hv_delete
732 Deletes a key/value pair in the hash. The value SV is removed from the
733 hash and returned to the caller. The C<klen> is the length of the key.
734 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
741 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
743 return hv_delete_common(hv, NULL, key, klen, flags, 0);
747 =for apidoc hv_delete_ent
749 Deletes a key/value pair in the hash. The value SV is removed from the
750 hash and returned to the caller. The C<flags> value will normally be zero;
751 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
752 precomputed hash value, or 0 to ask for it to be computed.
758 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
760 return hv_delete_common(hv, keysv, NULL, 0, flags, hash);
764 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
771 register HE **oentry;
782 key = SvPV(keysv, klen);
783 is_utf8 = (SvUTF8(keysv) != 0);
795 if (SvRMAGICAL(hv)) {
798 hv_magic_check (hv, &needs_copy, &needs_store);
801 entry = hv_fetch_common(hv, keysv, key, klen,
802 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
804 sv = entry ? HeVAL(entry) : NULL;
810 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
811 /* No longer an element */
812 sv_unmagic(sv, PERL_MAGIC_tiedelem);
815 return Nullsv; /* element cannot be deleted */
818 #ifdef ENV_IS_CASELESS
819 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
820 /* XXX This code isn't UTF8 clean. */
821 keysv = sv_2mortal(newSVpvn(key,klen));
822 keysave = key = strupr(SvPVX(keysv));
829 xhv = (XPVHV*)SvANY(hv);
830 if (!xhv->xhv_array /* !HvARRAY(hv) */)
834 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
836 k_flags = HVhek_UTF8;
838 k_flags |= HVhek_FREEKEY;
842 PERL_HASH_INTERNAL(hash, key, klen);
844 if (keysv && (SvIsCOW_shared_hash(keysv))) {
847 PERL_HASH(hash, key, klen);
849 PERL_HASH(hash, key, klen);
852 masked_flags = (k_flags & HVhek_MASK);
854 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
855 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
858 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
859 if (HeHASH(entry) != hash) /* strings can't be equal */
861 if (HeKLEN(entry) != (I32)klen)
863 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
865 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
867 if (k_flags & HVhek_FREEKEY)
870 /* if placeholder is here, it's already been deleted.... */
871 if (HeVAL(entry) == &PL_sv_placeholder)
874 return Nullsv; /* if still SvREADONLY, leave it deleted. */
876 /* okay, really delete the placeholder. */
877 *oentry = HeNEXT(entry);
879 xhv->xhv_fill--; /* HvFILL(hv)-- */
880 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
883 hv_free_ent(hv, entry);
884 xhv->xhv_keys--; /* HvKEYS(hv)-- */
885 if (xhv->xhv_keys == 0)
887 xhv->xhv_placeholders--;
890 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
891 S_hv_notallowed(aTHX_ k_flags, key, klen,
892 "delete readonly key '%"SVf"' from"
896 if (flags & G_DISCARD)
899 sv = sv_2mortal(HeVAL(entry));
900 HeVAL(entry) = &PL_sv_placeholder;
904 * If a restricted hash, rather than really deleting the entry, put
905 * a placeholder there. This marks the key as being "approved", so
906 * we can still access via not-really-existing key without raising
909 if (SvREADONLY(hv)) {
910 HeVAL(entry) = &PL_sv_placeholder;
911 /* We'll be saving this slot, so the number of allocated keys
912 * doesn't go down, but the number placeholders goes up */
913 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
915 *oentry = HeNEXT(entry);
917 xhv->xhv_fill--; /* HvFILL(hv)-- */
918 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
921 hv_free_ent(hv, entry);
922 xhv->xhv_keys--; /* HvKEYS(hv)-- */
923 if (xhv->xhv_keys == 0)
928 if (SvREADONLY(hv)) {
929 S_hv_notallowed(aTHX_ k_flags, key, klen,
930 "delete disallowed key '%"SVf"' from"
934 if (k_flags & HVhek_FREEKEY)
940 =for apidoc hv_exists
942 Returns a boolean indicating whether the specified hash key exists. The
943 C<klen> is the length of the key.
949 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
951 return hv_exists_common(hv, NULL, key, klen, 0);
955 =for apidoc hv_exists_ent
957 Returns a boolean indicating whether the specified hash key exists. C<hash>
958 can be a valid precomputed hash value, or 0 to ask for it to be
965 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
967 return hv_exists_common(hv, keysv, NULL, 0, hash);
971 S_hv_exists_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32,
986 key = SvPV(keysv, klen);
987 is_utf8 = (SvUTF8(keysv) != 0);
999 if (SvRMAGICAL(hv)) {
1000 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
1003 if (keysv || is_utf8) {
1005 keysv = newSVpvn(key, klen);
1008 keysv = newSVsv(keysv);
1010 key = (char *)sv_2mortal(keysv);
1014 /* I don't understand why hv_exists_ent has svret and sv,
1015 whereas hv_exists only had one. */
1016 svret = sv_newmortal();
1017 sv = sv_newmortal();
1018 mg_copy((SV*)hv, sv, key, klen);
1019 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1020 return (bool)SvTRUE(svret);
1022 #ifdef ENV_IS_CASELESS
1023 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1024 /* XXX This code isn't UTF8 clean. */
1025 keysv = sv_2mortal(newSVpvn(key,klen));
1026 keysave = key = strupr(SvPVX(keysv));
1033 xhv = (XPVHV*)SvANY(hv);
1034 #ifndef DYNAMIC_ENV_FETCH
1035 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1040 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1042 k_flags = HVhek_UTF8;
1044 k_flags |= HVhek_FREEKEY;
1047 PERL_HASH_INTERNAL(hash, key, klen);
1049 PERL_HASH(hash, key, klen);
1051 #ifdef DYNAMIC_ENV_FETCH
1052 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
1055 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1056 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1057 for (; entry; entry = HeNEXT(entry)) {
1058 if (HeHASH(entry) != hash) /* strings can't be equal */
1060 if (HeKLEN(entry) != (I32)klen)
1062 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1064 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1066 if (k_flags & HVhek_FREEKEY)
1068 /* If we find the key, but the value is a placeholder, return false. */
1069 if (HeVAL(entry) == &PL_sv_placeholder)
1073 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
1074 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1076 char *env = PerlEnv_ENVgetenv_len(key,&len);
1078 sv = newSVpvn(env,len);
1080 (void)hv_store_ent(hv,keysv,sv,hash);
1081 if (k_flags & HVhek_FREEKEY)
1087 if (k_flags & HVhek_FREEKEY)
1094 S_hsplit(pTHX_ HV *hv)
1096 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1097 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1098 register I32 newsize = oldsize * 2;
1100 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1104 register HE **oentry;
1105 int longest_chain = 0;
1109 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1110 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1116 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1121 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1122 if (oldsize >= 64) {
1123 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1124 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1127 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1131 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1132 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1133 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1136 for (i=0; i<oldsize; i++,aep++) {
1137 int left_length = 0;
1138 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);
1194 aep = (HE **) xhv->xhv_array;
1196 for (i=0; i<newsize; i++,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);
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 (xhv->xhv_array);
1233 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1237 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1239 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1240 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1241 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 = xhv->xhv_array; /* 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(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1276 if (oldsize >= 64) {
1277 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1278 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1281 Safefree(xhv->xhv_array /* 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 xhv->xhv_array = a; /* HvARRAY(hv) = 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) {
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 */
1340 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1341 (void)hv_iterinit(hv); /* so each() will start off right */
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 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 U32 hash = HeHASH(oent);
1376 char *key = HeKEY(oent);
1377 STRLEN len = HeKLEN(oent);
1378 int flags = HeKFLAGS(oent);
1381 HeVAL(ent) = newSVsv(HeVAL(oent));
1383 = shared ? 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 I32 riter = HvRITER(ohv);
1403 HE *eiter = HvEITER(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(ohv) = riter;
1417 HvEITER(ohv) = eiter;
1424 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1431 if (val && isGV(val) && GvCVu(val) && HvNAME(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(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)
1475 register XPVHV* xhv;
1479 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1481 xhv = (XPVHV*)SvANY(hv);
1483 if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
1484 /* restricted hash: convert all keys to placeholders */
1487 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1488 entry = ((HE**)xhv->xhv_array)[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 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1508 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1509 if (xhv->xhv_array /* HvARRAY(hv) */)
1510 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1511 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1516 HvHASKFLAGS_off(hv);
1521 =for apidoc hv_clear_placeholders
1523 Clears any placeholders from a hash. If a restricted hash has any of its keys
1524 marked as readonly and the key is subsequently deleted, the key is not actually
1525 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1526 it so it will be ignored by future operations such as iterating over the hash,
1527 but will still allow the hash to have a value reaasigned to the key at some
1528 future point. This function clears any such placeholder keys from the hash.
1529 See Hash::Util::lock_keys() for an example of its use.
1535 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1538 items = (I32)HvPLACEHOLDERS(hv);
1541 I32 riter = HvRITER(hv);
1542 HE *eiter = HvEITER(hv);
1544 /* This may look suboptimal with the items *after* the iternext, but
1545 it's quite deliberate. We only get here with items==0 if we've
1546 just deleted the last placeholder in the hash. If we've just done
1547 that then it means that the hash is in lazy delete mode, and the
1548 HE is now only referenced in our iterator. If we just quit the loop
1549 and discarded our iterator then the HE leaks. So we do the && the
1550 other way to ensure iternext is called just one more time, which
1551 has the side effect of triggering the lazy delete. */
1552 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1554 SV *val = hv_iterval(hv, entry);
1556 if (val == &PL_sv_placeholder) {
1558 /* It seems that I have to go back in the front of the hash
1559 API to delete a hash, even though I have a HE structure
1560 pointing to the very entry I want to delete, and could hold
1561 onto the previous HE that points to it. And it's easier to
1562 go in with SVs as I can then specify the precomputed hash,
1563 and don't have fun and games with utf8 keys. */
1564 SV *key = hv_iterkeysv(entry);
1566 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
1570 HvRITER(hv) = riter;
1571 HvEITER(hv) = eiter;
1576 S_hfreeentries(pTHX_ HV *hv)
1578 register HE **array;
1580 register HE *oentry = Null(HE*);
1591 array = HvARRAY(hv);
1592 /* make everyone else think the array is empty, so that the destructors
1593 * called for freed entries can't recusively mess with us */
1594 HvARRAY(hv) = Null(HE**);
1596 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1602 entry = HeNEXT(entry);
1603 hv_free_ent(hv, oentry);
1608 entry = array[riter];
1611 HvARRAY(hv) = array;
1612 (void)hv_iterinit(hv);
1616 =for apidoc hv_undef
1624 Perl_hv_undef(pTHX_ HV *hv)
1626 register XPVHV* xhv;
1629 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1630 xhv = (XPVHV*)SvANY(hv);
1632 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1635 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1636 Safefree(HvNAME(hv));
1639 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1640 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1641 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1648 =for apidoc hv_iterinit
1650 Prepares a starting point to traverse a hash table. Returns the number of
1651 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1652 currently only meaningful for hashes without tie magic.
1654 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1655 hash buckets that happen to be in use. If you still need that esoteric
1656 value, you can get it through the macro C<HvFILL(tb)>.
1663 Perl_hv_iterinit(pTHX_ HV *hv)
1665 register XPVHV* xhv;
1669 Perl_croak(aTHX_ "Bad hash");
1670 xhv = (XPVHV*)SvANY(hv);
1671 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1672 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1674 hv_free_ent(hv, entry);
1676 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1677 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1678 /* used to be xhv->xhv_fill before 5.004_65 */
1679 return XHvTOTALKEYS(xhv);
1682 =for apidoc hv_iternext
1684 Returns entries from a hash iterator. See C<hv_iterinit>.
1686 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1687 iterator currently points to, without losing your place or invalidating your
1688 iterator. Note that in this case the current entry is deleted from the hash
1689 with your iterator holding the last reference to it. Your iterator is flagged
1690 to free the entry on the next call to C<hv_iternext>, so you must not discard
1691 your iterator immediately else the entry will leak - call C<hv_iternext> to
1692 trigger the resource deallocation.
1698 Perl_hv_iternext(pTHX_ HV *hv)
1700 return hv_iternext_flags(hv, 0);
1704 =for apidoc hv_iternext_flags
1706 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1707 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1708 set the placeholders keys (for restricted hashes) will be returned in addition
1709 to normal keys. By default placeholders are automatically skipped over.
1710 Currently a placeholder is implemented with a value that is
1711 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1712 restricted hashes may change, and the implementation currently is
1713 insufficiently abstracted for any change to be tidy.
1719 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1721 register XPVHV* xhv;
1727 Perl_croak(aTHX_ "Bad hash");
1728 xhv = (XPVHV*)SvANY(hv);
1729 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1731 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1732 SV *key = sv_newmortal();
1734 sv_setsv(key, HeSVKEY_force(entry));
1735 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1741 /* one HE per MAGICAL hash */
1742 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1744 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1746 HeKEY_hek(entry) = hek;
1747 HeKLEN(entry) = HEf_SVKEY;
1749 magic_nextpack((SV*) hv,mg,key);
1751 /* force key to stay around until next time */
1752 HeSVKEY_set(entry, SvREFCNT_inc(key));
1753 return entry; /* beware, hent_val is not set */
1756 SvREFCNT_dec(HeVAL(entry));
1757 Safefree(HeKEY_hek(entry));
1759 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1762 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1763 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1767 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1768 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1769 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1771 /* At start of hash, entry is NULL. */
1774 entry = HeNEXT(entry);
1775 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1777 * Skip past any placeholders -- don't want to include them in
1780 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1781 entry = HeNEXT(entry);
1786 /* OK. Come to the end of the current list. Grab the next one. */
1788 xhv->xhv_riter++; /* HvRITER(hv)++ */
1789 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1790 /* There is no next one. End of the hash. */
1791 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1794 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1795 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1797 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1798 /* If we have an entry, but it's a placeholder, don't count it.
1800 while (entry && HeVAL(entry) == &PL_sv_placeholder)
1801 entry = HeNEXT(entry);
1803 /* Will loop again if this linked list starts NULL
1804 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1805 or if we run through it and find only placeholders. */
1808 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1810 hv_free_ent(hv, oldentry);
1813 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1814 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1816 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1821 =for apidoc hv_iterkey
1823 Returns the key from the current position of the hash iterator. See
1830 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1832 if (HeKLEN(entry) == HEf_SVKEY) {
1834 char *p = SvPV(HeKEY_sv(entry), len);
1839 *retlen = HeKLEN(entry);
1840 return HeKEY(entry);
1844 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1846 =for apidoc hv_iterkeysv
1848 Returns the key as an C<SV*> from the current position of the hash
1849 iterator. The return value will always be a mortal copy of the key. Also
1856 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1858 if (HeKLEN(entry) != HEf_SVKEY) {
1859 HEK *hek = HeKEY_hek(entry);
1860 int flags = HEK_FLAGS(hek);
1863 if (flags & HVhek_WASUTF8) {
1865 Andreas would like keys he put in as utf8 to come back as utf8
1867 STRLEN utf8_len = HEK_LEN(hek);
1868 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1870 sv = newSVpvn ((char*)as_utf8, utf8_len);
1872 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1873 } else if (flags & HVhek_REHASH) {
1874 /* We don't have a pointer to the hv, so we have to replicate the
1875 flag into every HEK. This hv is using custom a hasing
1876 algorithm. Hence we can't return a shared string scalar, as
1877 that would contain the (wrong) hash value, and might get passed
1878 into an hv routine with a regular hash */
1880 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
1884 sv = newSVpvn_share(HEK_KEY(hek),
1885 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1888 return sv_2mortal(sv);
1890 return sv_mortalcopy(HeKEY_sv(entry));
1894 =for apidoc hv_iterval
1896 Returns the value from the current position of the hash iterator. See
1903 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1905 if (SvRMAGICAL(hv)) {
1906 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1907 SV* sv = sv_newmortal();
1908 if (HeKLEN(entry) == HEf_SVKEY)
1909 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1910 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1914 return HeVAL(entry);
1918 =for apidoc hv_iternextsv
1920 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1927 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1930 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
1932 *key = hv_iterkey(he, retlen);
1933 return hv_iterval(hv, he);
1937 =for apidoc hv_magic
1939 Adds magic to a hash. See C<sv_magic>.
1945 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1947 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1950 #if 0 /* use the macro from hv.h instead */
1953 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1955 return HEK_KEY(share_hek(sv, len, hash));
1960 /* possibly free a shared string if no one has access to it
1961 * len and hash must both be valid for str.
1964 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1966 unshare_hek_or_pvn (NULL, str, len, hash);
1971 Perl_unshare_hek(pTHX_ HEK *hek)
1973 unshare_hek_or_pvn(hek, NULL, 0, 0);
1976 /* possibly free a shared string if no one has access to it
1977 hek if non-NULL takes priority over the other 3, else str, len and hash
1978 are used. If so, len and hash must both be valid for str.
1981 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
1983 register XPVHV* xhv;
1985 register HE **oentry;
1988 bool is_utf8 = FALSE;
1990 const char *save = str;
1993 hash = HEK_HASH(hek);
1994 } else if (len < 0) {
1995 STRLEN tmplen = -len;
1997 /* See the note in hv_fetch(). --jhi */
1998 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2001 k_flags = HVhek_UTF8;
2003 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2006 /* what follows is the moral equivalent of:
2007 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2008 if (--*Svp == Nullsv)
2009 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2011 xhv = (XPVHV*)SvANY(PL_strtab);
2012 /* assert(xhv_array != 0) */
2014 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2015 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2017 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2018 if (HeKEY_hek(entry) != hek)
2024 int flags_masked = k_flags & HVhek_MASK;
2025 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2026 if (HeHASH(entry) != hash) /* strings can't be equal */
2028 if (HeKLEN(entry) != len)
2030 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2032 if (HeKFLAGS(entry) != flags_masked)
2040 if (--HeVAL(entry) == Nullsv) {
2041 *oentry = HeNEXT(entry);
2043 xhv->xhv_fill--; /* HvFILL(hv)-- */
2044 Safefree(HeKEY_hek(entry));
2046 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2050 UNLOCK_STRTAB_MUTEX;
2051 if (!found && ckWARN_d(WARN_INTERNAL))
2052 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2053 "Attempt to free non-existent shared string '%s'%s",
2054 hek ? HEK_KEY(hek) : str,
2055 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2056 if (k_flags & HVhek_FREEKEY)
2060 /* get a (constant) string ptr from the global string table
2061 * string will get added if it is not already there.
2062 * len and hash must both be valid for str.
2065 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2067 bool is_utf8 = FALSE;
2069 const char *save = str;
2072 STRLEN tmplen = -len;
2074 /* See the note in hv_fetch(). --jhi */
2075 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2077 /* If we were able to downgrade here, then than means that we were passed
2078 in a key which only had chars 0-255, but was utf8 encoded. */
2081 /* If we found we were able to downgrade the string to bytes, then
2082 we should flag that it needs upgrading on keys or each. Also flag
2083 that we need share_hek_flags to free the string. */
2085 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2088 return share_hek_flags (str, len, hash, flags);
2092 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2094 register XPVHV* xhv;
2096 register HE **oentry;
2099 int flags_masked = flags & HVhek_MASK;
2101 /* what follows is the moral equivalent of:
2103 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2104 hv_store(PL_strtab, str, len, Nullsv, hash);
2106 Can't rehash the shared string table, so not sure if it's worth
2107 counting the number of entries in the linked list
2109 xhv = (XPVHV*)SvANY(PL_strtab);
2110 /* assert(xhv_array != 0) */
2112 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2113 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2114 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2115 if (HeHASH(entry) != hash) /* strings can't be equal */
2117 if (HeKLEN(entry) != len)
2119 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2121 if (HeKFLAGS(entry) != flags_masked)
2128 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2129 HeVAL(entry) = Nullsv;
2130 HeNEXT(entry) = *oentry;
2132 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2133 if (i) { /* initial entry? */
2134 xhv->xhv_fill++; /* HvFILL(hv)++ */
2135 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2140 ++HeVAL(entry); /* use value slot as REFCNT */
2141 UNLOCK_STRTAB_MUTEX;
2143 if (flags & HVhek_FREEKEY)
2146 return HeKEY_hek(entry);
2151 =for apidoc hv_assert
2153 Check that a hash is in an internally consistent state.
2159 Perl_hv_assert(pTHX_ HV *hv)
2163 int placeholders = 0;
2166 I32 riter = HvRITER(hv);
2167 HE *eiter = HvEITER(hv);
2169 (void)hv_iterinit(hv);
2171 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2172 /* sanity check the values */
2173 if (HeVAL(entry) == &PL_sv_placeholder) {
2178 /* sanity check the keys */
2179 if (HeSVKEY(entry)) {
2180 /* Don't know what to check on SV keys. */
2181 } else if (HeKUTF8(entry)) {
2183 if (HeKWASUTF8(entry)) {
2184 PerlIO_printf(Perl_debug_log,
2185 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2186 (int) HeKLEN(entry), HeKEY(entry));
2189 } else if (HeKWASUTF8(entry)) {
2193 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2194 if (HvUSEDKEYS(hv) != real) {
2195 PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2196 (int) real, (int) HvUSEDKEYS(hv));
2199 if (HvPLACEHOLDERS(hv) != placeholders) {
2200 PerlIO_printf(Perl_debug_log,
2201 "Count %d placeholder(s), but hash reports %d\n",
2202 (int) placeholders, (int) HvPLACEHOLDERS(hv));
2206 if (withflags && ! HvHASKFLAGS(hv)) {
2207 PerlIO_printf(Perl_debug_log,
2208 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2215 HvRITER(hv) = riter; /* Restore hash iterator state */
2216 HvEITER(hv) = eiter;