3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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
36 static const char S_strtab_error[]
37 = "Cannot modify shared string table in hv_%s";
46 he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE);
48 heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
49 PL_body_roots[HE_SVSLOT] = he;
51 HeNEXT(he) = (HE*)(he + 1);
59 #define new_HE() (HE*)safemalloc(sizeof(HE))
60 #define del_HE(p) safefree((char*)p)
69 void ** const root = &PL_body_roots[HE_SVSLOT];
81 #define new_HE() new_he()
85 HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \
86 PL_body_roots[HE_SVSLOT] = p; \
95 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
97 const int flags_masked = flags & HVhek_MASK;
101 Newx(k, HEK_BASESIZE + len + 2, char);
103 Copy(str, HEK_KEY(hek), len, char);
104 HEK_KEY(hek)[len] = 0;
106 HEK_HASH(hek) = hash;
107 HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
109 if (flags & HVhek_FREEKEY)
114 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
118 Perl_free_tied_hv_pool(pTHX)
121 HE *he = PL_hv_fetch_ent_mh;
124 Safefree(HeKEY_hek(he));
128 PL_hv_fetch_ent_mh = NULL;
131 #if defined(USE_ITHREADS)
133 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
135 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
137 PERL_UNUSED_ARG(param);
140 /* We already shared this hash key. */
141 (void)share_hek_hek(shared);
145 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
146 HEK_HASH(source), HEK_FLAGS(source));
147 ptr_table_store(PL_ptr_table, source, shared);
153 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
159 /* look for it in the table first */
160 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
164 /* create anew and remember what it is */
166 ptr_table_store(PL_ptr_table, e, ret);
168 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
169 if (HeKLEN(e) == HEf_SVKEY) {
171 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
172 HeKEY_hek(ret) = (HEK*)k;
173 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
176 /* This is hek_dup inlined, which seems to be important for speed
178 HEK * const source = HeKEY_hek(e);
179 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
182 /* We already shared this hash key. */
183 (void)share_hek_hek(shared);
187 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
188 HEK_HASH(source), HEK_FLAGS(source));
189 ptr_table_store(PL_ptr_table, source, shared);
191 HeKEY_hek(ret) = shared;
194 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
196 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
199 #endif /* USE_ITHREADS */
202 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
205 SV * const sv = sv_newmortal();
206 if (!(flags & HVhek_FREEKEY)) {
207 sv_setpvn(sv, key, klen);
210 /* Need to free saved eventually assign to mortal SV */
211 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
212 sv_usepvn(sv, (char *) key, klen);
214 if (flags & HVhek_UTF8) {
217 Perl_croak(aTHX_ msg, sv);
220 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
223 #define HV_FETCH_ISSTORE 0x01
224 #define HV_FETCH_ISEXISTS 0x02
225 #define HV_FETCH_LVALUE 0x04
226 #define HV_FETCH_JUST_SV 0x08
231 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
232 the length of the key. The C<hash> parameter is the precomputed hash
233 value; if it is zero then Perl will compute it. The return value will be
234 NULL if the operation failed or if the value did not need to be actually
235 stored within the hash (as in the case of tied hashes). Otherwise it can
236 be dereferenced to get the original C<SV*>. Note that the caller is
237 responsible for suitably incrementing the reference count of C<val> before
238 the call, and decrementing it if the function returned NULL. Effectively
239 a successful hv_store takes ownership of one reference to C<val>. This is
240 usually what you want; a newly created SV has a reference count of one, so
241 if all your code does is create SVs then store them in a hash, hv_store
242 will own the only reference to the new SV, and your code doesn't need to do
243 anything further to tidy up. hv_store is not implemented as a call to
244 hv_store_ent, and does not create a temporary SV for the key, so if your
245 key data is not already in SV form then use hv_store in preference to
248 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
249 information on how to use this function on tied hashes.
255 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
268 hek = hv_fetch_common (hv, NULL, key, klen, flags,
269 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
270 return hek ? &HeVAL(hek) : NULL;
273 /* XXX This looks like an ideal candidate to inline */
275 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
276 register U32 hash, int flags)
278 HE * const hek = hv_fetch_common (hv, NULL, key, klen, flags,
279 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
280 return hek ? &HeVAL(hek) : NULL;
284 =for apidoc hv_store_ent
286 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
287 parameter is the precomputed hash value; if it is zero then Perl will
288 compute it. The return value is the new hash entry so created. It will be
289 NULL if the operation failed or if the value did not need to be actually
290 stored within the hash (as in the case of tied hashes). Otherwise the
291 contents of the return value can be accessed using the C<He?> macros
292 described here. Note that the caller is responsible for suitably
293 incrementing the reference count of C<val> before the call, and
294 decrementing it if the function returned NULL. Effectively a successful
295 hv_store_ent takes ownership of one reference to C<val>. This is
296 usually what you want; a newly created SV has a reference count of one, so
297 if all your code does is create SVs then store them in a hash, hv_store
298 will own the only reference to the new SV, and your code doesn't need to do
299 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
300 unlike C<val> it does not take ownership of it, so maintaining the correct
301 reference count on C<key> is entirely the caller's responsibility. hv_store
302 is not implemented as a call to hv_store_ent, and does not create a temporary
303 SV for the key, so if your key data is not already in SV form then use
304 hv_store in preference to hv_store_ent.
306 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
307 information on how to use this function on tied hashes.
312 /* XXX This looks like an ideal candidate to inline */
314 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
316 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
320 =for apidoc hv_exists
322 Returns a boolean indicating whether the specified hash key exists. The
323 C<klen> is the length of the key.
329 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
341 return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
348 Returns the SV which corresponds to the specified key in the hash. The
349 C<klen> is the length of the key. If C<lval> is set then the fetch will be
350 part of a store. Check that the return value is non-null before
351 dereferencing it to an C<SV*>.
353 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
354 information on how to use this function on tied hashes.
360 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
373 hek = hv_fetch_common (hv, NULL, key, klen, flags,
374 lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) : HV_FETCH_JUST_SV,
376 return hek ? &HeVAL(hek) : NULL;
380 =for apidoc hv_exists_ent
382 Returns a boolean indicating whether the specified hash key exists. C<hash>
383 can be a valid precomputed hash value, or 0 to ask for it to be
389 /* XXX This looks like an ideal candidate to inline */
391 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
393 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
397 /* returns an HE * structure with the all fields set */
398 /* note that hent_val will be a mortal sv for MAGICAL hashes */
400 =for apidoc hv_fetch_ent
402 Returns the hash entry which corresponds to the specified key in the hash.
403 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
404 if you want the function to compute it. IF C<lval> is set then the fetch
405 will be part of a store. Make sure the return value is non-null before
406 accessing it. The return value when C<tb> is a tied hash is a pointer to a
407 static location, so be sure to make a copy of the structure if you need to
410 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
411 information on how to use this function on tied hashes.
417 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
419 return hv_fetch_common(hv, keysv, NULL, 0, 0,
420 (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
424 S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
425 int flags, int action, SV *val, register U32 hash)
439 if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
440 keysv = hv_magic_uvar_xkey(hv, keysv, action);
441 if (flags & HVhek_FREEKEY)
443 key = SvPV_const(keysv, klen);
445 is_utf8 = (SvUTF8(keysv) != 0);
447 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
450 xhv = (XPVHV*)SvANY(hv);
452 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
453 MAGIC *regdata = NULL;
454 if (( regdata = mg_find((SV*)hv, PERL_MAGIC_regdata_names)) ||
455 mg_find((SV*)hv, PERL_MAGIC_tied) ||
458 /* XXX should be able to skimp on the HE/HEK here when
459 HV_FETCH_JUST_SV is true. */
461 keysv = newSVpvn(key, klen);
466 keysv = newSVsv(keysv);
469 sv = Perl_reg_named_buff_sv(aTHX_ keysv);
476 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
479 /* grab a fake HE/HEK pair from the pool or make a new one */
480 entry = PL_hv_fetch_ent_mh;
482 PL_hv_fetch_ent_mh = HeNEXT(entry);
486 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
487 HeKEY_hek(entry) = (HEK*)k;
489 HeNEXT(entry) = NULL;
490 HeSVKEY_set(entry, keysv);
492 sv_upgrade(sv, SVt_PVLV);
494 /* so we can free entry when freeing sv */
495 LvTARG(sv) = (SV*)entry;
497 /* XXX remove at some point? */
498 if (flags & HVhek_FREEKEY)
503 #ifdef ENV_IS_CASELESS
504 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
506 for (i = 0; i < klen; ++i)
507 if (isLOWER(key[i])) {
508 /* Would be nice if we had a routine to do the
509 copy and upercase in a single pass through. */
510 const char * const nkey = strupr(savepvn(key,klen));
511 /* Note that this fetch is for nkey (the uppercased
512 key) whereas the store is for key (the original) */
513 entry = hv_fetch_common(hv, NULL, nkey, klen,
514 HVhek_FREEKEY, /* free nkey */
515 0 /* non-LVAL fetch */,
517 0 /* compute hash */);
518 if (!entry && (action & HV_FETCH_LVALUE)) {
519 /* This call will free key if necessary.
520 Do it this way to encourage compiler to tail
522 entry = hv_fetch_common(hv, keysv, key, klen,
523 flags, HV_FETCH_ISSTORE,
526 if (flags & HVhek_FREEKEY)
534 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
535 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
536 /* I don't understand why hv_exists_ent has svret and sv,
537 whereas hv_exists only had one. */
538 SV * const svret = sv_newmortal();
541 if (keysv || is_utf8) {
543 keysv = newSVpvn(key, klen);
546 keysv = newSVsv(keysv);
548 mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
550 mg_copy((SV*)hv, sv, key, klen);
552 if (flags & HVhek_FREEKEY)
554 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
555 /* This cast somewhat evil, but I'm merely using NULL/
556 not NULL to return the boolean exists.
557 And I know hv is not NULL. */
558 return SvTRUE(svret) ? (HE *)hv : NULL;
560 #ifdef ENV_IS_CASELESS
561 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
562 /* XXX This code isn't UTF8 clean. */
563 char * const keysave = (char * const)key;
564 /* Will need to free this, so set FREEKEY flag. */
565 key = savepvn(key,klen);
566 key = (const char*)strupr((char*)key);
571 if (flags & HVhek_FREEKEY) {
574 flags |= HVhek_FREEKEY;
578 else if (action & HV_FETCH_ISSTORE) {
581 hv_magic_check (hv, &needs_copy, &needs_store);
583 const bool save_taint = PL_tainted;
584 if (keysv || is_utf8) {
586 keysv = newSVpvn(key, klen);
590 PL_tainted = SvTAINTED(keysv);
591 keysv = sv_2mortal(newSVsv(keysv));
592 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
594 mg_copy((SV*)hv, val, key, klen);
597 TAINT_IF(save_taint);
599 if (flags & HVhek_FREEKEY)
603 #ifdef ENV_IS_CASELESS
604 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
605 /* XXX This code isn't UTF8 clean. */
606 const char *keysave = key;
607 /* Will need to free this, so set FREEKEY flag. */
608 key = savepvn(key,klen);
609 key = (const char*)strupr((char*)key);
614 if (flags & HVhek_FREEKEY) {
617 flags |= HVhek_FREEKEY;
625 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
626 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
627 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
632 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
634 HvARRAY(hv) = (HE**)array;
636 #ifdef DYNAMIC_ENV_FETCH
637 else if (action & HV_FETCH_ISEXISTS) {
638 /* for an %ENV exists, if we do an insert it's by a recursive
639 store call, so avoid creating HvARRAY(hv) right now. */
643 /* XXX remove at some point? */
644 if (flags & HVhek_FREEKEY)
652 char * const keysave = (char *)key;
653 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
657 flags &= ~HVhek_UTF8;
658 if (key != keysave) {
659 if (flags & HVhek_FREEKEY)
661 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
666 PERL_HASH_INTERNAL(hash, key, klen);
667 /* We don't have a pointer to the hv, so we have to replicate the
668 flag into every HEK, so that hv_iterkeysv can see it. */
669 /* And yes, you do need this even though you are not "storing" because
670 you can flip the flags below if doing an lval lookup. (And that
671 was put in to give the semantics Andreas was expecting.) */
672 flags |= HVhek_REHASH;
674 if (keysv && (SvIsCOW_shared_hash(keysv))) {
675 hash = SvSHARED_HASH(keysv);
677 PERL_HASH(hash, key, klen);
681 masked_flags = (flags & HVhek_MASK);
683 #ifdef DYNAMIC_ENV_FETCH
684 if (!HvARRAY(hv)) entry = NULL;
688 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
690 for (; entry; entry = HeNEXT(entry)) {
691 if (HeHASH(entry) != hash) /* strings can't be equal */
693 if (HeKLEN(entry) != (I32)klen)
695 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
697 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
700 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
701 if (HeKFLAGS(entry) != masked_flags) {
702 /* We match if HVhek_UTF8 bit in our flags and hash key's
703 match. But if entry was set previously with HVhek_WASUTF8
704 and key now doesn't (or vice versa) then we should change
705 the key's flag, as this is assignment. */
706 if (HvSHAREKEYS(hv)) {
707 /* Need to swap the key we have for a key with the flags we
708 need. As keys are shared we can't just write to the
709 flag, so we share the new one, unshare the old one. */
710 HEK * const new_hek = share_hek_flags(key, klen, hash,
712 unshare_hek (HeKEY_hek(entry));
713 HeKEY_hek(entry) = new_hek;
715 else if (hv == PL_strtab) {
716 /* PL_strtab is usually the only hash without HvSHAREKEYS,
717 so putting this test here is cheap */
718 if (flags & HVhek_FREEKEY)
720 Perl_croak(aTHX_ S_strtab_error,
721 action & HV_FETCH_LVALUE ? "fetch" : "store");
724 HeKFLAGS(entry) = masked_flags;
725 if (masked_flags & HVhek_ENABLEHVKFLAGS)
728 if (HeVAL(entry) == &PL_sv_placeholder) {
729 /* yes, can store into placeholder slot */
730 if (action & HV_FETCH_LVALUE) {
732 /* This preserves behaviour with the old hv_fetch
733 implementation which at this point would bail out
734 with a break; (at "if we find a placeholder, we
735 pretend we haven't found anything")
737 That break mean that if a placeholder were found, it
738 caused a call into hv_store, which in turn would
739 check magic, and if there is no magic end up pretty
740 much back at this point (in hv_store's code). */
743 /* LVAL fetch which actaully needs a store. */
745 HvPLACEHOLDERS(hv)--;
748 if (val != &PL_sv_placeholder)
749 HvPLACEHOLDERS(hv)--;
752 } else if (action & HV_FETCH_ISSTORE) {
753 SvREFCNT_dec(HeVAL(entry));
756 } else if (HeVAL(entry) == &PL_sv_placeholder) {
757 /* if we find a placeholder, we pretend we haven't found
761 if (flags & HVhek_FREEKEY)
765 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
766 if (!(action & HV_FETCH_ISSTORE)
767 && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
769 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
771 sv = newSVpvn(env,len);
773 return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
779 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
780 hv_notallowed(flags, key, klen,
781 "Attempt to access disallowed key '%"SVf"' in"
782 " a restricted hash");
784 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
785 /* Not doing some form of store, so return failure. */
786 if (flags & HVhek_FREEKEY)
790 if (action & HV_FETCH_LVALUE) {
793 /* At this point the old hv_fetch code would call to hv_store,
794 which in turn might do some tied magic. So we need to make that
795 magic check happen. */
796 /* gonna assign to this, so it better be there */
797 return hv_fetch_common(hv, keysv, key, klen, flags,
798 HV_FETCH_ISSTORE, val, hash);
799 /* XXX Surely that could leak if the fetch-was-store fails?
800 Just like the hv_fetch. */
804 /* Welcome to hv_store... */
807 /* Not sure if we can get here. I think the only case of oentry being
808 NULL is for %ENV with dynamic env fetch. But that should disappear
809 with magic in the previous code. */
812 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
814 HvARRAY(hv) = (HE**)array;
817 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
820 /* share_hek_flags will do the free for us. This might be considered
823 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
824 else if (hv == PL_strtab) {
825 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
826 this test here is cheap */
827 if (flags & HVhek_FREEKEY)
829 Perl_croak(aTHX_ S_strtab_error,
830 action & HV_FETCH_LVALUE ? "fetch" : "store");
832 else /* gotta do the real thing */
833 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
835 HeNEXT(entry) = *oentry;
838 if (val == &PL_sv_placeholder)
839 HvPLACEHOLDERS(hv)++;
840 if (masked_flags & HVhek_ENABLEHVKFLAGS)
844 const HE *counter = HeNEXT(entry);
846 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
847 if (!counter) { /* initial entry? */
848 xhv->xhv_fill++; /* HvFILL(hv)++ */
849 } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
851 } else if(!HvREHASH(hv)) {
854 while ((counter = HeNEXT(counter)))
857 if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
858 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
859 bucket splits on a rehashed hash, as we're not going to
860 split it again, and if someone is lucky (evil) enough to
861 get all the keys in one list they could exhaust our memory
862 as we repeatedly double the number of buckets on every
863 entry. Linear search feels a less worse thing to do. */
873 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
875 const MAGIC *mg = SvMAGIC(hv);
879 if (isUPPER(mg->mg_type)) {
881 if (mg->mg_type == PERL_MAGIC_tied) {
882 *needs_store = FALSE;
883 return; /* We've set all there is to set. */
886 mg = mg->mg_moremagic;
891 =for apidoc hv_scalar
893 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
899 Perl_hv_scalar(pTHX_ HV *hv)
903 if (SvRMAGICAL(hv)) {
904 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
906 return magic_scalarpack(hv, mg);
911 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
912 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
920 =for apidoc hv_delete
922 Deletes a key/value pair in the hash. The value SV is removed from the
923 hash and returned to the caller. The C<klen> is the length of the key.
924 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
931 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
938 k_flags = HVhek_UTF8;
943 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
947 =for apidoc hv_delete_ent
949 Deletes a key/value pair in the hash. The value SV is removed from the
950 hash and returned to the caller. The C<flags> value will normally be zero;
951 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
952 precomputed hash value, or 0 to ask for it to be computed.
957 /* XXX This looks like an ideal candidate to inline */
959 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
961 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
965 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
966 int k_flags, I32 d_flags, U32 hash)
971 register HE **oentry;
972 HE *const *first_entry;
980 if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
981 keysv = hv_magic_uvar_xkey(hv, keysv, -1);
982 if (k_flags & HVhek_FREEKEY)
984 key = SvPV_const(keysv, klen);
986 is_utf8 = (SvUTF8(keysv) != 0);
988 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
991 if (SvRMAGICAL(hv)) {
994 hv_magic_check (hv, &needs_copy, &needs_store);
998 entry = hv_fetch_common(hv, keysv, key, klen,
999 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
1001 sv = entry ? HeVAL(entry) : NULL;
1003 if (SvMAGICAL(sv)) {
1007 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1008 /* No longer an element */
1009 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1012 return NULL; /* element cannot be deleted */
1014 #ifdef ENV_IS_CASELESS
1015 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1016 /* XXX This code isn't UTF8 clean. */
1017 keysv = sv_2mortal(newSVpvn(key,klen));
1018 if (k_flags & HVhek_FREEKEY) {
1021 key = strupr(SvPVX(keysv));
1030 xhv = (XPVHV*)SvANY(hv);
1035 const char * const keysave = key;
1036 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1039 k_flags |= HVhek_UTF8;
1041 k_flags &= ~HVhek_UTF8;
1042 if (key != keysave) {
1043 if (k_flags & HVhek_FREEKEY) {
1044 /* This shouldn't happen if our caller does what we expect,
1045 but strictly the API allows it. */
1048 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1050 HvHASKFLAGS_on((SV*)hv);
1054 PERL_HASH_INTERNAL(hash, key, klen);
1056 if (keysv && (SvIsCOW_shared_hash(keysv))) {
1057 hash = SvSHARED_HASH(keysv);
1059 PERL_HASH(hash, key, klen);
1063 masked_flags = (k_flags & HVhek_MASK);
1065 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1067 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1069 if (HeHASH(entry) != hash) /* strings can't be equal */
1071 if (HeKLEN(entry) != (I32)klen)
1073 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1075 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1078 if (hv == PL_strtab) {
1079 if (k_flags & HVhek_FREEKEY)
1081 Perl_croak(aTHX_ S_strtab_error, "delete");
1084 /* if placeholder is here, it's already been deleted.... */
1085 if (HeVAL(entry) == &PL_sv_placeholder) {
1086 if (k_flags & HVhek_FREEKEY)
1090 if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1091 hv_notallowed(k_flags, key, klen,
1092 "Attempt to delete readonly key '%"SVf"' from"
1093 " a restricted hash");
1095 if (k_flags & HVhek_FREEKEY)
1098 if (d_flags & G_DISCARD)
1101 sv = sv_2mortal(HeVAL(entry));
1102 HeVAL(entry) = &PL_sv_placeholder;
1106 * If a restricted hash, rather than really deleting the entry, put
1107 * a placeholder there. This marks the key as being "approved", so
1108 * we can still access via not-really-existing key without raising
1111 if (SvREADONLY(hv)) {
1112 SvREFCNT_dec(HeVAL(entry));
1113 HeVAL(entry) = &PL_sv_placeholder;
1114 /* We'll be saving this slot, so the number of allocated keys
1115 * doesn't go down, but the number placeholders goes up */
1116 HvPLACEHOLDERS(hv)++;
1118 *oentry = HeNEXT(entry);
1120 xhv->xhv_fill--; /* HvFILL(hv)-- */
1122 if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1125 hv_free_ent(hv, entry);
1126 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1127 if (xhv->xhv_keys == 0)
1128 HvHASKFLAGS_off(hv);
1132 if (SvREADONLY(hv)) {
1133 hv_notallowed(k_flags, key, klen,
1134 "Attempt to delete disallowed key '%"SVf"' from"
1135 " a restricted hash");
1138 if (k_flags & HVhek_FREEKEY)
1144 S_hsplit(pTHX_ HV *hv)
1147 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1148 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1149 register I32 newsize = oldsize * 2;
1151 char *a = (char*) HvARRAY(hv);
1153 register HE **oentry;
1154 int longest_chain = 0;
1157 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1158 hv, (int) oldsize);*/
1160 if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1161 /* Can make this clear any placeholders first for non-restricted hashes,
1162 even though Storable rebuilds restricted hashes by putting in all the
1163 placeholders (first) before turning on the readonly flag, because
1164 Storable always pre-splits the hash. */
1165 hv_clear_placeholders(hv);
1169 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1170 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1171 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1177 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1180 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1181 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1186 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1188 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1190 if (oldsize >= 64) {
1191 offer_nice_chunk(HvARRAY(hv),
1192 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1193 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1196 Safefree(HvARRAY(hv));
1200 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1201 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1202 HvARRAY(hv) = (HE**) a;
1205 for (i=0; i<oldsize; i++,aep++) {
1206 int left_length = 0;
1207 int right_length = 0;
1211 if (!*aep) /* non-existent */
1214 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1215 if ((HeHASH(entry) & newsize) != (U32)i) {
1216 *oentry = HeNEXT(entry);
1217 HeNEXT(entry) = *bep;
1219 xhv->xhv_fill++; /* HvFILL(hv)++ */
1225 oentry = &HeNEXT(entry);
1229 if (!*aep) /* everything moved */
1230 xhv->xhv_fill--; /* HvFILL(hv)-- */
1231 /* I think we don't actually need to keep track of the longest length,
1232 merely flag if anything is too long. But for the moment while
1233 developing this code I'll track it. */
1234 if (left_length > longest_chain)
1235 longest_chain = left_length;
1236 if (right_length > longest_chain)
1237 longest_chain = right_length;
1241 /* Pick your policy for "hashing isn't working" here: */
1242 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
1247 if (hv == PL_strtab) {
1248 /* Urg. Someone is doing something nasty to the string table.
1253 /* Awooga. Awooga. Pathological data. */
1254 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1255 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1258 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1259 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1261 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1264 was_shared = HvSHAREKEYS(hv);
1267 HvSHAREKEYS_off(hv);
1272 for (i=0; i<newsize; i++,aep++) {
1273 register HE *entry = *aep;
1275 /* We're going to trash this HE's next pointer when we chain it
1276 into the new hash below, so store where we go next. */
1277 HE * const next = HeNEXT(entry);
1282 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1287 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1288 hash, HeKFLAGS(entry));
1289 unshare_hek (HeKEY_hek(entry));
1290 HeKEY_hek(entry) = new_hek;
1292 /* Not shared, so simply write the new hash in. */
1293 HeHASH(entry) = hash;
1295 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1296 HEK_REHASH_on(HeKEY_hek(entry));
1297 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1299 /* Copy oentry to the correct new chain. */
1300 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1302 xhv->xhv_fill++; /* HvFILL(hv)++ */
1303 HeNEXT(entry) = *bep;
1309 Safefree (HvARRAY(hv));
1310 HvARRAY(hv) = (HE **)a;
1314 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1317 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1318 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1319 register I32 newsize;
1324 register HE **oentry;
1326 newsize = (I32) newmax; /* possible truncation here */
1327 if (newsize != newmax || newmax <= oldsize)
1329 while ((newsize & (1 + ~newsize)) != newsize) {
1330 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1332 if (newsize < newmax)
1334 if (newsize < newmax)
1335 return; /* overflow detection */
1337 a = (char *) HvARRAY(hv);
1340 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1341 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1342 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1348 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1351 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1352 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1357 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1359 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1361 if (oldsize >= 64) {
1362 offer_nice_chunk(HvARRAY(hv),
1363 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1364 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1367 Safefree(HvARRAY(hv));
1370 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1373 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1375 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1376 HvARRAY(hv) = (HE **) a;
1377 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1381 for (i=0; i<oldsize; i++,aep++) {
1382 if (!*aep) /* non-existent */
1384 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1385 register I32 j = (HeHASH(entry) & newsize);
1389 *oentry = HeNEXT(entry);
1390 if (!(HeNEXT(entry) = aep[j]))
1391 xhv->xhv_fill++; /* HvFILL(hv)++ */
1396 oentry = &HeNEXT(entry);
1398 if (!*aep) /* everything moved */
1399 xhv->xhv_fill--; /* HvFILL(hv)-- */
1406 Creates a new HV. The reference count is set to 1.
1414 register XPVHV* xhv;
1415 HV * const hv = (HV*)newSV(0);
1417 sv_upgrade((SV *)hv, SVt_PVHV);
1418 xhv = (XPVHV*)SvANY(hv);
1421 #ifndef NODEFAULT_SHAREKEYS
1422 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1425 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1426 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1431 Perl_newHVhv(pTHX_ HV *ohv)
1433 HV * const hv = newHV();
1434 STRLEN hv_max, hv_fill;
1436 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1438 hv_max = HvMAX(ohv);
1440 if (!SvMAGICAL((SV *)ohv)) {
1441 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1443 const bool shared = !!HvSHAREKEYS(ohv);
1444 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1446 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1449 /* In each bucket... */
1450 for (i = 0; i <= hv_max; i++) {
1452 HE *oent = oents[i];
1459 /* Copy the linked list of entries. */
1460 for (; oent; oent = HeNEXT(oent)) {
1461 const U32 hash = HeHASH(oent);
1462 const char * const key = HeKEY(oent);
1463 const STRLEN len = HeKLEN(oent);
1464 const int flags = HeKFLAGS(oent);
1465 HE * const ent = new_HE();
1467 HeVAL(ent) = newSVsv(HeVAL(oent));
1469 = shared ? share_hek_flags(key, len, hash, flags)
1470 : save_hek_flags(key, len, hash, flags);
1481 HvFILL(hv) = hv_fill;
1482 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1486 /* Iterate over ohv, copying keys and values one at a time. */
1488 const I32 riter = HvRITER_get(ohv);
1489 HE * const eiter = HvEITER_get(ohv);
1491 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1492 while (hv_max && hv_max + 1 >= hv_fill * 2)
1493 hv_max = hv_max / 2;
1497 while ((entry = hv_iternext_flags(ohv, 0))) {
1498 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1499 newSVsv(HeVAL(entry)), HeHASH(entry),
1502 HvRITER_set(ohv, riter);
1503 HvEITER_set(ohv, eiter);
1509 /* A rather specialised version of newHVhv for copying %^H, ensuring all the
1510 magic stays on it. */
1512 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1514 HV * const hv = newHV();
1517 if (ohv && (hv_fill = HvFILL(ohv))) {
1518 STRLEN hv_max = HvMAX(ohv);
1520 const I32 riter = HvRITER_get(ohv);
1521 HE * const eiter = HvEITER_get(ohv);
1523 while (hv_max && hv_max + 1 >= hv_fill * 2)
1524 hv_max = hv_max / 2;
1528 while ((entry = hv_iternext_flags(ohv, 0))) {
1529 SV *const sv = newSVsv(HeVAL(entry));
1530 sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1531 (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
1532 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1533 sv, HeHASH(entry), HeKFLAGS(entry));
1535 HvRITER_set(ohv, riter);
1536 HvEITER_set(ohv, eiter);
1538 hv_magic(hv, NULL, PERL_MAGIC_hints);
1543 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1551 if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
1552 PL_sub_generation++; /* may be deletion of method from stash */
1554 if (HeKLEN(entry) == HEf_SVKEY) {
1555 SvREFCNT_dec(HeKEY_sv(entry));
1556 Safefree(HeKEY_hek(entry));
1558 else if (HvSHAREKEYS(hv))
1559 unshare_hek(HeKEY_hek(entry));
1561 Safefree(HeKEY_hek(entry));
1566 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1571 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1572 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
1573 if (HeKLEN(entry) == HEf_SVKEY) {
1574 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1576 hv_free_ent(hv, entry);
1580 =for apidoc hv_clear
1582 Clears a hash, making it empty.
1588 Perl_hv_clear(pTHX_ HV *hv)
1591 register XPVHV* xhv;
1595 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1597 xhv = (XPVHV*)SvANY(hv);
1599 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1600 /* restricted hash: convert all keys to placeholders */
1602 for (i = 0; i <= xhv->xhv_max; i++) {
1603 HE *entry = (HvARRAY(hv))[i];
1604 for (; entry; entry = HeNEXT(entry)) {
1605 /* not already placeholder */
1606 if (HeVAL(entry) != &PL_sv_placeholder) {
1607 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1608 SV* const keysv = hv_iterkeysv(entry);
1610 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1613 SvREFCNT_dec(HeVAL(entry));
1614 HeVAL(entry) = &PL_sv_placeholder;
1615 HvPLACEHOLDERS(hv)++;
1623 HvPLACEHOLDERS_set(hv, 0);
1625 Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1630 HvHASKFLAGS_off(hv);
1634 HvEITER_set(hv, NULL);
1639 =for apidoc hv_clear_placeholders
1641 Clears any placeholders from a hash. If a restricted hash has any of its keys
1642 marked as readonly and the key is subsequently deleted, the key is not actually
1643 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1644 it so it will be ignored by future operations such as iterating over the hash,
1645 but will still allow the hash to have a value reassigned to the key at some
1646 future point. This function clears any such placeholder keys from the hash.
1647 See Hash::Util::lock_keys() for an example of its use.
1653 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1656 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1659 clear_placeholders(hv, items);
1663 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1673 /* Loop down the linked list heads */
1675 HE **oentry = &(HvARRAY(hv))[i];
1678 while ((entry = *oentry)) {
1679 if (HeVAL(entry) == &PL_sv_placeholder) {
1680 *oentry = HeNEXT(entry);
1681 if (first && !*oentry)
1682 HvFILL(hv)--; /* This linked list is now empty. */
1683 if (entry == HvEITER_get(hv))
1686 hv_free_ent(hv, entry);
1690 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1691 if (HvKEYS(hv) == 0)
1692 HvHASKFLAGS_off(hv);
1693 HvPLACEHOLDERS_set(hv, 0);
1697 oentry = &HeNEXT(entry);
1702 /* You can't get here, hence assertion should always fail. */
1703 assert (items == 0);
1708 S_hfreeentries(pTHX_ HV *hv)
1710 /* This is the array that we're going to restore */
1719 /* If the hash is actually a symbol table with a name, look after the
1721 struct xpvhv_aux *iter = HvAUX(hv);
1723 name = iter->xhv_name;
1724 iter->xhv_name = NULL;
1729 orig_array = HvARRAY(hv);
1730 /* orig_array remains unchanged throughout the loop. If after freeing all
1731 the entries it turns out that one of the little blighters has triggered
1732 an action that has caused HvARRAY to be re-allocated, then we set
1733 array to the new HvARRAY, and try again. */
1736 /* This is the one we're going to try to empty. First time round
1737 it's the original array. (Hopefully there will only be 1 time
1739 HE ** const array = HvARRAY(hv);
1742 /* Because we have taken xhv_name out, the only allocated pointer
1743 in the aux structure that might exist is the backreference array.
1748 struct xpvhv_aux *iter = HvAUX(hv);
1749 /* If there are weak references to this HV, we need to avoid
1750 freeing them up here. In particular we need to keep the AV
1751 visible as what we're deleting might well have weak references
1752 back to this HV, so the for loop below may well trigger
1753 the removal of backreferences from this array. */
1755 if (iter->xhv_backreferences) {
1756 /* So donate them to regular backref magic to keep them safe.
1757 The sv_magic will increase the reference count of the AV,
1758 so we need to drop it first. */
1759 SvREFCNT_dec(iter->xhv_backreferences);
1760 if (AvFILLp(iter->xhv_backreferences) == -1) {
1761 /* Turns out that the array is empty. Just free it. */
1762 SvREFCNT_dec(iter->xhv_backreferences);
1765 sv_magic((SV*)hv, (SV*)iter->xhv_backreferences,
1766 PERL_MAGIC_backref, NULL, 0);
1768 iter->xhv_backreferences = NULL;
1771 entry = iter->xhv_eiter; /* HvEITER(hv) */
1772 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1774 hv_free_ent(hv, entry);
1776 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1777 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1779 /* There are now no allocated pointers in the aux structure. */
1781 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
1782 /* What aux structure? */
1785 /* make everyone else think the array is empty, so that the destructors
1786 * called for freed entries can't recusively mess with us */
1789 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1793 /* Loop down the linked list heads */
1794 HE *entry = array[i];
1797 register HE * const oentry = entry;
1798 entry = HeNEXT(entry);
1799 hv_free_ent(hv, oentry);
1803 /* As there are no allocated pointers in the aux structure, it's now
1804 safe to free the array we just cleaned up, if it's not the one we're
1805 going to put back. */
1806 if (array != orig_array) {
1811 /* Good. No-one added anything this time round. */
1816 /* Someone attempted to iterate or set the hash name while we had
1817 the array set to 0. We'll catch backferences on the next time
1818 round the while loop. */
1819 assert(HvARRAY(hv));
1821 if (HvAUX(hv)->xhv_name) {
1822 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1826 if (--attempts == 0) {
1827 Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1831 HvARRAY(hv) = orig_array;
1833 /* If the hash was actually a symbol table, put the name back. */
1835 /* We have restored the original array. If name is non-NULL, then
1836 the original array had an aux structure at the end. So this is
1838 SvFLAGS(hv) |= SVf_OOK;
1839 HvAUX(hv)->xhv_name = name;
1844 =for apidoc hv_undef
1852 Perl_hv_undef(pTHX_ HV *hv)
1855 register XPVHV* xhv;
1860 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1861 xhv = (XPVHV*)SvANY(hv);
1863 if ((name = HvNAME_get(hv))) {
1865 hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1866 hv_name_set(hv, NULL, 0, 0);
1868 SvFLAGS(hv) &= ~SVf_OOK;
1869 Safefree(HvARRAY(hv));
1870 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1872 HvPLACEHOLDERS_set(hv, 0);
1878 static struct xpvhv_aux*
1879 S_hv_auxinit(HV *hv) {
1880 struct xpvhv_aux *iter;
1884 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1885 + sizeof(struct xpvhv_aux), char);
1887 array = (char *) HvARRAY(hv);
1888 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1889 + sizeof(struct xpvhv_aux), char);
1891 HvARRAY(hv) = (HE**) array;
1892 /* SvOOK_on(hv) attacks the IV flags. */
1893 SvFLAGS(hv) |= SVf_OOK;
1896 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1897 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1899 iter->xhv_backreferences = 0;
1904 =for apidoc hv_iterinit
1906 Prepares a starting point to traverse a hash table. Returns the number of
1907 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1908 currently only meaningful for hashes without tie magic.
1910 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1911 hash buckets that happen to be in use. If you still need that esoteric
1912 value, you can get it through the macro C<HvFILL(tb)>.
1919 Perl_hv_iterinit(pTHX_ HV *hv)
1922 Perl_croak(aTHX_ "Bad hash");
1925 struct xpvhv_aux * const iter = HvAUX(hv);
1926 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1927 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1929 hv_free_ent(hv, entry);
1931 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1932 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1936 if ( SvRMAGICAL(hv) ) {
1937 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names);
1940 const REGEXP * const rx = PM_GETRE(PL_curpm);
1941 if (rx && rx->paren_names) {
1942 (void)hv_iterinit(rx->paren_names);
1947 /* used to be xhv->xhv_fill before 5.004_65 */
1948 return HvTOTALKEYS(hv);
1952 Perl_hv_riter_p(pTHX_ HV *hv) {
1953 struct xpvhv_aux *iter;
1956 Perl_croak(aTHX_ "Bad hash");
1958 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1959 return &(iter->xhv_riter);
1963 Perl_hv_eiter_p(pTHX_ HV *hv) {
1964 struct xpvhv_aux *iter;
1967 Perl_croak(aTHX_ "Bad hash");
1969 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1970 return &(iter->xhv_eiter);
1974 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1975 struct xpvhv_aux *iter;
1978 Perl_croak(aTHX_ "Bad hash");
1986 iter = hv_auxinit(hv);
1988 iter->xhv_riter = riter;
1992 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1993 struct xpvhv_aux *iter;
1996 Perl_croak(aTHX_ "Bad hash");
2001 /* 0 is the default so don't go malloc()ing a new structure just to
2006 iter = hv_auxinit(hv);
2008 iter->xhv_eiter = eiter;
2012 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2015 struct xpvhv_aux *iter;
2018 PERL_UNUSED_ARG(flags);
2021 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2025 if (iter->xhv_name) {
2026 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2032 iter = hv_auxinit(hv);
2034 PERL_HASH(hash, name, len);
2035 iter->xhv_name = name ? share_hek(name, len, hash) : 0;
2039 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2040 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2041 PERL_UNUSED_CONTEXT;
2042 return &(iter->xhv_backreferences);
2046 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2052 av = HvAUX(hv)->xhv_backreferences;
2055 HvAUX(hv)->xhv_backreferences = 0;
2056 Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av);
2061 hv_iternext is implemented as a macro in hv.h
2063 =for apidoc hv_iternext
2065 Returns entries from a hash iterator. See C<hv_iterinit>.
2067 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2068 iterator currently points to, without losing your place or invalidating your
2069 iterator. Note that in this case the current entry is deleted from the hash
2070 with your iterator holding the last reference to it. Your iterator is flagged
2071 to free the entry on the next call to C<hv_iternext>, so you must not discard
2072 your iterator immediately else the entry will leak - call C<hv_iternext> to
2073 trigger the resource deallocation.
2075 =for apidoc hv_iternext_flags
2077 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
2078 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2079 set the placeholders keys (for restricted hashes) will be returned in addition
2080 to normal keys. By default placeholders are automatically skipped over.
2081 Currently a placeholder is implemented with a value that is
2082 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2083 restricted hashes may change, and the implementation currently is
2084 insufficiently abstracted for any change to be tidy.
2090 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2093 register XPVHV* xhv;
2097 struct xpvhv_aux *iter;
2100 Perl_croak(aTHX_ "Bad hash");
2102 xhv = (XPVHV*)SvANY(hv);
2105 /* Too many things (well, pp_each at least) merrily assume that you can
2106 call iv_iternext without calling hv_iterinit, so we'll have to deal
2112 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2113 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2114 if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names) ) ) {
2120 rx = PM_GETRE(PL_curpm);
2121 if (rx && rx->paren_names) {
2122 hv = rx->paren_names;
2127 key = sv_newmortal();
2129 sv_setsv(key, HeSVKEY_force(entry));
2130 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2136 /* one HE per MAGICAL hash */
2137 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2139 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
2141 HeKEY_hek(entry) = hek;
2142 HeKLEN(entry) = HEf_SVKEY;
2146 HE *temphe = hv_iternext_flags(hv,flags);
2150 SV* sv_dat = HeVAL(temphe);
2151 I32 *nums = (I32*)SvPVX(sv_dat);
2152 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
2153 if ((I32)(rx->lastcloseparen) >= nums[i] &&
2154 rx->startp[nums[i]] != -1 &&
2155 rx->endp[nums[i]] != -1)
2164 SV *sv = sv_newmortal();
2165 const char* pvkey = HePV(temphe, len);
2167 Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
2168 gv_paren = Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
2169 Perl_sv_setpvn(aTHX_ key, pvkey, len);
2170 val = GvSVn(gv_paren);
2177 if (val && SvOK(key)) {
2178 /* force key to stay around until next time */
2179 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2180 HeVAL(entry) = SvREFCNT_inc_simple_NN(val);
2181 return entry; /* beware, hent_val is not set */
2184 SvREFCNT_dec(HeVAL(entry));
2185 Safefree(HeKEY_hek(entry));
2187 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2190 else if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
2191 SV * const key = sv_newmortal();
2193 sv_setsv(key, HeSVKEY_force(entry));
2194 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2200 /* one HE per MAGICAL hash */
2201 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2203 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
2205 HeKEY_hek(entry) = hek;
2206 HeKLEN(entry) = HEf_SVKEY;
2208 magic_nextpack((SV*) hv,mg,key);
2210 /* force key to stay around until next time */
2211 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2212 return entry; /* beware, hent_val is not set */
2215 SvREFCNT_dec(HeVAL(entry));
2216 Safefree(HeKEY_hek(entry));
2218 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2222 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
2223 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
2226 /* The prime_env_iter() on VMS just loaded up new hash values
2227 * so the iteration count needs to be reset back to the beginning
2231 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2236 /* hv_iterint now ensures this. */
2237 assert (HvARRAY(hv));
2239 /* At start of hash, entry is NULL. */
2242 entry = HeNEXT(entry);
2243 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2245 * Skip past any placeholders -- don't want to include them in
2248 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2249 entry = HeNEXT(entry);
2254 /* OK. Come to the end of the current list. Grab the next one. */
2256 iter->xhv_riter++; /* HvRITER(hv)++ */
2257 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2258 /* There is no next one. End of the hash. */
2259 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2262 entry = (HvARRAY(hv))[iter->xhv_riter];
2264 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2265 /* If we have an entry, but it's a placeholder, don't count it.
2267 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2268 entry = HeNEXT(entry);
2270 /* Will loop again if this linked list starts NULL
2271 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2272 or if we run through it and find only placeholders. */
2275 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2277 hv_free_ent(hv, oldentry);
2280 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2281 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
2283 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2288 =for apidoc hv_iterkey
2290 Returns the key from the current position of the hash iterator. See
2297 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2299 if (HeKLEN(entry) == HEf_SVKEY) {
2301 char * const p = SvPV(HeKEY_sv(entry), len);
2306 *retlen = HeKLEN(entry);
2307 return HeKEY(entry);
2311 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2313 =for apidoc hv_iterkeysv
2315 Returns the key as an C<SV*> from the current position of the hash
2316 iterator. The return value will always be a mortal copy of the key. Also
2323 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2325 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2329 =for apidoc hv_iterval
2331 Returns the value from the current position of the hash iterator. See
2338 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2340 if (SvRMAGICAL(hv)) {
2341 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2342 SV* const sv = sv_newmortal();
2343 if (HeKLEN(entry) == HEf_SVKEY)
2344 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2346 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2350 return HeVAL(entry);
2354 =for apidoc hv_iternextsv
2356 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2363 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2365 HE * const he = hv_iternext_flags(hv, 0);
2369 *key = hv_iterkey(he, retlen);
2370 return hv_iterval(hv, he);
2377 =for apidoc hv_magic
2379 Adds magic to a hash. See C<sv_magic>.
2384 /* possibly free a shared string if no one has access to it
2385 * len and hash must both be valid for str.
2388 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2390 unshare_hek_or_pvn (NULL, str, len, hash);
2395 Perl_unshare_hek(pTHX_ HEK *hek)
2397 unshare_hek_or_pvn(hek, NULL, 0, 0);
2400 /* possibly free a shared string if no one has access to it
2401 hek if non-NULL takes priority over the other 3, else str, len and hash
2402 are used. If so, len and hash must both be valid for str.
2405 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2408 register XPVHV* xhv;
2410 register HE **oentry;
2412 bool is_utf8 = FALSE;
2414 const char * const save = str;
2415 struct shared_he *he = NULL;
2418 /* Find the shared he which is just before us in memory. */
2419 he = (struct shared_he *)(((char *)hek)
2420 - STRUCT_OFFSET(struct shared_he,
2423 /* Assert that the caller passed us a genuine (or at least consistent)
2425 assert (he->shared_he_he.hent_hek == hek);
2428 if (he->shared_he_he.he_valu.hent_refcount - 1) {
2429 --he->shared_he_he.he_valu.hent_refcount;
2430 UNLOCK_STRTAB_MUTEX;
2433 UNLOCK_STRTAB_MUTEX;
2435 hash = HEK_HASH(hek);
2436 } else if (len < 0) {
2437 STRLEN tmplen = -len;
2439 /* See the note in hv_fetch(). --jhi */
2440 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2443 k_flags = HVhek_UTF8;
2445 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2448 /* what follows was the moral equivalent of:
2449 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2451 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2453 xhv = (XPVHV*)SvANY(PL_strtab);
2454 /* assert(xhv_array != 0) */
2456 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2458 const HE *const he_he = &(he->shared_he_he);
2459 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2464 const int flags_masked = k_flags & HVhek_MASK;
2465 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2466 if (HeHASH(entry) != hash) /* strings can't be equal */
2468 if (HeKLEN(entry) != len)
2470 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2472 if (HeKFLAGS(entry) != flags_masked)
2479 if (--entry->he_valu.hent_refcount == 0) {
2480 *oentry = HeNEXT(entry);
2482 /* There are now no entries in our slot. */
2483 xhv->xhv_fill--; /* HvFILL(hv)-- */
2486 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2490 UNLOCK_STRTAB_MUTEX;
2491 if (!entry && ckWARN_d(WARN_INTERNAL))
2492 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2493 "Attempt to free non-existent shared string '%s'%s"
2495 hek ? HEK_KEY(hek) : str,
2496 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2497 if (k_flags & HVhek_FREEKEY)
2501 /* get a (constant) string ptr from the global string table
2502 * string will get added if it is not already there.
2503 * len and hash must both be valid for str.
2506 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2508 bool is_utf8 = FALSE;
2510 const char * const save = str;
2513 STRLEN tmplen = -len;
2515 /* See the note in hv_fetch(). --jhi */
2516 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2518 /* If we were able to downgrade here, then than means that we were passed
2519 in a key which only had chars 0-255, but was utf8 encoded. */
2522 /* If we found we were able to downgrade the string to bytes, then
2523 we should flag that it needs upgrading on keys or each. Also flag
2524 that we need share_hek_flags to free the string. */
2526 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2529 return share_hek_flags (str, len, hash, flags);
2533 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2537 const int flags_masked = flags & HVhek_MASK;
2538 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2540 /* what follows is the moral equivalent of:
2542 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2543 hv_store(PL_strtab, str, len, NULL, hash);
2545 Can't rehash the shared string table, so not sure if it's worth
2546 counting the number of entries in the linked list
2548 register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2549 /* assert(xhv_array != 0) */
2551 entry = (HvARRAY(PL_strtab))[hindex];
2552 for (;entry; entry = HeNEXT(entry)) {
2553 if (HeHASH(entry) != hash) /* strings can't be equal */
2555 if (HeKLEN(entry) != len)
2557 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2559 if (HeKFLAGS(entry) != flags_masked)
2565 /* What used to be head of the list.
2566 If this is NULL, then we're the first entry for this slot, which
2567 means we need to increate fill. */
2568 struct shared_he *new_entry;
2571 HE **const head = &HvARRAY(PL_strtab)[hindex];
2572 HE *const next = *head;
2574 /* We don't actually store a HE from the arena and a regular HEK.
2575 Instead we allocate one chunk of memory big enough for both,
2576 and put the HEK straight after the HE. This way we can find the
2577 HEK directly from the HE.
2580 Newx(k, STRUCT_OFFSET(struct shared_he,
2581 shared_he_hek.hek_key[0]) + len + 2, char);
2582 new_entry = (struct shared_he *)k;
2583 entry = &(new_entry->shared_he_he);
2584 hek = &(new_entry->shared_he_hek);
2586 Copy(str, HEK_KEY(hek), len, char);
2587 HEK_KEY(hek)[len] = 0;
2589 HEK_HASH(hek) = hash;
2590 HEK_FLAGS(hek) = (unsigned char)flags_masked;
2592 /* Still "point" to the HEK, so that other code need not know what
2594 HeKEY_hek(entry) = hek;
2595 entry->he_valu.hent_refcount = 0;
2596 HeNEXT(entry) = next;
2599 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2600 if (!next) { /* initial entry? */
2601 xhv->xhv_fill++; /* HvFILL(hv)++ */
2602 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2607 ++entry->he_valu.hent_refcount;
2608 UNLOCK_STRTAB_MUTEX;
2610 if (flags & HVhek_FREEKEY)
2613 return HeKEY_hek(entry);
2617 S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action)
2620 if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
2621 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2622 if (uf->uf_set == NULL) {
2623 SV* obj = mg->mg_obj;
2624 mg->mg_obj = keysv; /* pass key */
2625 uf->uf_index = action; /* pass action */
2626 magic_getuvar((SV*)hv, mg);
2627 keysv = mg->mg_obj; /* may have changed */
2635 Perl_hv_placeholders_p(pTHX_ HV *hv)
2638 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2641 mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2644 Perl_die(aTHX_ "panic: hv_placeholders_p");
2647 return &(mg->mg_len);
2652 Perl_hv_placeholders_get(pTHX_ HV *hv)
2655 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2657 return mg ? mg->mg_len : 0;
2661 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2664 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2669 if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2670 Perl_die(aTHX_ "panic: hv_placeholders_set");
2672 /* else we don't need to add magic to record 0 placeholders. */
2676 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2680 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2685 value = &PL_sv_placeholder;
2688 value = (he->refcounted_he_data[0] & HVrhek_UV)
2689 ? newSVuv(he->refcounted_he_val.refcounted_he_u_iv)
2690 : newSViv(he->refcounted_he_val.refcounted_he_u_uv);
2693 /* Create a string SV that directly points to the bytes in our
2696 sv_upgrade(value, SVt_PV);
2697 SvPV_set(value, (char *) he->refcounted_he_data + 1);
2698 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2699 /* This stops anything trying to free it */
2700 SvLEN_set(value, 0);
2702 SvREADONLY_on(value);
2703 if (he->refcounted_he_data[0] & HVrhek_UTF8)
2707 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2708 he->refcounted_he_data[0]);
2714 /* A big expression to find the key offset */
2715 #define REF_HE_KEY(chain) \
2716 ((((chain->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV) \
2717 ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \
2718 + 1 + chain->refcounted_he_data)
2722 =for apidoc refcounted_he_chain_2hv
2724 Generates an returns a C<HV *> by walking up the tree starting at the passed
2725 in C<struct refcounted_he *>.
2730 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2734 U32 placeholders = 0;
2735 /* We could chase the chain once to get an idea of the number of keys,
2736 and call ksplit. But for now we'll make a potentially inefficient
2737 hash with only 8 entries in its array. */
2738 const U32 max = HvMAX(hv);
2742 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2743 HvARRAY(hv) = (HE**)array;
2748 U32 hash = chain->refcounted_he_hash;
2750 U32 hash = HEK_HASH(chain->refcounted_he_hek);
2752 HE **oentry = &((HvARRAY(hv))[hash & max]);
2753 HE *entry = *oentry;
2756 for (; entry; entry = HeNEXT(entry)) {
2757 if (HeHASH(entry) == hash) {
2758 /* We might have a duplicate key here. If so, entry is older
2759 than the key we've already put in the hash, so if they are
2760 the same, skip adding entry. */
2762 const STRLEN klen = HeKLEN(entry);
2763 const char *const key = HeKEY(entry);
2764 if (klen == chain->refcounted_he_keylen
2765 && (!!HeKUTF8(entry)
2766 == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2767 && memEQ(key, REF_HE_KEY(chain), klen))
2770 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2772 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2773 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2774 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2785 = share_hek_flags(REF_HE_KEY(chain),
2786 chain->refcounted_he_keylen,
2787 chain->refcounted_he_hash,
2788 (chain->refcounted_he_data[0]
2789 & (HVhek_UTF8|HVhek_WASUTF8)));
2791 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2793 value = refcounted_he_value(chain);
2794 if (value == &PL_sv_placeholder)
2796 HeVAL(entry) = value;
2798 /* Link it into the chain. */
2799 HeNEXT(entry) = *oentry;
2800 if (!HeNEXT(entry)) {
2801 /* initial entry. */
2809 chain = chain->refcounted_he_next;
2813 clear_placeholders(hv, placeholders);
2814 HvTOTALKEYS(hv) -= placeholders;
2817 /* We could check in the loop to see if we encounter any keys with key
2818 flags, but it's probably not worth it, as this per-hash flag is only
2819 really meant as an optimisation for things like Storable. */
2821 DEBUG_A(Perl_hv_assert(aTHX_ hv));
2827 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2828 const char *key, STRLEN klen, int flags, U32 hash)
2831 /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2832 of your key has to exactly match that which is stored. */
2833 SV *value = &PL_sv_placeholder;
2837 if (flags & HVhek_FREEKEY)
2839 key = SvPV_const(keysv, klen);
2841 is_utf8 = (SvUTF8(keysv) != 0);
2843 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
2847 if (keysv && (SvIsCOW_shared_hash(keysv))) {
2848 hash = SvSHARED_HASH(keysv);
2850 PERL_HASH(hash, key, klen);
2854 for (; chain; chain = chain->refcounted_he_next) {
2856 if (hash != chain->refcounted_he_hash)
2858 if (klen != chain->refcounted_he_keylen)
2860 if (memNE(REF_HE_KEY(chain),key,klen))
2862 if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2865 if (hash != HEK_HASH(chain->refcounted_he_hek))
2867 if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
2869 if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2871 if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2875 value = sv_2mortal(refcounted_he_value(chain));
2879 if (flags & HVhek_FREEKEY)
2886 =for apidoc refcounted_he_new
2888 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2889 stored in a compact form, all references remain the property of the caller.
2890 The C<struct refcounted_he> is returned with a reference count of 1.
2895 struct refcounted_he *
2896 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2897 SV *const key, SV *const value) {
2899 struct refcounted_he *he;
2901 const char *key_p = SvPV_const(key, key_len);
2902 STRLEN value_len = 0;
2903 const char *value_p = NULL;
2908 bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
2911 value_type = HVrhek_PV;
2912 } else if (SvIOK(value)) {
2913 value_type = HVrhek_IV;
2914 } else if (value == &PL_sv_placeholder) {
2915 value_type = HVrhek_delete;
2916 } else if (!SvOK(value)) {
2917 value_type = HVrhek_undef;
2919 value_type = HVrhek_PV;
2922 if (value_type == HVrhek_PV) {
2923 value_p = SvPV_const(value, value_len);
2924 key_offset = value_len + 2;
2932 he = (struct refcounted_he*)
2933 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2937 he = (struct refcounted_he*)
2938 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2943 he->refcounted_he_next = parent;
2945 if (value_type == HVrhek_PV) {
2946 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
2947 he->refcounted_he_val.refcounted_he_u_len = value_len;
2948 if (SvUTF8(value)) {
2949 flags |= HVrhek_UTF8;
2951 } else if (value_type == HVrhek_IV) {
2953 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
2956 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
2961 /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2962 As we're going to be building hash keys from this value in future,
2963 normalise it now. */
2964 key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2965 flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2967 PERL_HASH(hash, key_p, key_len);
2970 he->refcounted_he_hash = hash;
2971 he->refcounted_he_keylen = key_len;
2972 Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
2974 he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
2977 if (flags & HVhek_WASUTF8) {
2978 /* If it was downgraded from UTF-8, then the pointer returned from
2979 bytes_from_utf8 is an allocated pointer that we must free. */
2983 he->refcounted_he_data[0] = flags;
2984 he->refcounted_he_refcnt = 1;
2990 =for apidoc refcounted_he_free
2992 Decrements the reference count of the passed in C<struct refcounted_he *>
2993 by one. If the reference count reaches zero the structure's memory is freed,
2994 and C<refcounted_he_free> iterates onto the parent node.
3000 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3001 PERL_UNUSED_CONTEXT;
3004 struct refcounted_he *copy;
3008 new_count = --he->refcounted_he_refcnt;
3009 HINTS_REFCNT_UNLOCK;
3015 #ifndef USE_ITHREADS
3016 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3019 he = he->refcounted_he_next;
3020 PerlMemShared_free(copy);
3025 =for apidoc hv_assert
3027 Check that a hash is in an internally consistent state.
3035 Perl_hv_assert(pTHX_ HV *hv)
3040 int placeholders = 0;
3043 const I32 riter = HvRITER_get(hv);
3044 HE *eiter = HvEITER_get(hv);
3046 (void)hv_iterinit(hv);
3048 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3049 /* sanity check the values */
3050 if (HeVAL(entry) == &PL_sv_placeholder)
3054 /* sanity check the keys */
3055 if (HeSVKEY(entry)) {
3056 NOOP; /* Don't know what to check on SV keys. */
3057 } else if (HeKUTF8(entry)) {
3059 if (HeKWASUTF8(entry)) {
3060 PerlIO_printf(Perl_debug_log,
3061 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
3062 (int) HeKLEN(entry), HeKEY(entry));
3065 } else if (HeKWASUTF8(entry))
3068 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
3069 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3070 const int nhashkeys = HvUSEDKEYS(hv);
3071 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3073 if (nhashkeys != real) {
3074 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3077 if (nhashplaceholders != placeholders) {
3078 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3082 if (withflags && ! HvHASKFLAGS(hv)) {
3083 PerlIO_printf(Perl_debug_log,
3084 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3091 HvRITER_set(hv, riter); /* Restore hash iterator state */
3092 HvEITER_set(hv, eiter);
3099 * c-indentation-style: bsd
3101 * indent-tabs-mode: t
3104 * ex: set ts=8 sts=4 sw=4 noet: