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);
474 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
477 /* grab a fake HE/HEK pair from the pool or make a new one */
478 entry = PL_hv_fetch_ent_mh;
480 PL_hv_fetch_ent_mh = HeNEXT(entry);
484 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
485 HeKEY_hek(entry) = (HEK*)k;
487 HeNEXT(entry) = NULL;
488 HeSVKEY_set(entry, keysv);
490 sv_upgrade(sv, SVt_PVLV);
492 /* so we can free entry when freeing sv */
493 LvTARG(sv) = (SV*)entry;
495 /* XXX remove at some point? */
496 if (flags & HVhek_FREEKEY)
501 #ifdef ENV_IS_CASELESS
502 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
504 for (i = 0; i < klen; ++i)
505 if (isLOWER(key[i])) {
506 /* Would be nice if we had a routine to do the
507 copy and upercase in a single pass through. */
508 const char * const nkey = strupr(savepvn(key,klen));
509 /* Note that this fetch is for nkey (the uppercased
510 key) whereas the store is for key (the original) */
511 entry = hv_fetch_common(hv, NULL, nkey, klen,
512 HVhek_FREEKEY, /* free nkey */
513 0 /* non-LVAL fetch */,
515 0 /* compute hash */);
516 if (!entry && (action & HV_FETCH_LVALUE)) {
517 /* This call will free key if necessary.
518 Do it this way to encourage compiler to tail
520 entry = hv_fetch_common(hv, keysv, key, klen,
521 flags, HV_FETCH_ISSTORE,
524 if (flags & HVhek_FREEKEY)
532 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
533 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
534 /* I don't understand why hv_exists_ent has svret and sv,
535 whereas hv_exists only had one. */
536 SV * const svret = sv_newmortal();
539 if (keysv || is_utf8) {
541 keysv = newSVpvn(key, klen);
544 keysv = newSVsv(keysv);
546 mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
548 mg_copy((SV*)hv, sv, key, klen);
550 if (flags & HVhek_FREEKEY)
552 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
553 /* This cast somewhat evil, but I'm merely using NULL/
554 not NULL to return the boolean exists.
555 And I know hv is not NULL. */
556 return SvTRUE(svret) ? (HE *)hv : NULL;
558 #ifdef ENV_IS_CASELESS
559 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
560 /* XXX This code isn't UTF8 clean. */
561 char * const keysave = (char * const)key;
562 /* Will need to free this, so set FREEKEY flag. */
563 key = savepvn(key,klen);
564 key = (const char*)strupr((char*)key);
569 if (flags & HVhek_FREEKEY) {
572 flags |= HVhek_FREEKEY;
576 else if (action & HV_FETCH_ISSTORE) {
579 hv_magic_check (hv, &needs_copy, &needs_store);
581 const bool save_taint = PL_tainted;
582 if (keysv || is_utf8) {
584 keysv = newSVpvn(key, klen);
588 PL_tainted = SvTAINTED(keysv);
589 keysv = sv_2mortal(newSVsv(keysv));
590 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
592 mg_copy((SV*)hv, val, key, klen);
595 TAINT_IF(save_taint);
597 if (flags & HVhek_FREEKEY)
601 #ifdef ENV_IS_CASELESS
602 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
603 /* XXX This code isn't UTF8 clean. */
604 const char *keysave = key;
605 /* Will need to free this, so set FREEKEY flag. */
606 key = savepvn(key,klen);
607 key = (const char*)strupr((char*)key);
612 if (flags & HVhek_FREEKEY) {
615 flags |= HVhek_FREEKEY;
623 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
624 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
625 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
630 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
632 HvARRAY(hv) = (HE**)array;
634 #ifdef DYNAMIC_ENV_FETCH
635 else if (action & HV_FETCH_ISEXISTS) {
636 /* for an %ENV exists, if we do an insert it's by a recursive
637 store call, so avoid creating HvARRAY(hv) right now. */
641 /* XXX remove at some point? */
642 if (flags & HVhek_FREEKEY)
650 char * const keysave = (char *)key;
651 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
655 flags &= ~HVhek_UTF8;
656 if (key != keysave) {
657 if (flags & HVhek_FREEKEY)
659 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
664 PERL_HASH_INTERNAL(hash, key, klen);
665 /* We don't have a pointer to the hv, so we have to replicate the
666 flag into every HEK, so that hv_iterkeysv can see it. */
667 /* And yes, you do need this even though you are not "storing" because
668 you can flip the flags below if doing an lval lookup. (And that
669 was put in to give the semantics Andreas was expecting.) */
670 flags |= HVhek_REHASH;
672 if (keysv && (SvIsCOW_shared_hash(keysv))) {
673 hash = SvSHARED_HASH(keysv);
675 PERL_HASH(hash, key, klen);
679 masked_flags = (flags & HVhek_MASK);
681 #ifdef DYNAMIC_ENV_FETCH
682 if (!HvARRAY(hv)) entry = NULL;
686 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
688 for (; entry; entry = HeNEXT(entry)) {
689 if (HeHASH(entry) != hash) /* strings can't be equal */
691 if (HeKLEN(entry) != (I32)klen)
693 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
695 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
698 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
699 if (HeKFLAGS(entry) != masked_flags) {
700 /* We match if HVhek_UTF8 bit in our flags and hash key's
701 match. But if entry was set previously with HVhek_WASUTF8
702 and key now doesn't (or vice versa) then we should change
703 the key's flag, as this is assignment. */
704 if (HvSHAREKEYS(hv)) {
705 /* Need to swap the key we have for a key with the flags we
706 need. As keys are shared we can't just write to the
707 flag, so we share the new one, unshare the old one. */
708 HEK * const new_hek = share_hek_flags(key, klen, hash,
710 unshare_hek (HeKEY_hek(entry));
711 HeKEY_hek(entry) = new_hek;
713 else if (hv == PL_strtab) {
714 /* PL_strtab is usually the only hash without HvSHAREKEYS,
715 so putting this test here is cheap */
716 if (flags & HVhek_FREEKEY)
718 Perl_croak(aTHX_ S_strtab_error,
719 action & HV_FETCH_LVALUE ? "fetch" : "store");
722 HeKFLAGS(entry) = masked_flags;
723 if (masked_flags & HVhek_ENABLEHVKFLAGS)
726 if (HeVAL(entry) == &PL_sv_placeholder) {
727 /* yes, can store into placeholder slot */
728 if (action & HV_FETCH_LVALUE) {
730 /* This preserves behaviour with the old hv_fetch
731 implementation which at this point would bail out
732 with a break; (at "if we find a placeholder, we
733 pretend we haven't found anything")
735 That break mean that if a placeholder were found, it
736 caused a call into hv_store, which in turn would
737 check magic, and if there is no magic end up pretty
738 much back at this point (in hv_store's code). */
741 /* LVAL fetch which actaully needs a store. */
743 HvPLACEHOLDERS(hv)--;
746 if (val != &PL_sv_placeholder)
747 HvPLACEHOLDERS(hv)--;
750 } else if (action & HV_FETCH_ISSTORE) {
751 SvREFCNT_dec(HeVAL(entry));
754 } else if (HeVAL(entry) == &PL_sv_placeholder) {
755 /* if we find a placeholder, we pretend we haven't found
759 if (flags & HVhek_FREEKEY)
763 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
764 if (!(action & HV_FETCH_ISSTORE)
765 && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
767 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
769 sv = newSVpvn(env,len);
771 return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
777 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
778 hv_notallowed(flags, key, klen,
779 "Attempt to access disallowed key '%"SVf"' in"
780 " a restricted hash");
782 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
783 /* Not doing some form of store, so return failure. */
784 if (flags & HVhek_FREEKEY)
788 if (action & HV_FETCH_LVALUE) {
791 /* At this point the old hv_fetch code would call to hv_store,
792 which in turn might do some tied magic. So we need to make that
793 magic check happen. */
794 /* gonna assign to this, so it better be there */
795 return hv_fetch_common(hv, keysv, key, klen, flags,
796 HV_FETCH_ISSTORE, val, hash);
797 /* XXX Surely that could leak if the fetch-was-store fails?
798 Just like the hv_fetch. */
802 /* Welcome to hv_store... */
805 /* Not sure if we can get here. I think the only case of oentry being
806 NULL is for %ENV with dynamic env fetch. But that should disappear
807 with magic in the previous code. */
810 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
812 HvARRAY(hv) = (HE**)array;
815 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
818 /* share_hek_flags will do the free for us. This might be considered
821 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
822 else if (hv == PL_strtab) {
823 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
824 this test here is cheap */
825 if (flags & HVhek_FREEKEY)
827 Perl_croak(aTHX_ S_strtab_error,
828 action & HV_FETCH_LVALUE ? "fetch" : "store");
830 else /* gotta do the real thing */
831 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
833 HeNEXT(entry) = *oentry;
836 if (val == &PL_sv_placeholder)
837 HvPLACEHOLDERS(hv)++;
838 if (masked_flags & HVhek_ENABLEHVKFLAGS)
842 const HE *counter = HeNEXT(entry);
844 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
845 if (!counter) { /* initial entry? */
846 xhv->xhv_fill++; /* HvFILL(hv)++ */
847 } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
849 } else if(!HvREHASH(hv)) {
852 while ((counter = HeNEXT(counter)))
855 if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
856 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
857 bucket splits on a rehashed hash, as we're not going to
858 split it again, and if someone is lucky (evil) enough to
859 get all the keys in one list they could exhaust our memory
860 as we repeatedly double the number of buckets on every
861 entry. Linear search feels a less worse thing to do. */
871 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
873 const MAGIC *mg = SvMAGIC(hv);
877 if (isUPPER(mg->mg_type)) {
879 if (mg->mg_type == PERL_MAGIC_tied) {
880 *needs_store = FALSE;
881 return; /* We've set all there is to set. */
884 mg = mg->mg_moremagic;
889 =for apidoc hv_scalar
891 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
897 Perl_hv_scalar(pTHX_ HV *hv)
901 if (SvRMAGICAL(hv)) {
902 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
904 return magic_scalarpack(hv, mg);
909 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
910 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
918 =for apidoc hv_delete
920 Deletes a key/value pair in the hash. The value SV is removed from the
921 hash and returned to the caller. The C<klen> is the length of the key.
922 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
929 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
936 k_flags = HVhek_UTF8;
941 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
945 =for apidoc hv_delete_ent
947 Deletes a key/value pair in the hash. The value SV is removed from the
948 hash and returned to the caller. The C<flags> value will normally be zero;
949 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
950 precomputed hash value, or 0 to ask for it to be computed.
955 /* XXX This looks like an ideal candidate to inline */
957 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
959 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
963 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
964 int k_flags, I32 d_flags, U32 hash)
969 register HE **oentry;
970 HE *const *first_entry;
978 if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
979 keysv = hv_magic_uvar_xkey(hv, keysv, -1);
980 if (k_flags & HVhek_FREEKEY)
982 key = SvPV_const(keysv, klen);
984 is_utf8 = (SvUTF8(keysv) != 0);
986 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
989 if (SvRMAGICAL(hv)) {
992 hv_magic_check (hv, &needs_copy, &needs_store);
996 entry = hv_fetch_common(hv, keysv, key, klen,
997 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
999 sv = entry ? HeVAL(entry) : NULL;
1001 if (SvMAGICAL(sv)) {
1005 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1006 /* No longer an element */
1007 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1010 return NULL; /* element cannot be deleted */
1012 #ifdef ENV_IS_CASELESS
1013 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1014 /* XXX This code isn't UTF8 clean. */
1015 keysv = sv_2mortal(newSVpvn(key,klen));
1016 if (k_flags & HVhek_FREEKEY) {
1019 key = strupr(SvPVX(keysv));
1028 xhv = (XPVHV*)SvANY(hv);
1033 const char * const keysave = key;
1034 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1037 k_flags |= HVhek_UTF8;
1039 k_flags &= ~HVhek_UTF8;
1040 if (key != keysave) {
1041 if (k_flags & HVhek_FREEKEY) {
1042 /* This shouldn't happen if our caller does what we expect,
1043 but strictly the API allows it. */
1046 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1048 HvHASKFLAGS_on((SV*)hv);
1052 PERL_HASH_INTERNAL(hash, key, klen);
1054 if (keysv && (SvIsCOW_shared_hash(keysv))) {
1055 hash = SvSHARED_HASH(keysv);
1057 PERL_HASH(hash, key, klen);
1061 masked_flags = (k_flags & HVhek_MASK);
1063 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1065 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1067 if (HeHASH(entry) != hash) /* strings can't be equal */
1069 if (HeKLEN(entry) != (I32)klen)
1071 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1073 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1076 if (hv == PL_strtab) {
1077 if (k_flags & HVhek_FREEKEY)
1079 Perl_croak(aTHX_ S_strtab_error, "delete");
1082 /* if placeholder is here, it's already been deleted.... */
1083 if (HeVAL(entry) == &PL_sv_placeholder) {
1084 if (k_flags & HVhek_FREEKEY)
1088 if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1089 hv_notallowed(k_flags, key, klen,
1090 "Attempt to delete readonly key '%"SVf"' from"
1091 " a restricted hash");
1093 if (k_flags & HVhek_FREEKEY)
1096 if (d_flags & G_DISCARD)
1099 sv = sv_2mortal(HeVAL(entry));
1100 HeVAL(entry) = &PL_sv_placeholder;
1104 * If a restricted hash, rather than really deleting the entry, put
1105 * a placeholder there. This marks the key as being "approved", so
1106 * we can still access via not-really-existing key without raising
1109 if (SvREADONLY(hv)) {
1110 SvREFCNT_dec(HeVAL(entry));
1111 HeVAL(entry) = &PL_sv_placeholder;
1112 /* We'll be saving this slot, so the number of allocated keys
1113 * doesn't go down, but the number placeholders goes up */
1114 HvPLACEHOLDERS(hv)++;
1116 *oentry = HeNEXT(entry);
1118 xhv->xhv_fill--; /* HvFILL(hv)-- */
1120 if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1123 hv_free_ent(hv, entry);
1124 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1125 if (xhv->xhv_keys == 0)
1126 HvHASKFLAGS_off(hv);
1130 if (SvREADONLY(hv)) {
1131 hv_notallowed(k_flags, key, klen,
1132 "Attempt to delete disallowed key '%"SVf"' from"
1133 " a restricted hash");
1136 if (k_flags & HVhek_FREEKEY)
1142 S_hsplit(pTHX_ HV *hv)
1145 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1146 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1147 register I32 newsize = oldsize * 2;
1149 char *a = (char*) HvARRAY(hv);
1151 register HE **oentry;
1152 int longest_chain = 0;
1155 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1156 hv, (int) oldsize);*/
1158 if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1159 /* Can make this clear any placeholders first for non-restricted hashes,
1160 even though Storable rebuilds restricted hashes by putting in all the
1161 placeholders (first) before turning on the readonly flag, because
1162 Storable always pre-splits the hash. */
1163 hv_clear_placeholders(hv);
1167 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1168 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1169 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1175 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1178 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1179 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1184 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1186 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1188 if (oldsize >= 64) {
1189 offer_nice_chunk(HvARRAY(hv),
1190 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1191 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1194 Safefree(HvARRAY(hv));
1198 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1199 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1200 HvARRAY(hv) = (HE**) a;
1203 for (i=0; i<oldsize; i++,aep++) {
1204 int left_length = 0;
1205 int right_length = 0;
1209 if (!*aep) /* non-existent */
1212 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1213 if ((HeHASH(entry) & newsize) != (U32)i) {
1214 *oentry = HeNEXT(entry);
1215 HeNEXT(entry) = *bep;
1217 xhv->xhv_fill++; /* HvFILL(hv)++ */
1223 oentry = &HeNEXT(entry);
1227 if (!*aep) /* everything moved */
1228 xhv->xhv_fill--; /* HvFILL(hv)-- */
1229 /* I think we don't actually need to keep track of the longest length,
1230 merely flag if anything is too long. But for the moment while
1231 developing this code I'll track it. */
1232 if (left_length > longest_chain)
1233 longest_chain = left_length;
1234 if (right_length > longest_chain)
1235 longest_chain = right_length;
1239 /* Pick your policy for "hashing isn't working" here: */
1240 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
1245 if (hv == PL_strtab) {
1246 /* Urg. Someone is doing something nasty to the string table.
1251 /* Awooga. Awooga. Pathological data. */
1252 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1253 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1256 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1257 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1259 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1262 was_shared = HvSHAREKEYS(hv);
1265 HvSHAREKEYS_off(hv);
1270 for (i=0; i<newsize; i++,aep++) {
1271 register HE *entry = *aep;
1273 /* We're going to trash this HE's next pointer when we chain it
1274 into the new hash below, so store where we go next. */
1275 HE * const next = HeNEXT(entry);
1280 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1285 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1286 hash, HeKFLAGS(entry));
1287 unshare_hek (HeKEY_hek(entry));
1288 HeKEY_hek(entry) = new_hek;
1290 /* Not shared, so simply write the new hash in. */
1291 HeHASH(entry) = hash;
1293 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1294 HEK_REHASH_on(HeKEY_hek(entry));
1295 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1297 /* Copy oentry to the correct new chain. */
1298 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1300 xhv->xhv_fill++; /* HvFILL(hv)++ */
1301 HeNEXT(entry) = *bep;
1307 Safefree (HvARRAY(hv));
1308 HvARRAY(hv) = (HE **)a;
1312 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1315 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1316 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1317 register I32 newsize;
1322 register HE **oentry;
1324 newsize = (I32) newmax; /* possible truncation here */
1325 if (newsize != newmax || newmax <= oldsize)
1327 while ((newsize & (1 + ~newsize)) != newsize) {
1328 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1330 if (newsize < newmax)
1332 if (newsize < newmax)
1333 return; /* overflow detection */
1335 a = (char *) HvARRAY(hv);
1338 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1339 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1340 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1346 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1349 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1350 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1355 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1357 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1359 if (oldsize >= 64) {
1360 offer_nice_chunk(HvARRAY(hv),
1361 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1362 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1365 Safefree(HvARRAY(hv));
1368 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1371 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1373 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1374 HvARRAY(hv) = (HE **) a;
1375 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1379 for (i=0; i<oldsize; i++,aep++) {
1380 if (!*aep) /* non-existent */
1382 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1383 register I32 j = (HeHASH(entry) & newsize);
1387 *oentry = HeNEXT(entry);
1388 if (!(HeNEXT(entry) = aep[j]))
1389 xhv->xhv_fill++; /* HvFILL(hv)++ */
1394 oentry = &HeNEXT(entry);
1396 if (!*aep) /* everything moved */
1397 xhv->xhv_fill--; /* HvFILL(hv)-- */
1404 Creates a new HV. The reference count is set to 1.
1412 register XPVHV* xhv;
1413 HV * const hv = (HV*)newSV(0);
1415 sv_upgrade((SV *)hv, SVt_PVHV);
1416 xhv = (XPVHV*)SvANY(hv);
1419 #ifndef NODEFAULT_SHAREKEYS
1420 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1423 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1424 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1429 Perl_newHVhv(pTHX_ HV *ohv)
1431 HV * const hv = newHV();
1432 STRLEN hv_max, hv_fill;
1434 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1436 hv_max = HvMAX(ohv);
1438 if (!SvMAGICAL((SV *)ohv)) {
1439 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1441 const bool shared = !!HvSHAREKEYS(ohv);
1442 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1444 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1447 /* In each bucket... */
1448 for (i = 0; i <= hv_max; i++) {
1450 HE *oent = oents[i];
1457 /* Copy the linked list of entries. */
1458 for (; oent; oent = HeNEXT(oent)) {
1459 const U32 hash = HeHASH(oent);
1460 const char * const key = HeKEY(oent);
1461 const STRLEN len = HeKLEN(oent);
1462 const int flags = HeKFLAGS(oent);
1463 HE * const ent = new_HE();
1465 HeVAL(ent) = newSVsv(HeVAL(oent));
1467 = shared ? share_hek_flags(key, len, hash, flags)
1468 : save_hek_flags(key, len, hash, flags);
1479 HvFILL(hv) = hv_fill;
1480 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1484 /* Iterate over ohv, copying keys and values one at a time. */
1486 const I32 riter = HvRITER_get(ohv);
1487 HE * const eiter = HvEITER_get(ohv);
1489 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1490 while (hv_max && hv_max + 1 >= hv_fill * 2)
1491 hv_max = hv_max / 2;
1495 while ((entry = hv_iternext_flags(ohv, 0))) {
1496 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1497 newSVsv(HeVAL(entry)), HeHASH(entry),
1500 HvRITER_set(ohv, riter);
1501 HvEITER_set(ohv, eiter);
1507 /* A rather specialised version of newHVhv for copying %^H, ensuring all the
1508 magic stays on it. */
1510 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1512 HV * const hv = newHV();
1515 if (ohv && (hv_fill = HvFILL(ohv))) {
1516 STRLEN hv_max = HvMAX(ohv);
1518 const I32 riter = HvRITER_get(ohv);
1519 HE * const eiter = HvEITER_get(ohv);
1521 while (hv_max && hv_max + 1 >= hv_fill * 2)
1522 hv_max = hv_max / 2;
1526 while ((entry = hv_iternext_flags(ohv, 0))) {
1527 SV *const sv = newSVsv(HeVAL(entry));
1528 sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1529 (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
1530 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1531 sv, HeHASH(entry), HeKFLAGS(entry));
1533 HvRITER_set(ohv, riter);
1534 HvEITER_set(ohv, eiter);
1536 hv_magic(hv, NULL, PERL_MAGIC_hints);
1541 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1549 if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
1550 PL_sub_generation++; /* may be deletion of method from stash */
1552 if (HeKLEN(entry) == HEf_SVKEY) {
1553 SvREFCNT_dec(HeKEY_sv(entry));
1554 Safefree(HeKEY_hek(entry));
1556 else if (HvSHAREKEYS(hv))
1557 unshare_hek(HeKEY_hek(entry));
1559 Safefree(HeKEY_hek(entry));
1564 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1569 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1570 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
1571 if (HeKLEN(entry) == HEf_SVKEY) {
1572 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1574 hv_free_ent(hv, entry);
1578 =for apidoc hv_clear
1580 Clears a hash, making it empty.
1586 Perl_hv_clear(pTHX_ HV *hv)
1589 register XPVHV* xhv;
1593 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1595 xhv = (XPVHV*)SvANY(hv);
1597 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1598 /* restricted hash: convert all keys to placeholders */
1600 for (i = 0; i <= xhv->xhv_max; i++) {
1601 HE *entry = (HvARRAY(hv))[i];
1602 for (; entry; entry = HeNEXT(entry)) {
1603 /* not already placeholder */
1604 if (HeVAL(entry) != &PL_sv_placeholder) {
1605 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1606 SV* const keysv = hv_iterkeysv(entry);
1608 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1611 SvREFCNT_dec(HeVAL(entry));
1612 HeVAL(entry) = &PL_sv_placeholder;
1613 HvPLACEHOLDERS(hv)++;
1621 HvPLACEHOLDERS_set(hv, 0);
1623 Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1628 HvHASKFLAGS_off(hv);
1632 HvEITER_set(hv, NULL);
1637 =for apidoc hv_clear_placeholders
1639 Clears any placeholders from a hash. If a restricted hash has any of its keys
1640 marked as readonly and the key is subsequently deleted, the key is not actually
1641 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1642 it so it will be ignored by future operations such as iterating over the hash,
1643 but will still allow the hash to have a value reassigned to the key at some
1644 future point. This function clears any such placeholder keys from the hash.
1645 See Hash::Util::lock_keys() for an example of its use.
1651 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1654 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1657 clear_placeholders(hv, items);
1661 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1671 /* Loop down the linked list heads */
1673 HE **oentry = &(HvARRAY(hv))[i];
1676 while ((entry = *oentry)) {
1677 if (HeVAL(entry) == &PL_sv_placeholder) {
1678 *oentry = HeNEXT(entry);
1679 if (first && !*oentry)
1680 HvFILL(hv)--; /* This linked list is now empty. */
1681 if (entry == HvEITER_get(hv))
1684 hv_free_ent(hv, entry);
1688 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1689 if (HvKEYS(hv) == 0)
1690 HvHASKFLAGS_off(hv);
1691 HvPLACEHOLDERS_set(hv, 0);
1695 oentry = &HeNEXT(entry);
1700 /* You can't get here, hence assertion should always fail. */
1701 assert (items == 0);
1706 S_hfreeentries(pTHX_ HV *hv)
1708 /* This is the array that we're going to restore */
1717 /* If the hash is actually a symbol table with a name, look after the
1719 struct xpvhv_aux *iter = HvAUX(hv);
1721 name = iter->xhv_name;
1722 iter->xhv_name = NULL;
1727 orig_array = HvARRAY(hv);
1728 /* orig_array remains unchanged throughout the loop. If after freeing all
1729 the entries it turns out that one of the little blighters has triggered
1730 an action that has caused HvARRAY to be re-allocated, then we set
1731 array to the new HvARRAY, and try again. */
1734 /* This is the one we're going to try to empty. First time round
1735 it's the original array. (Hopefully there will only be 1 time
1737 HE ** const array = HvARRAY(hv);
1740 /* Because we have taken xhv_name out, the only allocated pointer
1741 in the aux structure that might exist is the backreference array.
1746 struct xpvhv_aux *iter = HvAUX(hv);
1747 /* If there are weak references to this HV, we need to avoid
1748 freeing them up here. In particular we need to keep the AV
1749 visible as what we're deleting might well have weak references
1750 back to this HV, so the for loop below may well trigger
1751 the removal of backreferences from this array. */
1753 if (iter->xhv_backreferences) {
1754 /* So donate them to regular backref magic to keep them safe.
1755 The sv_magic will increase the reference count of the AV,
1756 so we need to drop it first. */
1757 SvREFCNT_dec(iter->xhv_backreferences);
1758 if (AvFILLp(iter->xhv_backreferences) == -1) {
1759 /* Turns out that the array is empty. Just free it. */
1760 SvREFCNT_dec(iter->xhv_backreferences);
1763 sv_magic((SV*)hv, (SV*)iter->xhv_backreferences,
1764 PERL_MAGIC_backref, NULL, 0);
1766 iter->xhv_backreferences = NULL;
1769 entry = iter->xhv_eiter; /* HvEITER(hv) */
1770 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1772 hv_free_ent(hv, entry);
1774 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1775 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1777 /* There are now no allocated pointers in the aux structure. */
1779 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
1780 /* What aux structure? */
1783 /* make everyone else think the array is empty, so that the destructors
1784 * called for freed entries can't recusively mess with us */
1787 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1791 /* Loop down the linked list heads */
1792 HE *entry = array[i];
1795 register HE * const oentry = entry;
1796 entry = HeNEXT(entry);
1797 hv_free_ent(hv, oentry);
1801 /* As there are no allocated pointers in the aux structure, it's now
1802 safe to free the array we just cleaned up, if it's not the one we're
1803 going to put back. */
1804 if (array != orig_array) {
1809 /* Good. No-one added anything this time round. */
1814 /* Someone attempted to iterate or set the hash name while we had
1815 the array set to 0. We'll catch backferences on the next time
1816 round the while loop. */
1817 assert(HvARRAY(hv));
1819 if (HvAUX(hv)->xhv_name) {
1820 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1824 if (--attempts == 0) {
1825 Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1829 HvARRAY(hv) = orig_array;
1831 /* If the hash was actually a symbol table, put the name back. */
1833 /* We have restored the original array. If name is non-NULL, then
1834 the original array had an aux structure at the end. So this is
1836 SvFLAGS(hv) |= SVf_OOK;
1837 HvAUX(hv)->xhv_name = name;
1842 =for apidoc hv_undef
1850 Perl_hv_undef(pTHX_ HV *hv)
1853 register XPVHV* xhv;
1858 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1859 xhv = (XPVHV*)SvANY(hv);
1861 if ((name = HvNAME_get(hv))) {
1863 hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1864 hv_name_set(hv, NULL, 0, 0);
1866 SvFLAGS(hv) &= ~SVf_OOK;
1867 Safefree(HvARRAY(hv));
1868 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1870 HvPLACEHOLDERS_set(hv, 0);
1876 static struct xpvhv_aux*
1877 S_hv_auxinit(HV *hv) {
1878 struct xpvhv_aux *iter;
1882 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1883 + sizeof(struct xpvhv_aux), char);
1885 array = (char *) HvARRAY(hv);
1886 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1887 + sizeof(struct xpvhv_aux), char);
1889 HvARRAY(hv) = (HE**) array;
1890 /* SvOOK_on(hv) attacks the IV flags. */
1891 SvFLAGS(hv) |= SVf_OOK;
1894 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1895 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1897 iter->xhv_backreferences = 0;
1902 =for apidoc hv_iterinit
1904 Prepares a starting point to traverse a hash table. Returns the number of
1905 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1906 currently only meaningful for hashes without tie magic.
1908 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1909 hash buckets that happen to be in use. If you still need that esoteric
1910 value, you can get it through the macro C<HvFILL(tb)>.
1917 Perl_hv_iterinit(pTHX_ HV *hv)
1920 Perl_croak(aTHX_ "Bad hash");
1923 struct xpvhv_aux * const iter = HvAUX(hv);
1924 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1925 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1927 hv_free_ent(hv, entry);
1929 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1930 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1934 if ( SvRMAGICAL(hv) ) {
1935 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names);
1938 const REGEXP * const rx = PM_GETRE(PL_curpm);
1939 if (rx && rx->paren_names) {
1940 (void)hv_iterinit(rx->paren_names);
1945 /* used to be xhv->xhv_fill before 5.004_65 */
1946 return HvTOTALKEYS(hv);
1950 Perl_hv_riter_p(pTHX_ HV *hv) {
1951 struct xpvhv_aux *iter;
1954 Perl_croak(aTHX_ "Bad hash");
1956 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1957 return &(iter->xhv_riter);
1961 Perl_hv_eiter_p(pTHX_ HV *hv) {
1962 struct xpvhv_aux *iter;
1965 Perl_croak(aTHX_ "Bad hash");
1967 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1968 return &(iter->xhv_eiter);
1972 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1973 struct xpvhv_aux *iter;
1976 Perl_croak(aTHX_ "Bad hash");
1984 iter = hv_auxinit(hv);
1986 iter->xhv_riter = riter;
1990 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1991 struct xpvhv_aux *iter;
1994 Perl_croak(aTHX_ "Bad hash");
1999 /* 0 is the default so don't go malloc()ing a new structure just to
2004 iter = hv_auxinit(hv);
2006 iter->xhv_eiter = eiter;
2010 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2013 struct xpvhv_aux *iter;
2016 PERL_UNUSED_ARG(flags);
2019 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2023 if (iter->xhv_name) {
2024 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2030 iter = hv_auxinit(hv);
2032 PERL_HASH(hash, name, len);
2033 iter->xhv_name = name ? share_hek(name, len, hash) : 0;
2037 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2038 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2039 PERL_UNUSED_CONTEXT;
2040 return &(iter->xhv_backreferences);
2044 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2050 av = HvAUX(hv)->xhv_backreferences;
2053 HvAUX(hv)->xhv_backreferences = 0;
2054 Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av);
2059 hv_iternext is implemented as a macro in hv.h
2061 =for apidoc hv_iternext
2063 Returns entries from a hash iterator. See C<hv_iterinit>.
2065 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2066 iterator currently points to, without losing your place or invalidating your
2067 iterator. Note that in this case the current entry is deleted from the hash
2068 with your iterator holding the last reference to it. Your iterator is flagged
2069 to free the entry on the next call to C<hv_iternext>, so you must not discard
2070 your iterator immediately else the entry will leak - call C<hv_iternext> to
2071 trigger the resource deallocation.
2073 =for apidoc hv_iternext_flags
2075 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
2076 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2077 set the placeholders keys (for restricted hashes) will be returned in addition
2078 to normal keys. By default placeholders are automatically skipped over.
2079 Currently a placeholder is implemented with a value that is
2080 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2081 restricted hashes may change, and the implementation currently is
2082 insufficiently abstracted for any change to be tidy.
2088 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2091 register XPVHV* xhv;
2095 struct xpvhv_aux *iter;
2098 Perl_croak(aTHX_ "Bad hash");
2100 xhv = (XPVHV*)SvANY(hv);
2103 /* Too many things (well, pp_each at least) merrily assume that you can
2104 call iv_iternext without calling hv_iterinit, so we'll have to deal
2110 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2111 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2112 if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names) ) ) {
2118 rx = PM_GETRE(PL_curpm);
2119 if (rx && rx->paren_names) {
2120 hv = rx->paren_names;
2125 key = sv_newmortal();
2127 sv_setsv(key, HeSVKEY_force(entry));
2128 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2134 /* one HE per MAGICAL hash */
2135 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2137 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
2139 HeKEY_hek(entry) = hek;
2140 HeKLEN(entry) = HEf_SVKEY;
2144 HE *temphe = hv_iternext_flags(hv,flags);
2148 SV* sv_dat = HeVAL(temphe);
2149 I32 *nums = (I32*)SvPVX(sv_dat);
2150 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
2151 if ((I32)(rx->lastcloseparen) >= nums[i] &&
2152 rx->startp[nums[i]] != -1 &&
2153 rx->endp[nums[i]] != -1)
2162 SV *sv = sv_newmortal();
2163 const char* pvkey = HePV(temphe, len);
2165 Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
2166 gv_paren = Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
2167 Perl_sv_setpvn(aTHX_ key, pvkey, len);
2168 val = GvSVn(gv_paren);
2175 if (val && SvOK(key)) {
2176 /* force key to stay around until next time */
2177 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2178 HeVAL(entry) = SvREFCNT_inc_simple_NN(val);
2179 return entry; /* beware, hent_val is not set */
2182 SvREFCNT_dec(HeVAL(entry));
2183 Safefree(HeKEY_hek(entry));
2185 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2188 else if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
2189 SV * const key = sv_newmortal();
2191 sv_setsv(key, HeSVKEY_force(entry));
2192 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2198 /* one HE per MAGICAL hash */
2199 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2201 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
2203 HeKEY_hek(entry) = hek;
2204 HeKLEN(entry) = HEf_SVKEY;
2206 magic_nextpack((SV*) hv,mg,key);
2208 /* force key to stay around until next time */
2209 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2210 return entry; /* beware, hent_val is not set */
2213 SvREFCNT_dec(HeVAL(entry));
2214 Safefree(HeKEY_hek(entry));
2216 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2220 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
2221 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
2224 /* The prime_env_iter() on VMS just loaded up new hash values
2225 * so the iteration count needs to be reset back to the beginning
2229 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2234 /* hv_iterint now ensures this. */
2235 assert (HvARRAY(hv));
2237 /* At start of hash, entry is NULL. */
2240 entry = HeNEXT(entry);
2241 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2243 * Skip past any placeholders -- don't want to include them in
2246 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2247 entry = HeNEXT(entry);
2252 /* OK. Come to the end of the current list. Grab the next one. */
2254 iter->xhv_riter++; /* HvRITER(hv)++ */
2255 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2256 /* There is no next one. End of the hash. */
2257 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2260 entry = (HvARRAY(hv))[iter->xhv_riter];
2262 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2263 /* If we have an entry, but it's a placeholder, don't count it.
2265 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2266 entry = HeNEXT(entry);
2268 /* Will loop again if this linked list starts NULL
2269 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2270 or if we run through it and find only placeholders. */
2273 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2275 hv_free_ent(hv, oldentry);
2278 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2279 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
2281 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2286 =for apidoc hv_iterkey
2288 Returns the key from the current position of the hash iterator. See
2295 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2297 if (HeKLEN(entry) == HEf_SVKEY) {
2299 char * const p = SvPV(HeKEY_sv(entry), len);
2304 *retlen = HeKLEN(entry);
2305 return HeKEY(entry);
2309 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2311 =for apidoc hv_iterkeysv
2313 Returns the key as an C<SV*> from the current position of the hash
2314 iterator. The return value will always be a mortal copy of the key. Also
2321 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2323 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2327 =for apidoc hv_iterval
2329 Returns the value from the current position of the hash iterator. See
2336 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2338 if (SvRMAGICAL(hv)) {
2339 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2340 SV* const sv = sv_newmortal();
2341 if (HeKLEN(entry) == HEf_SVKEY)
2342 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2344 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2348 return HeVAL(entry);
2352 =for apidoc hv_iternextsv
2354 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2361 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2363 HE * const he = hv_iternext_flags(hv, 0);
2367 *key = hv_iterkey(he, retlen);
2368 return hv_iterval(hv, he);
2375 =for apidoc hv_magic
2377 Adds magic to a hash. See C<sv_magic>.
2382 /* possibly free a shared string if no one has access to it
2383 * len and hash must both be valid for str.
2386 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2388 unshare_hek_or_pvn (NULL, str, len, hash);
2393 Perl_unshare_hek(pTHX_ HEK *hek)
2395 unshare_hek_or_pvn(hek, NULL, 0, 0);
2398 /* possibly free a shared string if no one has access to it
2399 hek if non-NULL takes priority over the other 3, else str, len and hash
2400 are used. If so, len and hash must both be valid for str.
2403 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2406 register XPVHV* xhv;
2408 register HE **oentry;
2410 bool is_utf8 = FALSE;
2412 const char * const save = str;
2413 struct shared_he *he = NULL;
2416 /* Find the shared he which is just before us in memory. */
2417 he = (struct shared_he *)(((char *)hek)
2418 - STRUCT_OFFSET(struct shared_he,
2421 /* Assert that the caller passed us a genuine (or at least consistent)
2423 assert (he->shared_he_he.hent_hek == hek);
2426 if (he->shared_he_he.he_valu.hent_refcount - 1) {
2427 --he->shared_he_he.he_valu.hent_refcount;
2428 UNLOCK_STRTAB_MUTEX;
2431 UNLOCK_STRTAB_MUTEX;
2433 hash = HEK_HASH(hek);
2434 } else if (len < 0) {
2435 STRLEN tmplen = -len;
2437 /* See the note in hv_fetch(). --jhi */
2438 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2441 k_flags = HVhek_UTF8;
2443 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2446 /* what follows was the moral equivalent of:
2447 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2449 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2451 xhv = (XPVHV*)SvANY(PL_strtab);
2452 /* assert(xhv_array != 0) */
2454 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2456 const HE *const he_he = &(he->shared_he_he);
2457 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2462 const int flags_masked = k_flags & HVhek_MASK;
2463 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2464 if (HeHASH(entry) != hash) /* strings can't be equal */
2466 if (HeKLEN(entry) != len)
2468 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2470 if (HeKFLAGS(entry) != flags_masked)
2477 if (--entry->he_valu.hent_refcount == 0) {
2478 *oentry = HeNEXT(entry);
2480 /* There are now no entries in our slot. */
2481 xhv->xhv_fill--; /* HvFILL(hv)-- */
2484 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2488 UNLOCK_STRTAB_MUTEX;
2489 if (!entry && ckWARN_d(WARN_INTERNAL))
2490 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2491 "Attempt to free non-existent shared string '%s'%s"
2493 hek ? HEK_KEY(hek) : str,
2494 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2495 if (k_flags & HVhek_FREEKEY)
2499 /* get a (constant) string ptr from the global string table
2500 * string will get added if it is not already there.
2501 * len and hash must both be valid for str.
2504 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2506 bool is_utf8 = FALSE;
2508 const char * const save = str;
2511 STRLEN tmplen = -len;
2513 /* See the note in hv_fetch(). --jhi */
2514 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2516 /* If we were able to downgrade here, then than means that we were passed
2517 in a key which only had chars 0-255, but was utf8 encoded. */
2520 /* If we found we were able to downgrade the string to bytes, then
2521 we should flag that it needs upgrading on keys or each. Also flag
2522 that we need share_hek_flags to free the string. */
2524 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2527 return share_hek_flags (str, len, hash, flags);
2531 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2535 const int flags_masked = flags & HVhek_MASK;
2536 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2538 /* what follows is the moral equivalent of:
2540 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2541 hv_store(PL_strtab, str, len, NULL, hash);
2543 Can't rehash the shared string table, so not sure if it's worth
2544 counting the number of entries in the linked list
2546 register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2547 /* assert(xhv_array != 0) */
2549 entry = (HvARRAY(PL_strtab))[hindex];
2550 for (;entry; entry = HeNEXT(entry)) {
2551 if (HeHASH(entry) != hash) /* strings can't be equal */
2553 if (HeKLEN(entry) != len)
2555 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2557 if (HeKFLAGS(entry) != flags_masked)
2563 /* What used to be head of the list.
2564 If this is NULL, then we're the first entry for this slot, which
2565 means we need to increate fill. */
2566 struct shared_he *new_entry;
2569 HE **const head = &HvARRAY(PL_strtab)[hindex];
2570 HE *const next = *head;
2572 /* We don't actually store a HE from the arena and a regular HEK.
2573 Instead we allocate one chunk of memory big enough for both,
2574 and put the HEK straight after the HE. This way we can find the
2575 HEK directly from the HE.
2578 Newx(k, STRUCT_OFFSET(struct shared_he,
2579 shared_he_hek.hek_key[0]) + len + 2, char);
2580 new_entry = (struct shared_he *)k;
2581 entry = &(new_entry->shared_he_he);
2582 hek = &(new_entry->shared_he_hek);
2584 Copy(str, HEK_KEY(hek), len, char);
2585 HEK_KEY(hek)[len] = 0;
2587 HEK_HASH(hek) = hash;
2588 HEK_FLAGS(hek) = (unsigned char)flags_masked;
2590 /* Still "point" to the HEK, so that other code need not know what
2592 HeKEY_hek(entry) = hek;
2593 entry->he_valu.hent_refcount = 0;
2594 HeNEXT(entry) = next;
2597 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2598 if (!next) { /* initial entry? */
2599 xhv->xhv_fill++; /* HvFILL(hv)++ */
2600 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2605 ++entry->he_valu.hent_refcount;
2606 UNLOCK_STRTAB_MUTEX;
2608 if (flags & HVhek_FREEKEY)
2611 return HeKEY_hek(entry);
2615 S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action)
2618 if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
2619 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2620 if (uf->uf_set == NULL) {
2621 SV* obj = mg->mg_obj;
2622 mg->mg_obj = keysv; /* pass key */
2623 uf->uf_index = action; /* pass action */
2624 magic_getuvar((SV*)hv, mg);
2625 keysv = mg->mg_obj; /* may have changed */
2633 Perl_hv_placeholders_p(pTHX_ HV *hv)
2636 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2639 mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2642 Perl_die(aTHX_ "panic: hv_placeholders_p");
2645 return &(mg->mg_len);
2650 Perl_hv_placeholders_get(pTHX_ HV *hv)
2653 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2655 return mg ? mg->mg_len : 0;
2659 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2662 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2667 if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2668 Perl_die(aTHX_ "panic: hv_placeholders_set");
2670 /* else we don't need to add magic to record 0 placeholders. */
2674 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2678 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2683 value = &PL_sv_placeholder;
2686 value = (he->refcounted_he_data[0] & HVrhek_UV)
2687 ? newSVuv(he->refcounted_he_val.refcounted_he_u_iv)
2688 : newSViv(he->refcounted_he_val.refcounted_he_u_uv);
2691 /* Create a string SV that directly points to the bytes in our
2694 sv_upgrade(value, SVt_PV);
2695 SvPV_set(value, (char *) he->refcounted_he_data + 1);
2696 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2697 /* This stops anything trying to free it */
2698 SvLEN_set(value, 0);
2700 SvREADONLY_on(value);
2701 if (he->refcounted_he_data[0] & HVrhek_UTF8)
2705 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2706 he->refcounted_he_data[0]);
2712 /* A big expression to find the key offset */
2713 #define REF_HE_KEY(chain) \
2714 ((((chain->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV) \
2715 ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \
2716 + 1 + chain->refcounted_he_data)
2720 =for apidoc refcounted_he_chain_2hv
2722 Generates an returns a C<HV *> by walking up the tree starting at the passed
2723 in C<struct refcounted_he *>.
2728 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2732 U32 placeholders = 0;
2733 /* We could chase the chain once to get an idea of the number of keys,
2734 and call ksplit. But for now we'll make a potentially inefficient
2735 hash with only 8 entries in its array. */
2736 const U32 max = HvMAX(hv);
2740 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2741 HvARRAY(hv) = (HE**)array;
2746 U32 hash = chain->refcounted_he_hash;
2748 U32 hash = HEK_HASH(chain->refcounted_he_hek);
2750 HE **oentry = &((HvARRAY(hv))[hash & max]);
2751 HE *entry = *oentry;
2754 for (; entry; entry = HeNEXT(entry)) {
2755 if (HeHASH(entry) == hash) {
2756 /* We might have a duplicate key here. If so, entry is older
2757 than the key we've already put in the hash, so if they are
2758 the same, skip adding entry. */
2760 const STRLEN klen = HeKLEN(entry);
2761 const char *const key = HeKEY(entry);
2762 if (klen == chain->refcounted_he_keylen
2763 && (!!HeKUTF8(entry)
2764 == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2765 && memEQ(key, REF_HE_KEY(chain), klen))
2768 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2770 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2771 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2772 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2783 = share_hek_flags(REF_HE_KEY(chain),
2784 chain->refcounted_he_keylen,
2785 chain->refcounted_he_hash,
2786 (chain->refcounted_he_data[0]
2787 & (HVhek_UTF8|HVhek_WASUTF8)));
2789 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2791 value = refcounted_he_value(chain);
2792 if (value == &PL_sv_placeholder)
2794 HeVAL(entry) = value;
2796 /* Link it into the chain. */
2797 HeNEXT(entry) = *oentry;
2798 if (!HeNEXT(entry)) {
2799 /* initial entry. */
2807 chain = chain->refcounted_he_next;
2811 clear_placeholders(hv, placeholders);
2812 HvTOTALKEYS(hv) -= placeholders;
2815 /* We could check in the loop to see if we encounter any keys with key
2816 flags, but it's probably not worth it, as this per-hash flag is only
2817 really meant as an optimisation for things like Storable. */
2819 DEBUG_A(Perl_hv_assert(aTHX_ hv));
2825 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2826 const char *key, STRLEN klen, int flags, U32 hash)
2829 /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2830 of your key has to exactly match that which is stored. */
2831 SV *value = &PL_sv_placeholder;
2835 if (flags & HVhek_FREEKEY)
2837 key = SvPV_const(keysv, klen);
2839 is_utf8 = (SvUTF8(keysv) != 0);
2841 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
2845 if (keysv && (SvIsCOW_shared_hash(keysv))) {
2846 hash = SvSHARED_HASH(keysv);
2848 PERL_HASH(hash, key, klen);
2852 for (; chain; chain = chain->refcounted_he_next) {
2854 if (hash != chain->refcounted_he_hash)
2856 if (klen != chain->refcounted_he_keylen)
2858 if (memNE(REF_HE_KEY(chain),key,klen))
2860 if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2863 if (hash != HEK_HASH(chain->refcounted_he_hek))
2865 if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
2867 if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2869 if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2873 value = sv_2mortal(refcounted_he_value(chain));
2877 if (flags & HVhek_FREEKEY)
2884 =for apidoc refcounted_he_new
2886 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2887 stored in a compact form, all references remain the property of the caller.
2888 The C<struct refcounted_he> is returned with a reference count of 1.
2893 struct refcounted_he *
2894 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2895 SV *const key, SV *const value) {
2897 struct refcounted_he *he;
2899 const char *key_p = SvPV_const(key, key_len);
2900 STRLEN value_len = 0;
2901 const char *value_p = NULL;
2906 bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
2909 value_type = HVrhek_PV;
2910 } else if (SvIOK(value)) {
2911 value_type = HVrhek_IV;
2912 } else if (value == &PL_sv_placeholder) {
2913 value_type = HVrhek_delete;
2914 } else if (!SvOK(value)) {
2915 value_type = HVrhek_undef;
2917 value_type = HVrhek_PV;
2920 if (value_type == HVrhek_PV) {
2921 value_p = SvPV_const(value, value_len);
2922 key_offset = value_len + 2;
2930 he = (struct refcounted_he*)
2931 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2935 he = (struct refcounted_he*)
2936 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2941 he->refcounted_he_next = parent;
2943 if (value_type == HVrhek_PV) {
2944 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
2945 he->refcounted_he_val.refcounted_he_u_len = value_len;
2946 if (SvUTF8(value)) {
2947 flags |= HVrhek_UTF8;
2949 } else if (value_type == HVrhek_IV) {
2951 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
2954 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
2959 /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2960 As we're going to be building hash keys from this value in future,
2961 normalise it now. */
2962 key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2963 flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2965 PERL_HASH(hash, key_p, key_len);
2968 he->refcounted_he_hash = hash;
2969 he->refcounted_he_keylen = key_len;
2970 Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
2972 he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
2975 if (flags & HVhek_WASUTF8) {
2976 /* If it was downgraded from UTF-8, then the pointer returned from
2977 bytes_from_utf8 is an allocated pointer that we must free. */
2981 he->refcounted_he_data[0] = flags;
2982 he->refcounted_he_refcnt = 1;
2988 =for apidoc refcounted_he_free
2990 Decrements the reference count of the passed in C<struct refcounted_he *>
2991 by one. If the reference count reaches zero the structure's memory is freed,
2992 and C<refcounted_he_free> iterates onto the parent node.
2998 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
2999 PERL_UNUSED_CONTEXT;
3002 struct refcounted_he *copy;
3006 new_count = --he->refcounted_he_refcnt;
3007 HINTS_REFCNT_UNLOCK;
3013 #ifndef USE_ITHREADS
3014 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3017 he = he->refcounted_he_next;
3018 PerlMemShared_free(copy);
3023 =for apidoc hv_assert
3025 Check that a hash is in an internally consistent state.
3033 Perl_hv_assert(pTHX_ HV *hv)
3038 int placeholders = 0;
3041 const I32 riter = HvRITER_get(hv);
3042 HE *eiter = HvEITER_get(hv);
3044 (void)hv_iterinit(hv);
3046 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3047 /* sanity check the values */
3048 if (HeVAL(entry) == &PL_sv_placeholder)
3052 /* sanity check the keys */
3053 if (HeSVKEY(entry)) {
3054 NOOP; /* Don't know what to check on SV keys. */
3055 } else if (HeKUTF8(entry)) {
3057 if (HeKWASUTF8(entry)) {
3058 PerlIO_printf(Perl_debug_log,
3059 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
3060 (int) HeKLEN(entry), HeKEY(entry));
3063 } else if (HeKWASUTF8(entry))
3066 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
3067 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3068 const int nhashkeys = HvUSEDKEYS(hv);
3069 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3071 if (nhashkeys != real) {
3072 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3075 if (nhashplaceholders != placeholders) {
3076 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3080 if (withflags && ! HvHASKFLAGS(hv)) {
3081 PerlIO_printf(Perl_debug_log,
3082 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3089 HvRITER_set(hv, riter); /* Restore hash iterator state */
3090 HvEITER_set(hv, eiter);
3097 * c-indentation-style: bsd
3099 * indent-tabs-mode: t
3102 * ex: set ts=8 sts=4 sw=4 noet: