3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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
13 * of all that I have seen.
16 * [p.278 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
20 =head1 Hash Manipulation Functions
21 A HV structure represents a Perl hash. It consists mainly of an array
22 of pointers, each of which points to a linked list of HE structures. The
23 array is indexed by the hash function of the key, so each linked list
24 represents all the hash entries with the same hash value. Each HE contains
25 a pointer to the actual value, plus a pointer to a HEK structure which
26 holds the key and hash value.
34 #define PERL_HASH_INTERNAL_ACCESS
37 /* we split when we collide and we have a load factor over 0.667.
38 * NOTE if you change this formula so we split earlier than previously
39 * you MUST change the logic in hv_ksplit()
41 #define DO_HSPLIT(xhv) ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1)) > (xhv)->xhv_max )
42 #define HV_FILL_THRESHOLD 31
44 static const char S_strtab_error[]
45 = "Cannot modify shared string table in hv_%s";
49 #define new_HE() (HE*)safemalloc(sizeof(HE))
50 #define del_HE(p) safefree((char*)p)
58 void ** const root = &PL_body_roots[HE_SVSLOT];
61 Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE);
68 #define new_HE() new_he()
71 HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \
72 PL_body_roots[HE_SVSLOT] = p; \
80 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
82 const int flags_masked = flags & HVhek_MASK;
86 PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
88 Newx(k, HEK_BASESIZE + len + 2, char);
90 Copy(str, HEK_KEY(hek), len, char);
91 HEK_KEY(hek)[len] = 0;
94 HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
96 if (flags & HVhek_FREEKEY)
101 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
105 Perl_free_tied_hv_pool(pTHX)
107 HE *he = PL_hv_fetch_ent_mh;
110 Safefree(HeKEY_hek(he));
114 PL_hv_fetch_ent_mh = NULL;
117 #if defined(USE_ITHREADS)
119 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
123 PERL_ARGS_ASSERT_HEK_DUP;
124 PERL_UNUSED_ARG(param);
129 shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
131 /* We already shared this hash key. */
132 (void)share_hek_hek(shared);
136 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
137 HEK_HASH(source), HEK_FLAGS(source));
138 ptr_table_store(PL_ptr_table, source, shared);
144 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
148 PERL_ARGS_ASSERT_HE_DUP;
152 /* look for it in the table first */
153 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
157 /* create anew and remember what it is */
159 ptr_table_store(PL_ptr_table, e, ret);
161 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
162 if (HeKLEN(e) == HEf_SVKEY) {
164 Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
165 HeKEY_hek(ret) = (HEK*)k;
166 HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param);
169 /* This is hek_dup inlined, which seems to be important for speed
171 HEK * const source = HeKEY_hek(e);
172 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
175 /* We already shared this hash key. */
176 (void)share_hek_hek(shared);
180 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
181 HEK_HASH(source), HEK_FLAGS(source));
182 ptr_table_store(PL_ptr_table, source, shared);
184 HeKEY_hek(ret) = shared;
187 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
189 HeVAL(ret) = sv_dup_inc(HeVAL(e), param);
192 #endif /* USE_ITHREADS */
195 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
198 SV * const sv = sv_newmortal();
200 PERL_ARGS_ASSERT_HV_NOTALLOWED;
202 if (!(flags & HVhek_FREEKEY)) {
203 sv_setpvn(sv, key, klen);
206 /* Need to free saved eventually assign to mortal SV */
207 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
208 sv_usepvn(sv, (char *) key, klen);
210 if (flags & HVhek_UTF8) {
213 Perl_croak(aTHX_ msg, SVfARG(sv));
216 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
222 Stores an SV in a hash. The hash key is specified as C<key> and the
223 absolute value of C<klen> is the length of the key. If C<klen> is
224 negative the key is assumed to be in UTF-8-encoded Unicode. The
225 C<hash> parameter is the precomputed hash value; if it is zero then
226 Perl will compute it.
228 The return value will be
229 C<NULL> if the operation failed or if the value did not need to be actually
230 stored within the hash (as in the case of tied hashes). Otherwise it can
231 be dereferenced to get the original C<SV*>. Note that the caller is
232 responsible for suitably incrementing the reference count of C<val> before
233 the call, and decrementing it if the function returned C<NULL>. Effectively
234 a successful C<hv_store> takes ownership of one reference to C<val>. This is
235 usually what you want; a newly created SV has a reference count of one, so
236 if all your code does is create SVs then store them in a hash, C<hv_store>
237 will own the only reference to the new SV, and your code doesn't need to do
238 anything further to tidy up. C<hv_store> is not implemented as a call to
239 C<hv_store_ent>, and does not create a temporary SV for the key, so if your
240 key data is not already in SV form then use C<hv_store> in preference to
243 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
244 information on how to use this function on tied hashes.
246 =for apidoc hv_store_ent
248 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
249 parameter is the precomputed hash value; if it is zero then Perl will
250 compute it. The return value is the new hash entry so created. It will be
251 C<NULL> if the operation failed or if the value did not need to be actually
252 stored within the hash (as in the case of tied hashes). Otherwise the
253 contents of the return value can be accessed using the C<He?> macros
254 described here. Note that the caller is responsible for suitably
255 incrementing the reference count of C<val> before the call, and
256 decrementing it if the function returned NULL. Effectively a successful
257 C<hv_store_ent> takes ownership of one reference to C<val>. This is
258 usually what you want; a newly created SV has a reference count of one, so
259 if all your code does is create SVs then store them in a hash, C<hv_store>
260 will own the only reference to the new SV, and your code doesn't need to do
261 anything further to tidy up. Note that C<hv_store_ent> only reads the C<key>;
262 unlike C<val> it does not take ownership of it, so maintaining the correct
263 reference count on C<key> is entirely the caller's responsibility. C<hv_store>
264 is not implemented as a call to C<hv_store_ent>, and does not create a temporary
265 SV for the key, so if your key data is not already in SV form then use
266 C<hv_store> in preference to C<hv_store_ent>.
268 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
269 information on how to use this function on tied hashes.
271 =for apidoc hv_exists
273 Returns a boolean indicating whether the specified hash key exists. The
274 absolute value of C<klen> is the length of the key. If C<klen> is
275 negative the key is assumed to be in UTF-8-encoded Unicode.
279 Returns the SV which corresponds to the specified key in the hash.
280 The absolute value of C<klen> is the length of the key. If C<klen> is
281 negative the key is assumed to be in UTF-8-encoded Unicode. If
282 C<lval> is set then the fetch will be part of a store. This means that if
283 there is no value in the hash associated with the given key, then one is
284 created and a pointer to it is returned. The C<SV*> it points to can be
285 assigned to. But always check that the
286 return value is non-null before dereferencing it to an C<SV*>.
288 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
289 information on how to use this function on tied hashes.
291 =for apidoc hv_exists_ent
293 Returns a boolean indicating whether
294 the specified hash key exists. C<hash>
295 can be a valid precomputed hash value, or 0 to ask for it to be
301 /* returns an HE * structure with the all fields set */
302 /* note that hent_val will be a mortal sv for MAGICAL hashes */
304 =for apidoc hv_fetch_ent
306 Returns the hash entry which corresponds to the specified key in the hash.
307 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
308 if you want the function to compute it. IF C<lval> is set then the fetch
309 will be part of a store. Make sure the return value is non-null before
310 accessing it. The return value when C<hv> is a tied hash is a pointer to a
311 static location, so be sure to make a copy of the structure if you need to
314 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
315 information on how to use this function on tied hashes.
320 /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */
322 Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
323 const int action, SV *val, const U32 hash)
328 PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN;
337 return hv_common(hv, NULL, key, klen, flags, action, val, hash);
341 Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
342 int flags, int action, SV *val, U32 hash)
352 const int return_svp = action & HV_FETCH_JUST_SV;
353 HEK *keysv_hek = NULL;
357 if (SvTYPE(hv) == (svtype)SVTYPEMASK)
360 assert(SvTYPE(hv) == SVt_PVHV);
362 if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
364 if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) {
365 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
366 if (uf->uf_set == NULL) {
367 SV* obj = mg->mg_obj;
370 keysv = newSVpvn_flags(key, klen, SVs_TEMP |
371 ((flags & HVhek_UTF8)
375 mg->mg_obj = keysv; /* pass key */
376 uf->uf_index = action; /* pass action */
377 magic_getuvar(MUTABLE_SV(hv), mg);
378 keysv = mg->mg_obj; /* may have changed */
381 /* If the key may have changed, then we need to invalidate
382 any passed-in computed hash value. */
388 if (flags & HVhek_FREEKEY)
390 key = SvPV_const(keysv, klen);
391 is_utf8 = (SvUTF8(keysv) != 0);
392 if (SvIsCOW_shared_hash(keysv)) {
393 flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
395 flags = is_utf8 ? HVhek_UTF8 : 0;
398 is_utf8 = cBOOL(flags & HVhek_UTF8);
401 if (action & HV_DELETE) {
402 return (void *) hv_delete_common(hv, keysv, key, klen,
403 flags, action, hash);
406 xhv = (XPVHV*)SvANY(hv);
408 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
409 if (mg_find((const SV *)hv, PERL_MAGIC_tied)
410 || SvGMAGICAL((const SV *)hv))
412 /* FIXME should be able to skimp on the HE/HEK here when
413 HV_FETCH_JUST_SV is true. */
415 keysv = newSVpvn_utf8(key, klen, is_utf8);
417 keysv = newSVsv(keysv);
420 mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY);
422 /* grab a fake HE/HEK pair from the pool or make a new one */
423 entry = PL_hv_fetch_ent_mh;
425 PL_hv_fetch_ent_mh = HeNEXT(entry);
429 Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
430 HeKEY_hek(entry) = (HEK*)k;
432 HeNEXT(entry) = NULL;
433 HeSVKEY_set(entry, keysv);
435 sv_upgrade(sv, SVt_PVLV);
437 /* so we can free entry when freeing sv */
438 LvTARG(sv) = MUTABLE_SV(entry);
440 /* XXX remove at some point? */
441 if (flags & HVhek_FREEKEY)
445 return entry ? (void *) &HeVAL(entry) : NULL;
447 return (void *) entry;
449 #ifdef ENV_IS_CASELESS
450 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
452 for (i = 0; i < klen; ++i)
453 if (isLOWER(key[i])) {
454 /* Would be nice if we had a routine to do the
455 copy and upercase in a single pass through. */
456 const char * const nkey = strupr(savepvn(key,klen));
457 /* Note that this fetch is for nkey (the uppercased
458 key) whereas the store is for key (the original) */
459 void *result = hv_common(hv, NULL, nkey, klen,
460 HVhek_FREEKEY, /* free nkey */
461 0 /* non-LVAL fetch */
462 | HV_DISABLE_UVAR_XKEY
465 0 /* compute hash */);
466 if (!result && (action & HV_FETCH_LVALUE)) {
467 /* This call will free key if necessary.
468 Do it this way to encourage compiler to tail
470 result = hv_common(hv, keysv, key, klen, flags,
472 | HV_DISABLE_UVAR_XKEY
476 if (flags & HVhek_FREEKEY)
484 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
485 if (mg_find((const SV *)hv, PERL_MAGIC_tied)
486 || SvGMAGICAL((const SV *)hv)) {
487 /* I don't understand why hv_exists_ent has svret and sv,
488 whereas hv_exists only had one. */
489 SV * const svret = sv_newmortal();
492 if (keysv || is_utf8) {
494 keysv = newSVpvn_utf8(key, klen, TRUE);
496 keysv = newSVsv(keysv);
498 mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
500 mg_copy(MUTABLE_SV(hv), sv, key, klen);
502 if (flags & HVhek_FREEKEY)
505 MAGIC * const mg = mg_find(sv, PERL_MAGIC_tiedelem);
507 magic_existspack(svret, mg);
509 /* This cast somewhat evil, but I'm merely using NULL/
510 not NULL to return the boolean exists.
511 And I know hv is not NULL. */
512 return SvTRUE(svret) ? (void *)hv : NULL;
514 #ifdef ENV_IS_CASELESS
515 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
516 /* XXX This code isn't UTF8 clean. */
517 char * const keysave = (char * const)key;
518 /* Will need to free this, so set FREEKEY flag. */
519 key = savepvn(key,klen);
520 key = (const char*)strupr((char*)key);
525 if (flags & HVhek_FREEKEY) {
528 flags |= HVhek_FREEKEY;
532 else if (action & HV_FETCH_ISSTORE) {
535 hv_magic_check (hv, &needs_copy, &needs_store);
537 const bool save_taint = TAINT_get;
538 if (keysv || is_utf8) {
540 keysv = newSVpvn_utf8(key, klen, TRUE);
543 TAINT_set(SvTAINTED(keysv));
544 keysv = sv_2mortal(newSVsv(keysv));
545 mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
547 mg_copy(MUTABLE_SV(hv), val, key, klen);
550 TAINT_IF(save_taint);
551 #ifdef NO_TAINT_SUPPORT
552 PERL_UNUSED_VAR(save_taint);
555 if (flags & HVhek_FREEKEY)
559 #ifdef ENV_IS_CASELESS
560 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
561 /* XXX This code isn't UTF8 clean. */
562 const char *keysave = key;
563 /* Will need to free this, so set FREEKEY flag. */
564 key = savepvn(key,klen);
565 key = (const char*)strupr((char*)key);
570 if (flags & HVhek_FREEKEY) {
573 flags |= HVhek_FREEKEY;
581 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
582 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
583 || (SvRMAGICAL((const SV *)hv)
584 && mg_find((const SV *)hv, PERL_MAGIC_env))
589 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
591 HvARRAY(hv) = (HE**)array;
593 #ifdef DYNAMIC_ENV_FETCH
594 else if (action & HV_FETCH_ISEXISTS) {
595 /* for an %ENV exists, if we do an insert it's by a recursive
596 store call, so avoid creating HvARRAY(hv) right now. */
600 /* XXX remove at some point? */
601 if (flags & HVhek_FREEKEY)
608 if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) {
609 char * const keysave = (char *)key;
610 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
614 flags &= ~HVhek_UTF8;
615 if (key != keysave) {
616 if (flags & HVhek_FREEKEY)
618 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
619 /* If the caller calculated a hash, it was on the sequence of
620 octets that are the UTF-8 form. We've now changed the sequence
621 of octets stored to that of the equivalent byte representation,
622 so the hash we need is different. */
627 if (keysv && (SvIsCOW_shared_hash(keysv))) {
629 keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
630 hash = SvSHARED_HASH(keysv);
633 PERL_HASH(hash, key, klen);
635 masked_flags = (flags & HVhek_MASK);
637 #ifdef DYNAMIC_ENV_FETCH
638 if (!HvARRAY(hv)) entry = NULL;
642 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
649 /* keysv is actually a HEK in disguise, so we can match just by
650 * comparing the HEK pointers in the HE chain. There is a slight
651 * caveat: on something like "\x80", which has both plain and utf8
652 * representations, perl's hashes do encoding-insensitive lookups,
653 * but preserve the encoding of the stored key. Thus a particular
654 * key could map to two different HEKs in PL_strtab. We only
655 * conclude 'not found' if all the flags are the same; otherwise
656 * we fall back to a full search (this should only happen in rare
659 int keysv_flags = HEK_FLAGS(keysv_hek);
660 HE *orig_entry = entry;
662 for (; entry; entry = HeNEXT(entry)) {
663 HEK *hek = HeKEY_hek(entry);
664 if (hek == keysv_hek)
666 if (HEK_FLAGS(hek) != keysv_flags)
667 break; /* need to do full match */
671 /* failed on shortcut - do full search loop */
675 for (; entry; entry = HeNEXT(entry)) {
676 if (HeHASH(entry) != hash) /* strings can't be equal */
678 if (HeKLEN(entry) != (I32)klen)
680 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
682 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
686 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
687 if (HeKFLAGS(entry) != masked_flags) {
688 /* We match if HVhek_UTF8 bit in our flags and hash key's
689 match. But if entry was set previously with HVhek_WASUTF8
690 and key now doesn't (or vice versa) then we should change
691 the key's flag, as this is assignment. */
692 if (HvSHAREKEYS(hv)) {
693 /* Need to swap the key we have for a key with the flags we
694 need. As keys are shared we can't just write to the
695 flag, so we share the new one, unshare the old one. */
696 HEK * const new_hek = share_hek_flags(key, klen, hash,
698 unshare_hek (HeKEY_hek(entry));
699 HeKEY_hek(entry) = new_hek;
701 else if (hv == PL_strtab) {
702 /* PL_strtab is usually the only hash without HvSHAREKEYS,
703 so putting this test here is cheap */
704 if (flags & HVhek_FREEKEY)
706 Perl_croak(aTHX_ S_strtab_error,
707 action & HV_FETCH_LVALUE ? "fetch" : "store");
710 HeKFLAGS(entry) = masked_flags;
711 if (masked_flags & HVhek_ENABLEHVKFLAGS)
714 if (HeVAL(entry) == &PL_sv_placeholder) {
715 /* yes, can store into placeholder slot */
716 if (action & HV_FETCH_LVALUE) {
718 /* This preserves behaviour with the old hv_fetch
719 implementation which at this point would bail out
720 with a break; (at "if we find a placeholder, we
721 pretend we haven't found anything")
723 That break mean that if a placeholder were found, it
724 caused a call into hv_store, which in turn would
725 check magic, and if there is no magic end up pretty
726 much back at this point (in hv_store's code). */
729 /* LVAL fetch which actually needs a store. */
731 HvPLACEHOLDERS(hv)--;
734 if (val != &PL_sv_placeholder)
735 HvPLACEHOLDERS(hv)--;
738 } else if (action & HV_FETCH_ISSTORE) {
739 SvREFCNT_dec(HeVAL(entry));
742 } else if (HeVAL(entry) == &PL_sv_placeholder) {
743 /* if we find a placeholder, we pretend we haven't found
747 if (flags & HVhek_FREEKEY)
750 return (void *) &HeVAL(entry);
756 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
757 if (!(action & HV_FETCH_ISSTORE)
758 && SvRMAGICAL((const SV *)hv)
759 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
761 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
763 sv = newSVpvn(env,len);
765 return hv_common(hv, keysv, key, klen, flags,
766 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
772 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
773 hv_notallowed(flags, key, klen,
774 "Attempt to access disallowed key '%" SVf "' in"
775 " a restricted hash");
777 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
778 /* Not doing some form of store, so return failure. */
779 if (flags & HVhek_FREEKEY)
783 if (action & HV_FETCH_LVALUE) {
784 val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0);
786 /* At this point the old hv_fetch code would call to hv_store,
787 which in turn might do some tied magic. So we need to make that
788 magic check happen. */
789 /* gonna assign to this, so it better be there */
790 /* If a fetch-as-store fails on the fetch, then the action is to
791 recurse once into "hv_store". If we didn't do this, then that
792 recursive call would call the key conversion routine again.
793 However, as we replace the original key with the converted
794 key, this would result in a double conversion, which would show
795 up as a bug if the conversion routine is not idempotent.
796 Hence the use of HV_DISABLE_UVAR_XKEY. */
797 return hv_common(hv, keysv, key, klen, flags,
798 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
800 /* XXX Surely that could leak if the fetch-was-store fails?
801 Just like the hv_fetch. */
805 /* Welcome to hv_store... */
808 /* Not sure if we can get here. I think the only case of oentry being
809 NULL is for %ENV with dynamic env fetch. But that should disappear
810 with magic in the previous code. */
813 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
815 HvARRAY(hv) = (HE**)array;
818 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
821 /* share_hek_flags will do the free for us. This might be considered
824 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
825 else if (hv == PL_strtab) {
826 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
827 this test here is cheap */
828 if (flags & HVhek_FREEKEY)
830 Perl_croak(aTHX_ S_strtab_error,
831 action & HV_FETCH_LVALUE ? "fetch" : "store");
833 else /* gotta do the real thing */
834 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
837 #ifdef PERL_HASH_RANDOMIZE_KEYS
838 /* This logic semi-randomizes the insert order in a bucket.
839 * Either we insert into the top, or the slot below the top,
840 * making it harder to see if there is a collision. We also
841 * reset the iterator randomizer if there is one.
843 in_collision = *oentry != NULL;
844 if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
846 PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
847 if ( PL_hash_rand_bits & 1 ) {
848 HeNEXT(entry) = HeNEXT(*oentry);
849 HeNEXT(*oentry) = entry;
851 HeNEXT(entry) = *oentry;
857 HeNEXT(entry) = *oentry;
860 #ifdef PERL_HASH_RANDOMIZE_KEYS
862 /* Currently this makes various tests warn in annoying ways.
863 * So Silenced for now. - Yves | bogus end of comment =>* /
864 if (HvAUX(hv)->xhv_riter != -1) {
865 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
866 "[TESTING] Inserting into a hash during each() traversal results in undefined behavior"
871 if (PL_HASH_RAND_BITS_ENABLED) {
872 if (PL_HASH_RAND_BITS_ENABLED == 1)
873 PL_hash_rand_bits += (PTRV)entry + 1; /* we don't bother to use ptr_hash here */
874 PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
876 HvAUX(hv)->xhv_rand= (U32)PL_hash_rand_bits;
880 if (val == &PL_sv_placeholder)
881 HvPLACEHOLDERS(hv)++;
882 if (masked_flags & HVhek_ENABLEHVKFLAGS)
885 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
886 if ( in_collision && DO_HSPLIT(xhv) ) {
887 const STRLEN oldsize = xhv->xhv_max + 1;
888 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
890 if (items /* hash has placeholders */
891 && !SvREADONLY(hv) /* but is not a restricted hash */) {
892 /* If this hash previously was a "restricted hash" and had
893 placeholders, but the "restricted" flag has been turned off,
894 then the placeholders no longer serve any useful purpose.
895 However, they have the downsides of taking up RAM, and adding
896 extra steps when finding used values. It's safe to clear them
897 at this point, even though Storable rebuilds restricted hashes by
898 putting in all the placeholders (first) before turning on the
899 readonly flag, because Storable always pre-splits the hash.
900 If we're lucky, then we may clear sufficient placeholders to
901 avoid needing to split the hash at all. */
902 clear_placeholders(hv, items);
904 hsplit(hv, oldsize, oldsize * 2);
906 hsplit(hv, oldsize, oldsize * 2);
910 return entry ? (void *) &HeVAL(entry) : NULL;
912 return (void *) entry;
916 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
918 const MAGIC *mg = SvMAGIC(hv);
920 PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
925 if (isUPPER(mg->mg_type)) {
927 if (mg->mg_type == PERL_MAGIC_tied) {
928 *needs_store = FALSE;
929 return; /* We've set all there is to set. */
932 mg = mg->mg_moremagic;
937 =for apidoc hv_scalar
939 Evaluates the hash in scalar context and returns the result.
941 When the hash is tied dispatches through to the SCALAR method,
942 otherwise returns a mortal SV containing the number of keys
945 Note, prior to 5.25 this function returned what is now
946 returned by the hv_bucket_ratio() function.
952 Perl_hv_scalar(pTHX_ HV *hv)
956 PERL_ARGS_ASSERT_HV_SCALAR;
958 if (SvRMAGICAL(hv)) {
959 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
961 return magic_scalarpack(hv, mg);
965 sv_setuv(sv, HvUSEDKEYS(hv));
971 =for apidoc hv_bucket_ratio
973 If the hash is tied dispatches through to the SCALAR tied method,
974 otherwise if the hash contains no keys returns 0, otherwise returns
975 a mortal sv containing a string specifying the number of used buckets,
976 followed by a slash, followed by the number of available buckets.
978 This function is expensive, it must scan all of the buckets
979 to determine which are used, and the count is NOT cached.
980 In a large hash this could be a lot of buckets.
986 Perl_hv_bucket_ratio(pTHX_ HV *hv)
990 PERL_ARGS_ASSERT_HV_BUCKET_RATIO;
992 if (SvRMAGICAL(hv)) {
993 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
995 return magic_scalarpack(hv, mg);
999 if (HvUSEDKEYS((HV *)hv))
1000 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
1001 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
1009 =for apidoc hv_delete
1011 Deletes a key/value pair in the hash. The value's SV is removed from
1012 the hash, made mortal, and returned to the caller. The absolute
1013 value of C<klen> is the length of the key. If C<klen> is negative the
1014 key is assumed to be in UTF-8-encoded Unicode. The C<flags> value
1015 will normally be zero; if set to C<G_DISCARD> then C<NULL> will be returned.
1016 C<NULL> will also be returned if the key is not found.
1018 =for apidoc hv_delete_ent
1020 Deletes a key/value pair in the hash. The value SV is removed from the hash,
1021 made mortal, and returned to the caller. The C<flags> value will normally be
1022 zero; if set to C<G_DISCARD> then C<NULL> will be returned. C<NULL> will also
1023 be returned if the key is not found. C<hash> can be a valid precomputed hash
1024 value, or 0 to ask for it to be computed.
1030 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
1031 int k_flags, I32 d_flags, U32 hash)
1038 bool is_utf8 = cBOOL(k_flags & HVhek_UTF8);
1040 HEK *keysv_hek = NULL;
1041 U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
1046 if (SvRMAGICAL(hv)) {
1049 hv_magic_check (hv, &needs_copy, &needs_store);
1053 entry = (HE *) hv_common(hv, keysv, key, klen,
1054 k_flags & ~HVhek_FREEKEY,
1055 HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
1057 sv = entry ? HeVAL(entry) : NULL;
1059 if (SvMAGICAL(sv)) {
1063 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1064 /* No longer an element */
1065 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1068 return NULL; /* element cannot be deleted */
1070 #ifdef ENV_IS_CASELESS
1071 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
1072 /* XXX This code isn't UTF8 clean. */
1073 keysv = newSVpvn_flags(key, klen, SVs_TEMP);
1074 if (k_flags & HVhek_FREEKEY) {
1077 key = strupr(SvPVX(keysv));
1086 xhv = (XPVHV*)SvANY(hv);
1090 if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
1091 const char * const keysave = key;
1092 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1095 k_flags |= HVhek_UTF8;
1097 k_flags &= ~HVhek_UTF8;
1098 if (key != keysave) {
1099 if (k_flags & HVhek_FREEKEY) {
1100 /* This shouldn't happen if our caller does what we expect,
1101 but strictly the API allows it. */
1104 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1106 HvHASKFLAGS_on(MUTABLE_SV(hv));
1109 if (keysv && (SvIsCOW_shared_hash(keysv))) {
1110 if (HvSHAREKEYS(hv))
1111 keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
1112 hash = SvSHARED_HASH(keysv);
1115 PERL_HASH(hash, key, klen);
1117 masked_flags = (k_flags & HVhek_MASK);
1119 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1126 /* keysv is actually a HEK in disguise, so we can match just by
1127 * comparing the HEK pointers in the HE chain. There is a slight
1128 * caveat: on something like "\x80", which has both plain and utf8
1129 * representations, perl's hashes do encoding-insensitive lookups,
1130 * but preserve the encoding of the stored key. Thus a particular
1131 * key could map to two different HEKs in PL_strtab. We only
1132 * conclude 'not found' if all the flags are the same; otherwise
1133 * we fall back to a full search (this should only happen in rare
1136 int keysv_flags = HEK_FLAGS(keysv_hek);
1138 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1139 HEK *hek = HeKEY_hek(entry);
1140 if (hek == keysv_hek)
1142 if (HEK_FLAGS(hek) != keysv_flags)
1143 break; /* need to do full match */
1147 /* failed on shortcut - do full search loop */
1148 oentry = first_entry;
1152 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1153 if (HeHASH(entry) != hash) /* strings can't be equal */
1155 if (HeKLEN(entry) != (I32)klen)
1157 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
1159 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1163 if (hv == PL_strtab) {
1164 if (k_flags & HVhek_FREEKEY)
1166 Perl_croak(aTHX_ S_strtab_error, "delete");
1169 /* if placeholder is here, it's already been deleted.... */
1170 if (HeVAL(entry) == &PL_sv_placeholder) {
1171 if (k_flags & HVhek_FREEKEY)
1175 if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1176 hv_notallowed(k_flags, key, klen,
1177 "Attempt to delete readonly key '%" SVf "' from"
1178 " a restricted hash");
1180 if (k_flags & HVhek_FREEKEY)
1183 /* If this is a stash and the key ends with ::, then someone is
1184 * deleting a package.
1186 if (HeVAL(entry) && HvENAME_get(hv)) {
1187 gv = (GV *)HeVAL(entry);
1188 if (keysv) key = SvPV(keysv, klen);
1190 (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1192 (klen == 1 && key[0] == ':')
1194 && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1195 && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
1196 && HvENAME_get(stash)) {
1197 /* A previous version of this code checked that the
1198 * GV was still in the symbol table by fetching the
1199 * GV with its name. That is not necessary (and
1200 * sometimes incorrect), as HvENAME cannot be set
1201 * on hv if it is not in the symtab. */
1203 /* Hang on to it for a bit. */
1204 SvREFCNT_inc_simple_void_NN(
1205 sv_2mortal((SV *)gv)
1208 else if (klen == 3 && strEQs(key, "ISA") && GvAV(gv)) {
1210 MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa);
1214 if (mg->mg_obj == (SV*)gv) {
1215 /* This is the only stash this ISA was used for.
1216 * The isaelem magic asserts if there's no
1217 * isa magic on the array, so explicitly
1218 * remove the magic on both the array and its
1219 * elements. @ISA shouldn't be /too/ large.
1224 end = svp + AvFILLp(isa)+1;
1227 mg_free_type(*svp, PERL_MAGIC_isaelem);
1230 mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
1233 /* mg_obj is an array of stashes
1234 Note that the array doesn't keep a reference
1235 count on the stashes.
1237 AV *av = (AV*)mg->mg_obj;
1242 assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
1244 /* remove the stash from the magic array */
1245 arrayp = svp = AvARRAY(av);
1246 items = AvFILLp(av) + 1;
1248 assert(*arrayp == (SV *)gv);
1250 /* avoid a double free on the last stash */
1252 /* The magic isn't MGf_REFCOUNTED, so release
1253 * the array manually.
1255 SvREFCNT_dec_NN(av);
1260 if (*svp == (SV*)gv)
1264 index = svp - arrayp;
1265 assert(index >= 0 && index <= AvFILLp(av));
1266 if (index < AvFILLp(av)) {
1267 arrayp[index] = arrayp[AvFILLp(av)];
1269 arrayp[AvFILLp(av)] = NULL;
1277 sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
1278 HeVAL(entry) = &PL_sv_placeholder;
1280 /* deletion of method from stash */
1281 if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1283 mro_method_changed_in(hv);
1287 * If a restricted hash, rather than really deleting the entry, put
1288 * a placeholder there. This marks the key as being "approved", so
1289 * we can still access via not-really-existing key without raising
1293 /* We'll be saving this slot, so the number of allocated keys
1294 * doesn't go down, but the number placeholders goes up */
1295 HvPLACEHOLDERS(hv)++;
1297 *oentry = HeNEXT(entry);
1298 if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1301 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1302 entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1303 HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1304 hv_free_ent(hv, entry);
1306 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1307 if (xhv->xhv_keys == 0)
1308 HvHASKFLAGS_off(hv);
1311 if (d_flags & G_DISCARD) {
1316 if (mro_changes == 1) mro_isa_changed_in(hv);
1317 else if (mro_changes == 2)
1318 mro_package_moved(NULL, stash, gv, 1);
1324 if (SvREADONLY(hv)) {
1325 hv_notallowed(k_flags, key, klen,
1326 "Attempt to delete disallowed key '%" SVf "' from"
1327 " a restricted hash");
1330 if (k_flags & HVhek_FREEKEY)
1337 S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1340 char *a = (char*) HvARRAY(hv);
1344 /* already have an HvAUX(hv) so we have to move it */
1346 /* no HvAUX() but array we are going to allocate is large enough
1347 * there is no point in saving the space for the iterator, and
1348 * speeds up later traversals. */
1349 ( ( hv != PL_strtab ) && ( newsize >= PERL_HV_ALLOC_AUX_SIZE ) )
1352 PERL_ARGS_ASSERT_HSPLIT;
1355 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1356 + (do_aux ? sizeof(struct xpvhv_aux) : 0), char);
1362 #ifdef PERL_HASH_RANDOMIZE_KEYS
1363 /* the idea of this is that we create a "random" value by hashing the address of
1364 * the array, we then use the low bit to decide if we insert at the top, or insert
1365 * second from top. After each such insert we rotate the hashed value. So we can
1366 * use the same hashed value over and over, and in normal build environments use
1367 * very few ops to do so. ROTL32() should produce a single machine operation. */
1368 if (PL_HASH_RAND_BITS_ENABLED) {
1369 if (PL_HASH_RAND_BITS_ENABLED == 1)
1370 PL_hash_rand_bits += ptr_hash((PTRV)a);
1371 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1374 HvARRAY(hv) = (HE**) a;
1375 HvMAX(hv) = newsize - 1;
1376 /* before we zero the newly added memory, we
1377 * need to deal with the aux struct that may be there
1378 * or have been allocated by us*/
1380 struct xpvhv_aux *const dest
1381 = (struct xpvhv_aux*) &a[newsize * sizeof(HE*)];
1383 /* alread have an aux, copy the old one in place. */
1384 Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
1385 /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
1386 #ifdef PERL_HASH_RANDOMIZE_KEYS
1387 dest->xhv_rand = (U32)PL_hash_rand_bits;
1390 /* no existing aux structure, but we allocated space for one
1391 * so initialize it properly. This unrolls hv_auxinit() a bit,
1392 * since we have to do the realloc anyway. */
1393 /* first we set the iterator's xhv_rand so it can be copied into lastrand below */
1394 #ifdef PERL_HASH_RANDOMIZE_KEYS
1395 dest->xhv_rand = (U32)PL_hash_rand_bits;
1397 /* this is the "non realloc" part of the hv_auxinit() */
1398 (void)hv_auxinit_internal(dest);
1399 /* Turn on the OOK flag */
1403 /* now we can safely clear the second half */
1404 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1406 if (!HvTOTALKEYS(hv)) /* skip rest if no entries */
1412 HE **oentry = aep + i;
1415 if (!entry) /* non-existent */
1418 U32 j = (HeHASH(entry) & newsize);
1420 *oentry = HeNEXT(entry);
1421 #ifdef PERL_HASH_RANDOMIZE_KEYS
1422 /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
1423 * insert to top, otherwise rotate the bucket rand 1 bit,
1424 * and use the new low bit to decide if we insert at top,
1425 * or next from top. IOW, we only rotate on a collision.*/
1426 if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
1427 PL_hash_rand_bits+= ROTL32(HeHASH(entry), 17);
1428 PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
1429 if (PL_hash_rand_bits & 1) {
1430 HeNEXT(entry)= HeNEXT(aep[j]);
1431 HeNEXT(aep[j])= entry;
1433 /* Note, this is structured in such a way as the optimizer
1434 * should eliminate the duplicated code here and below without
1435 * us needing to explicitly use a goto. */
1436 HeNEXT(entry) = aep[j];
1442 /* see comment above about duplicated code */
1443 HeNEXT(entry) = aep[j];
1448 oentry = &HeNEXT(entry);
1452 } while (i++ < oldsize);
1456 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1458 XPVHV* xhv = (XPVHV*)SvANY(hv);
1459 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 */
1465 PERL_ARGS_ASSERT_HV_KSPLIT;
1467 wantsize = (I32) newmax; /* possible truncation here */
1468 if (wantsize != newmax)
1471 wantsize= wantsize + (wantsize >> 1); /* wantsize *= 1.5 */
1472 if (wantsize < newmax) /* overflow detection */
1476 while (wantsize > newsize) {
1477 trysize = newsize << 1;
1478 if (trysize > newsize) {
1486 if (newsize <= oldsize)
1487 return; /* overflow detection */
1489 a = (char *) HvARRAY(hv);
1491 hsplit(hv, oldsize, newsize);
1493 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1494 xhv->xhv_max = newsize - 1;
1495 HvARRAY(hv) = (HE **) a;
1499 /* IMO this should also handle cases where hv_max is smaller than hv_keys
1500 * as tied hashes could play silly buggers and mess us around. We will
1501 * do the right thing during hv_store() afterwards, but still - Yves */
1502 #define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
1503 /* Can we use fewer buckets? (hv_max is always 2^n-1) */ \
1504 if (hv_max < PERL_HASH_DEFAULT_HvMAX) { \
1505 hv_max = PERL_HASH_DEFAULT_HvMAX; \
1507 while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
1508 hv_max = hv_max / 2; \
1510 HvMAX(hv) = hv_max; \
1515 Perl_newHVhv(pTHX_ HV *ohv)
1518 HV * const hv = newHV();
1521 if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
1523 hv_max = HvMAX(ohv);
1525 if (!SvMAGICAL((const SV *)ohv)) {
1526 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1528 const bool shared = !!HvSHAREKEYS(ohv);
1529 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1531 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1534 /* In each bucket... */
1535 for (i = 0; i <= hv_max; i++) {
1537 HE *oent = oents[i];
1544 /* Copy the linked list of entries. */
1545 for (; oent; oent = HeNEXT(oent)) {
1546 const U32 hash = HeHASH(oent);
1547 const char * const key = HeKEY(oent);
1548 const STRLEN len = HeKLEN(oent);
1549 const int flags = HeKFLAGS(oent);
1550 HE * const ent = new_HE();
1551 SV *const val = HeVAL(oent);
1553 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1555 = shared ? share_hek_flags(key, len, hash, flags)
1556 : save_hek_flags(key, len, hash, flags);
1567 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1571 /* Iterate over ohv, copying keys and values one at a time. */
1573 const I32 riter = HvRITER_get(ohv);
1574 HE * const eiter = HvEITER_get(ohv);
1575 STRLEN hv_keys = HvTOTALKEYS(ohv);
1577 HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1580 while ((entry = hv_iternext_flags(ohv, 0))) {
1581 SV *val = hv_iterval(ohv,entry);
1582 SV * const keysv = HeSVKEY(entry);
1583 val = SvIMMORTAL(val) ? val : newSVsv(val);
1585 (void)hv_store_ent(hv, keysv, val, 0);
1587 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1588 HeHASH(entry), HeKFLAGS(entry));
1590 HvRITER_set(ohv, riter);
1591 HvEITER_set(ohv, eiter);
1598 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1600 A specialised version of L</newHVhv> for copying C<%^H>. C<ohv> must be
1601 a pointer to a hash (which may have C<%^H> magic, but should be generally
1602 non-magical), or C<NULL> (interpreted as an empty hash). The content
1603 of C<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1604 added to it. A pointer to the new hash is returned.
1610 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1612 HV * const hv = newHV();
1615 STRLEN hv_max = HvMAX(ohv);
1616 STRLEN hv_keys = HvTOTALKEYS(ohv);
1618 const I32 riter = HvRITER_get(ohv);
1619 HE * const eiter = HvEITER_get(ohv);
1624 HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1627 while ((entry = hv_iternext_flags(ohv, 0))) {
1628 SV *const sv = newSVsv(hv_iterval(ohv,entry));
1629 SV *heksv = HeSVKEY(entry);
1630 if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1631 if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1632 (char *)heksv, HEf_SVKEY);
1633 if (heksv == HeSVKEY(entry))
1634 (void)hv_store_ent(hv, heksv, sv, 0);
1636 (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1637 HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1638 SvREFCNT_dec_NN(heksv);
1641 HvRITER_set(ohv, riter);
1642 HvEITER_set(ohv, eiter);
1644 SvREFCNT_inc_simple_void_NN(hv);
1647 hv_magic(hv, NULL, PERL_MAGIC_hints);
1650 #undef HV_SET_MAX_ADJUSTED_FOR_KEYS
1652 /* like hv_free_ent, but returns the SV rather than freeing it */
1654 S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
1658 PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1661 if (HeKLEN(entry) == HEf_SVKEY) {
1662 SvREFCNT_dec(HeKEY_sv(entry));
1663 Safefree(HeKEY_hek(entry));
1665 else if (HvSHAREKEYS(hv))
1666 unshare_hek(HeKEY_hek(entry));
1668 Safefree(HeKEY_hek(entry));
1675 Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
1679 PERL_ARGS_ASSERT_HV_FREE_ENT;
1683 val = hv_free_ent_ret(hv, entry);
1689 Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
1691 PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1695 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1696 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
1697 if (HeKLEN(entry) == HEf_SVKEY) {
1698 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1700 hv_free_ent(hv, entry);
1704 =for apidoc hv_clear
1706 Frees the all the elements of a hash, leaving it empty.
1707 The XS equivalent of C<%hash = ()>. See also L</hv_undef>.
1709 See L</av_clear> for a note about the hash possibly being invalid on
1716 Perl_hv_clear(pTHX_ HV *hv)
1725 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1727 xhv = (XPVHV*)SvANY(hv);
1729 /* avoid hv being freed when calling destructors below */
1731 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
1732 orig_ix = PL_tmps_ix;
1733 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1734 /* restricted hash: convert all keys to placeholders */
1736 for (i = 0; i <= xhv->xhv_max; i++) {
1737 HE *entry = (HvARRAY(hv))[i];
1738 for (; entry; entry = HeNEXT(entry)) {
1739 /* not already placeholder */
1740 if (HeVAL(entry) != &PL_sv_placeholder) {
1742 if (SvREADONLY(HeVAL(entry))) {
1743 SV* const keysv = hv_iterkeysv(entry);
1744 Perl_croak_nocontext(
1745 "Attempt to delete readonly key '%" SVf "' from a restricted hash",
1748 SvREFCNT_dec_NN(HeVAL(entry));
1750 HeVAL(entry) = &PL_sv_placeholder;
1751 HvPLACEHOLDERS(hv)++;
1758 HvPLACEHOLDERS_set(hv, 0);
1761 mg_clear(MUTABLE_SV(hv));
1763 HvHASKFLAGS_off(hv);
1767 mro_isa_changed_in(hv);
1768 HvEITER_set(hv, NULL);
1770 /* disarm hv's premature free guard */
1771 if (LIKELY(PL_tmps_ix == orig_ix))
1774 PL_tmps_stack[orig_ix] = &PL_sv_undef;
1775 SvREFCNT_dec_NN(hv);
1779 =for apidoc hv_clear_placeholders
1781 Clears any placeholders from a hash. If a restricted hash has any of its keys
1782 marked as readonly and the key is subsequently deleted, the key is not actually
1783 deleted but is marked by assigning it a value of C<&PL_sv_placeholder>. This tags
1784 it so it will be ignored by future operations such as iterating over the hash,
1785 but will still allow the hash to have a value reassigned to the key at some
1786 future point. This function clears any such placeholder keys from the hash.
1787 See C<L<Hash::Util::lock_keys()|Hash::Util/lock_keys>> for an example of its
1794 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1796 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1798 PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1801 clear_placeholders(hv, items);
1805 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1810 PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1817 /* Loop down the linked list heads */
1818 HE **oentry = &(HvARRAY(hv))[i];
1821 while ((entry = *oentry)) {
1822 if (HeVAL(entry) == &PL_sv_placeholder) {
1823 *oentry = HeNEXT(entry);
1824 if (entry == HvEITER_get(hv))
1827 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1828 entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1829 HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1830 hv_free_ent(hv, entry);
1835 I32 placeholders = HvPLACEHOLDERS_get(hv);
1836 HvTOTALKEYS(hv) -= (IV)placeholders;
1837 /* HvUSEDKEYS expanded */
1838 if ((HvTOTALKEYS(hv) - placeholders) == 0)
1839 HvHASKFLAGS_off(hv);
1840 HvPLACEHOLDERS_set(hv, 0);
1844 oentry = &HeNEXT(entry);
1848 /* You can't get here, hence assertion should always fail. */
1849 assert (items == 0);
1850 NOT_REACHED; /* NOTREACHED */
1854 S_hfreeentries(pTHX_ HV *hv)
1857 XPVHV * const xhv = (XPVHV*)SvANY(hv);
1860 PERL_ARGS_ASSERT_HFREEENTRIES;
1862 while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
1868 /* hfree_next_entry()
1869 * For use only by S_hfreeentries() and sv_clear().
1870 * Delete the next available HE from hv and return the associated SV.
1871 * Returns null on empty hash. Nevertheless null is not a reliable
1872 * indicator that the hash is empty, as the deleted entry may have a
1874 * indexp is a pointer to the current index into HvARRAY. The index should
1875 * initially be set to 0. hfree_next_entry() may update it. */
1878 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1880 struct xpvhv_aux *iter;
1884 STRLEN orig_index = *indexp;
1887 PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1889 if (SvOOK(hv) && ((iter = HvAUX(hv)))) {
1890 if ((entry = iter->xhv_eiter)) {
1891 /* the iterator may get resurrected after each
1892 * destructor call, so check each time */
1893 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1895 hv_free_ent(hv, entry);
1896 /* warning: at this point HvARRAY may have been
1897 * re-allocated, HvMAX changed etc */
1899 iter = HvAUX(hv); /* may have been realloced */
1900 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1901 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1902 #ifdef PERL_HASH_RANDOMIZE_KEYS
1903 iter->xhv_last_rand = iter->xhv_rand;
1908 if (!((XPVHV*)SvANY(hv))->xhv_keys)
1911 array = HvARRAY(hv);
1913 while ( ! ((entry = array[*indexp])) ) {
1914 if ((*indexp)++ >= HvMAX(hv))
1916 assert(*indexp != orig_index);
1918 array[*indexp] = HeNEXT(entry);
1919 ((XPVHV*) SvANY(hv))->xhv_keys--;
1921 if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
1922 && HeVAL(entry) && isGV(HeVAL(entry))
1923 && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
1926 const char * const key = HePV(entry,klen);
1927 if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
1928 || (klen == 1 && key[0] == ':')) {
1930 NULL, GvHV(HeVAL(entry)),
1931 (GV *)HeVAL(entry), 0
1935 return hv_free_ent_ret(hv, entry);
1940 =for apidoc hv_undef
1942 Undefines the hash. The XS equivalent of C<undef(%hash)>.
1944 As well as freeing all the elements of the hash (like C<hv_clear()>), this
1945 also frees any auxiliary data and storage associated with the hash.
1947 See L</av_clear> for a note about the hash possibly being invalid on
1954 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1958 SSize_t orig_ix = PL_tmps_ix; /* silence compiler warning about unitialized vars */
1962 save = cBOOL(SvREFCNT(hv));
1963 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1964 xhv = (XPVHV*)SvANY(hv);
1966 /* The name must be deleted before the call to hfreeeeentries so that
1967 CVs are anonymised properly. But the effective name must be pre-
1968 served until after that call (and only deleted afterwards if the
1969 call originated from sv_clear). For stashes with one name that is
1970 both the canonical name and the effective name, hv_name_set has to
1971 allocate an array for storing the effective name. We can skip that
1972 during global destruction, as it does not matter where the CVs point
1973 if they will be freed anyway. */
1974 /* note that the code following prior to hfreeentries is duplicated
1975 * in sv_clear(), and changes here should be done there too */
1976 if (PL_phase != PERL_PHASE_DESTRUCT && HvNAME(hv)) {
1977 if (PL_stashcache) {
1978 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
1979 HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
1980 (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
1982 hv_name_set(hv, NULL, 0, 0);
1985 /* avoid hv being freed when calling destructors below */
1987 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
1988 orig_ix = PL_tmps_ix;
1992 struct mro_meta *meta;
1995 if (HvENAME_get(hv)) {
1996 if (PL_phase != PERL_PHASE_DESTRUCT)
1997 mro_isa_changed_in(hv);
1998 if (PL_stashcache) {
1999 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
2000 HEKf "'\n", HEKfARG(HvENAME_HEK(hv))));
2001 (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD);
2005 /* If this call originated from sv_clear, then we must check for
2006 * effective names that need freeing, as well as the usual name. */
2008 if (flags & HV_NAME_SETALL ? !!HvAUX(hv)->xhv_name_u.xhvnameu_name : !!name) {
2009 if (name && PL_stashcache) {
2010 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
2011 HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
2012 (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
2014 hv_name_set(hv, NULL, 0, flags);
2016 if((meta = HvAUX(hv)->xhv_mro_meta)) {
2017 if (meta->mro_linear_all) {
2018 SvREFCNT_dec_NN(meta->mro_linear_all);
2019 /* mro_linear_current is just acting as a shortcut pointer,
2023 /* Only the current MRO is stored, so this owns the data.
2025 SvREFCNT_dec(meta->mro_linear_current);
2026 SvREFCNT_dec(meta->mro_nextmethod);
2027 SvREFCNT_dec(meta->isa);
2028 SvREFCNT_dec(meta->super);
2030 HvAUX(hv)->xhv_mro_meta = NULL;
2032 if (!HvAUX(hv)->xhv_name_u.xhvnameu_name && ! HvAUX(hv)->xhv_backreferences)
2033 SvFLAGS(hv) &= ~SVf_OOK;
2036 Safefree(HvARRAY(hv));
2037 xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX; /* HvMAX(hv) = 7 (it's a normal hash) */
2040 /* if we're freeing the HV, the SvMAGIC field has been reused for
2041 * other purposes, and so there can't be any placeholder magic */
2043 HvPLACEHOLDERS_set(hv, 0);
2046 mg_clear(MUTABLE_SV(hv));
2049 /* disarm hv's premature free guard */
2050 if (LIKELY(PL_tmps_ix == orig_ix))
2053 PL_tmps_stack[orig_ix] = &PL_sv_undef;
2054 SvREFCNT_dec_NN(hv);
2061 Returns the number of hash buckets that happen to be in use.
2063 This function is wrapped by the macro C<HvFILL>.
2065 As of perl 5.25 this function is used only for debugging
2066 purposes, and the number of used hash buckets is not
2067 in any way cached, thus this function can be costly
2068 to execute as it must iterate over all the buckets in the
2075 Perl_hv_fill(pTHX_ HV *const hv)
2078 HE **ents = HvARRAY(hv);
2080 PERL_UNUSED_CONTEXT;
2081 PERL_ARGS_ASSERT_HV_FILL;
2083 /* No keys implies no buckets used.
2084 One key can only possibly mean one bucket used. */
2085 if (HvTOTALKEYS(hv) < 2)
2086 return HvTOTALKEYS(hv);
2089 /* I wonder why we count down here...
2090 * Is it some micro-optimisation?
2091 * I would have thought counting up was better.
2094 HE *const *const last = ents + HvMAX(hv);
2095 count = last + 1 - ents;
2100 } while (++ents <= last);
2105 /* hash a pointer to a U32 - Used in the hash traversal randomization
2106 * and bucket order randomization code
2108 * this code was derived from Sereal, which was derived from autobox.
2111 PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
2114 * This is one of Thomas Wang's hash functions for 64-bit integers from:
2115 * http://www.concentric.net/~Ttwang/tech/inthash.htm
2117 u = (~u) + (u << 18);
2125 * This is one of Bob Jenkins' hash functions for 32-bit integers
2126 * from: http://burtleburtle.net/bob/hash/integer.html
2128 u = (u + 0x7ed55d16) + (u << 12);
2129 u = (u ^ 0xc761c23c) ^ (u >> 19);
2130 u = (u + 0x165667b1) + (u << 5);
2131 u = (u + 0xd3a2646c) ^ (u << 9);
2132 u = (u + 0xfd7046c5) + (u << 3);
2133 u = (u ^ 0xb55a4f09) ^ (u >> 16);
2138 static struct xpvhv_aux*
2139 S_hv_auxinit_internal(struct xpvhv_aux *iter) {
2140 PERL_ARGS_ASSERT_HV_AUXINIT_INTERNAL;
2141 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2142 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2143 #ifdef PERL_HASH_RANDOMIZE_KEYS
2144 iter->xhv_last_rand = iter->xhv_rand;
2146 iter->xhv_name_u.xhvnameu_name = 0;
2147 iter->xhv_name_count = 0;
2148 iter->xhv_backreferences = 0;
2149 iter->xhv_mro_meta = NULL;
2150 iter->xhv_aux_flags = 0;
2155 static struct xpvhv_aux*
2156 S_hv_auxinit(pTHX_ HV *hv) {
2157 struct xpvhv_aux *iter;
2160 PERL_ARGS_ASSERT_HV_AUXINIT;
2164 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
2165 + sizeof(struct xpvhv_aux), char);
2167 array = (char *) HvARRAY(hv);
2168 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
2169 + sizeof(struct xpvhv_aux), char);
2171 HvARRAY(hv) = (HE**)array;
2174 #ifdef PERL_HASH_RANDOMIZE_KEYS
2175 if (PL_HASH_RAND_BITS_ENABLED) {
2176 /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
2177 if (PL_HASH_RAND_BITS_ENABLED == 1)
2178 PL_hash_rand_bits += ptr_hash((PTRV)array);
2179 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
2181 iter->xhv_rand = (U32)PL_hash_rand_bits;
2187 return hv_auxinit_internal(iter);
2191 =for apidoc hv_iterinit
2193 Prepares a starting point to traverse a hash table. Returns the number of
2194 keys in the hash, including placeholders (i.e. the same as C<HvTOTALKEYS(hv)>).
2195 The return value is currently only meaningful for hashes without tie magic.
2197 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
2198 hash buckets that happen to be in use. If you still need that esoteric
2199 value, you can get it through the macro C<HvFILL(hv)>.
2206 Perl_hv_iterinit(pTHX_ HV *hv)
2208 PERL_ARGS_ASSERT_HV_ITERINIT;
2211 struct xpvhv_aux * iter = HvAUX(hv);
2212 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2213 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2215 hv_free_ent(hv, entry);
2217 iter = HvAUX(hv); /* may have been reallocated */
2218 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2219 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2220 #ifdef PERL_HASH_RANDOMIZE_KEYS
2221 iter->xhv_last_rand = iter->xhv_rand;
2227 /* note this includes placeholders! */
2228 return HvTOTALKEYS(hv);
2232 Perl_hv_riter_p(pTHX_ HV *hv) {
2233 struct xpvhv_aux *iter;
2235 PERL_ARGS_ASSERT_HV_RITER_P;
2237 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2238 return &(iter->xhv_riter);
2242 Perl_hv_eiter_p(pTHX_ HV *hv) {
2243 struct xpvhv_aux *iter;
2245 PERL_ARGS_ASSERT_HV_EITER_P;
2247 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2248 return &(iter->xhv_eiter);
2252 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2253 struct xpvhv_aux *iter;
2255 PERL_ARGS_ASSERT_HV_RITER_SET;
2263 iter = hv_auxinit(hv);
2265 iter->xhv_riter = riter;
2269 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2270 struct xpvhv_aux *iter;
2272 PERL_ARGS_ASSERT_HV_RAND_SET;
2274 #ifdef PERL_HASH_RANDOMIZE_KEYS
2278 iter = hv_auxinit(hv);
2280 iter->xhv_rand = new_xhv_rand;
2282 Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2287 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2288 struct xpvhv_aux *iter;
2290 PERL_ARGS_ASSERT_HV_EITER_SET;
2295 /* 0 is the default so don't go malloc()ing a new structure just to
2300 iter = hv_auxinit(hv);
2302 iter->xhv_eiter = eiter;
2306 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2309 struct xpvhv_aux *iter;
2313 PERL_ARGS_ASSERT_HV_NAME_SET;
2316 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2320 if (iter->xhv_name_u.xhvnameu_name) {
2321 if(iter->xhv_name_count) {
2322 if(flags & HV_NAME_SETALL) {
2323 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2324 HEK **hekp = name + (
2325 iter->xhv_name_count < 0
2326 ? -iter->xhv_name_count
2327 : iter->xhv_name_count
2329 while(hekp-- > name+1)
2330 unshare_hek_or_pvn(*hekp, 0, 0, 0);
2331 /* The first elem may be null. */
2332 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2334 iter = HvAUX(hv); /* may been realloced */
2335 spot = &iter->xhv_name_u.xhvnameu_name;
2336 iter->xhv_name_count = 0;
2339 if(iter->xhv_name_count > 0) {
2340 /* shift some things over */
2342 iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2344 spot = iter->xhv_name_u.xhvnameu_names;
2345 spot[iter->xhv_name_count] = spot[1];
2347 iter->xhv_name_count = -(iter->xhv_name_count + 1);
2349 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2350 unshare_hek_or_pvn(*spot, 0, 0, 0);
2354 else if (flags & HV_NAME_SETALL) {
2355 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2356 iter = HvAUX(hv); /* may been realloced */
2357 spot = &iter->xhv_name_u.xhvnameu_name;
2360 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2361 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2362 iter->xhv_name_count = -2;
2363 spot = iter->xhv_name_u.xhvnameu_names;
2364 spot[1] = existing_name;
2367 else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2372 iter = hv_auxinit(hv);
2373 spot = &iter->xhv_name_u.xhvnameu_name;
2375 PERL_HASH(hash, name, len);
2376 *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2380 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2385 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2386 if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2387 if (flags & SVf_UTF8)
2388 return (bytes_cmp_utf8(
2389 (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2390 (const U8*)pv, pvlen) == 0);
2392 return (bytes_cmp_utf8(
2393 (const U8*)pv, pvlen,
2394 (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2397 return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2398 || memEQ(HEK_KEY(hek), pv, pvlen));
2402 =for apidoc hv_ename_add
2404 Adds a name to a stash's internal list of effective names. See
2405 C<L</hv_ename_delete>>.
2407 This is called when a stash is assigned to a new location in the symbol
2414 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2417 struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2420 PERL_ARGS_ASSERT_HV_ENAME_ADD;
2423 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2425 PERL_HASH(hash, name, len);
2427 if (aux->xhv_name_count) {
2428 I32 count = aux->xhv_name_count;
2429 HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0);
2430 HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count);
2431 while (hekp-- > xhv_name)
2435 (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
2436 ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2437 : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2439 if (hekp == xhv_name && count < 0)
2440 aux->xhv_name_count = -count;
2444 if (count < 0) aux->xhv_name_count--, count = -count;
2445 else aux->xhv_name_count++;
2446 Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2447 (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2450 HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2453 (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2454 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2455 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2458 Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2459 aux->xhv_name_count = existing_name ? 2 : -2;
2460 *aux->xhv_name_u.xhvnameu_names = existing_name;
2461 (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2466 =for apidoc hv_ename_delete
2468 Removes a name from a stash's internal list of effective names. If this is
2469 the name returned by C<HvENAME>, then another name in the list will take
2470 its place (C<HvENAME> will use it).
2472 This is called when a stash is deleted from the symbol table.
2478 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2480 struct xpvhv_aux *aux;
2482 PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2485 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2487 if (!SvOOK(hv)) return;
2490 if (!aux->xhv_name_u.xhvnameu_name) return;
2492 if (aux->xhv_name_count) {
2493 HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2494 I32 const count = aux->xhv_name_count;
2495 HEK **victim = namep + (count < 0 ? -count : count);
2496 while (victim-- > namep + 1)
2498 (HEK_UTF8(*victim) || (flags & SVf_UTF8))
2499 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2500 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2502 unshare_hek_or_pvn(*victim, 0, 0, 0);
2503 aux = HvAUX(hv); /* may been realloced */
2504 if (count < 0) ++aux->xhv_name_count;
2505 else --aux->xhv_name_count;
2507 (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2509 ) { /* if there are none left */
2511 aux->xhv_name_u.xhvnameu_names = NULL;
2512 aux->xhv_name_count = 0;
2515 /* Move the last one back to fill the empty slot. It
2516 does not matter what order they are in. */
2517 *victim = *(namep + (count < 0 ? -count : count) - 1);
2522 count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8))
2523 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2524 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2527 aux->xhv_name_count = -count;
2531 (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
2532 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2533 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2534 memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2536 HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2537 Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2538 *aux->xhv_name_u.xhvnameu_names = namehek;
2539 aux->xhv_name_count = -1;
2544 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2545 PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2546 /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
2548 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2549 return &(iter->xhv_backreferences);
2554 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2557 PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2562 av = HvAUX(hv)->xhv_backreferences;
2565 HvAUX(hv)->xhv_backreferences = 0;
2566 Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2567 if (SvTYPE(av) == SVt_PVAV)
2568 SvREFCNT_dec_NN(av);
2573 hv_iternext is implemented as a macro in hv.h
2575 =for apidoc hv_iternext
2577 Returns entries from a hash iterator. See C<L</hv_iterinit>>.
2579 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2580 iterator currently points to, without losing your place or invalidating your
2581 iterator. Note that in this case the current entry is deleted from the hash
2582 with your iterator holding the last reference to it. Your iterator is flagged
2583 to free the entry on the next call to C<hv_iternext>, so you must not discard
2584 your iterator immediately else the entry will leak - call C<hv_iternext> to
2585 trigger the resource deallocation.
2587 =for apidoc hv_iternext_flags
2589 Returns entries from a hash iterator. See C<L</hv_iterinit>> and
2591 The C<flags> value will normally be zero; if C<HV_ITERNEXT_WANTPLACEHOLDERS> is
2592 set the placeholders keys (for restricted hashes) will be returned in addition
2593 to normal keys. By default placeholders are automatically skipped over.
2594 Currently a placeholder is implemented with a value that is
2595 C<&PL_sv_placeholder>. Note that the implementation of placeholders and
2596 restricted hashes may change, and the implementation currently is
2597 insufficiently abstracted for any change to be tidy.
2603 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2610 struct xpvhv_aux *iter;
2612 PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2614 xhv = (XPVHV*)SvANY(hv);
2617 /* Too many things (well, pp_each at least) merrily assume that you can
2618 call hv_iternext without calling hv_iterinit, so we'll have to deal
2624 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2625 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2626 if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2627 SV * const key = sv_newmortal();
2629 sv_setsv(key, HeSVKEY_force(entry));
2630 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2631 HeSVKEY_set(entry, NULL);
2637 /* one HE per MAGICAL hash */
2638 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2639 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2641 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2643 HeKEY_hek(entry) = hek;
2644 HeKLEN(entry) = HEf_SVKEY;
2646 magic_nextpack(MUTABLE_SV(hv),mg,key);
2648 /* force key to stay around until next time */
2649 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2650 return entry; /* beware, hent_val is not set */
2652 SvREFCNT_dec(HeVAL(entry));
2653 Safefree(HeKEY_hek(entry));
2655 iter = HvAUX(hv); /* may been realloced */
2656 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2661 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
2662 if (!entry && SvRMAGICAL((const SV *)hv)
2663 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2666 /* The prime_env_iter() on VMS just loaded up new hash values
2667 * so the iteration count needs to be reset back to the beginning
2671 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2676 /* hv_iterinit now ensures this. */
2677 assert (HvARRAY(hv));
2679 /* At start of hash, entry is NULL. */
2682 entry = HeNEXT(entry);
2683 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2685 * Skip past any placeholders -- don't want to include them in
2688 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2689 entry = HeNEXT(entry);
2694 #ifdef PERL_HASH_RANDOMIZE_KEYS
2695 if (iter->xhv_last_rand != iter->xhv_rand) {
2696 if (iter->xhv_riter != -1) {
2697 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2698 "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2702 iter = HvAUX(hv); /* may been realloced */
2703 iter->xhv_last_rand = iter->xhv_rand;
2707 /* Skip the entire loop if the hash is empty. */
2708 if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2709 ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2711 /* OK. Come to the end of the current list. Grab the next one. */
2713 iter->xhv_riter++; /* HvRITER(hv)++ */
2714 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2715 /* There is no next one. End of the hash. */
2716 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2717 #ifdef PERL_HASH_RANDOMIZE_KEYS
2718 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2722 entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2724 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2725 /* If we have an entry, but it's a placeholder, don't count it.
2727 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2728 entry = HeNEXT(entry);
2730 /* Will loop again if this linked list starts NULL
2731 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2732 or if we run through it and find only placeholders. */
2736 iter->xhv_riter = -1;
2737 #ifdef PERL_HASH_RANDOMIZE_KEYS
2738 iter->xhv_last_rand = iter->xhv_rand;
2742 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2744 hv_free_ent(hv, oldentry);
2747 iter = HvAUX(hv); /* may been realloced */
2748 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2753 =for apidoc hv_iterkey
2755 Returns the key from the current position of the hash iterator. See
2762 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2764 PERL_ARGS_ASSERT_HV_ITERKEY;
2766 if (HeKLEN(entry) == HEf_SVKEY) {
2768 char * const p = SvPV(HeKEY_sv(entry), len);
2773 *retlen = HeKLEN(entry);
2774 return HeKEY(entry);
2778 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2780 =for apidoc hv_iterkeysv
2782 Returns the key as an C<SV*> from the current position of the hash
2783 iterator. The return value will always be a mortal copy of the key. Also
2784 see C<L</hv_iterinit>>.
2790 Perl_hv_iterkeysv(pTHX_ HE *entry)
2792 PERL_ARGS_ASSERT_HV_ITERKEYSV;
2794 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2798 =for apidoc hv_iterval
2800 Returns the value from the current position of the hash iterator. See
2807 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2809 PERL_ARGS_ASSERT_HV_ITERVAL;
2811 if (SvRMAGICAL(hv)) {
2812 if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2813 SV* const sv = sv_newmortal();
2814 if (HeKLEN(entry) == HEf_SVKEY)
2815 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2817 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2821 return HeVAL(entry);
2825 =for apidoc hv_iternextsv
2827 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2834 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2836 HE * const he = hv_iternext_flags(hv, 0);
2838 PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2842 *key = hv_iterkey(he, retlen);
2843 return hv_iterval(hv, he);
2850 =for apidoc hv_magic
2852 Adds magic to a hash. See C<L</sv_magic>>.
2857 /* possibly free a shared string if no one has access to it
2858 * len and hash must both be valid for str.
2861 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2863 unshare_hek_or_pvn (NULL, str, len, hash);
2868 Perl_unshare_hek(pTHX_ HEK *hek)
2871 unshare_hek_or_pvn(hek, NULL, 0, 0);
2874 /* possibly free a shared string if no one has access to it
2875 hek if non-NULL takes priority over the other 3, else str, len and hash
2876 are used. If so, len and hash must both be valid for str.
2879 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2884 bool is_utf8 = FALSE;
2886 const char * const save = str;
2887 struct shared_he *he = NULL;
2890 /* Find the shared he which is just before us in memory. */
2891 he = (struct shared_he *)(((char *)hek)
2892 - STRUCT_OFFSET(struct shared_he,
2895 /* Assert that the caller passed us a genuine (or at least consistent)
2897 assert (he->shared_he_he.hent_hek == hek);
2899 if (he->shared_he_he.he_valu.hent_refcount - 1) {
2900 --he->shared_he_he.he_valu.hent_refcount;
2904 hash = HEK_HASH(hek);
2905 } else if (len < 0) {
2906 STRLEN tmplen = -len;
2908 /* See the note in hv_fetch(). --jhi */
2909 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2912 k_flags = HVhek_UTF8;
2914 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2917 /* what follows was the moral equivalent of:
2918 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2920 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2922 xhv = (XPVHV*)SvANY(PL_strtab);
2923 /* assert(xhv_array != 0) */
2924 oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2926 const HE *const he_he = &(he->shared_he_he);
2927 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2932 const int flags_masked = k_flags & HVhek_MASK;
2933 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2934 if (HeHASH(entry) != hash) /* strings can't be equal */
2936 if (HeKLEN(entry) != len)
2938 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2940 if (HeKFLAGS(entry) != flags_masked)
2947 if (--entry->he_valu.hent_refcount == 0) {
2948 *oentry = HeNEXT(entry);
2950 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2955 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2956 "Attempt to free nonexistent shared string '%s'%s"
2958 hek ? HEK_KEY(hek) : str,
2959 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2960 if (k_flags & HVhek_FREEKEY)
2964 /* get a (constant) string ptr from the global string table
2965 * string will get added if it is not already there.
2966 * len and hash must both be valid for str.
2969 Perl_share_hek(pTHX_ const char *str, SSize_t len, U32 hash)
2971 bool is_utf8 = FALSE;
2973 const char * const save = str;
2975 PERL_ARGS_ASSERT_SHARE_HEK;
2978 STRLEN tmplen = -len;
2980 /* See the note in hv_fetch(). --jhi */
2981 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2983 /* If we were able to downgrade here, then than means that we were passed
2984 in a key which only had chars 0-255, but was utf8 encoded. */
2987 /* If we found we were able to downgrade the string to bytes, then
2988 we should flag that it needs upgrading on keys or each. Also flag
2989 that we need share_hek_flags to free the string. */
2992 PERL_HASH(hash, str, len);
2993 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2997 return share_hek_flags (str, len, hash, flags);
3001 S_share_hek_flags(pTHX_ const char *str, STRLEN len, U32 hash, int flags)
3004 const int flags_masked = flags & HVhek_MASK;
3005 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
3006 XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
3008 PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
3010 if (UNLIKELY(len > (STRLEN) I32_MAX)) {
3011 Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes");
3014 /* what follows is the moral equivalent of:
3016 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
3017 hv_store(PL_strtab, str, len, NULL, hash);
3019 Can't rehash the shared string table, so not sure if it's worth
3020 counting the number of entries in the linked list
3023 /* assert(xhv_array != 0) */
3024 entry = (HvARRAY(PL_strtab))[hindex];
3025 for (;entry; entry = HeNEXT(entry)) {
3026 if (HeHASH(entry) != hash) /* strings can't be equal */
3028 if (HeKLEN(entry) != (SSize_t) len)
3030 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
3032 if (HeKFLAGS(entry) != flags_masked)
3038 /* What used to be head of the list.
3039 If this is NULL, then we're the first entry for this slot, which
3040 means we need to increate fill. */
3041 struct shared_he *new_entry;
3044 HE **const head = &HvARRAY(PL_strtab)[hindex];
3045 HE *const next = *head;
3047 /* We don't actually store a HE from the arena and a regular HEK.
3048 Instead we allocate one chunk of memory big enough for both,
3049 and put the HEK straight after the HE. This way we can find the
3050 HE directly from the HEK.
3053 Newx(k, STRUCT_OFFSET(struct shared_he,
3054 shared_he_hek.hek_key[0]) + len + 2, char);
3055 new_entry = (struct shared_he *)k;
3056 entry = &(new_entry->shared_he_he);
3057 hek = &(new_entry->shared_he_hek);
3059 Copy(str, HEK_KEY(hek), len, char);
3060 HEK_KEY(hek)[len] = 0;
3062 HEK_HASH(hek) = hash;
3063 HEK_FLAGS(hek) = (unsigned char)flags_masked;
3065 /* Still "point" to the HEK, so that other code need not know what
3067 HeKEY_hek(entry) = hek;
3068 entry->he_valu.hent_refcount = 0;
3069 HeNEXT(entry) = next;
3072 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
3073 if (!next) { /* initial entry? */
3074 } else if ( DO_HSPLIT(xhv) ) {
3075 const STRLEN oldsize = xhv->xhv_max + 1;
3076 hsplit(PL_strtab, oldsize, oldsize * 2);
3080 ++entry->he_valu.hent_refcount;
3082 if (flags & HVhek_FREEKEY)
3085 return HeKEY_hek(entry);
3089 Perl_hv_placeholders_p(pTHX_ HV *hv)
3091 MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3093 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
3096 mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
3099 Perl_die(aTHX_ "panic: hv_placeholders_p");
3102 return &(mg->mg_len);
3107 Perl_hv_placeholders_get(pTHX_ const HV *hv)
3109 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3111 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3112 PERL_UNUSED_CONTEXT;
3114 return mg ? mg->mg_len : 0;
3118 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3120 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3122 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3127 if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3128 Perl_die(aTHX_ "panic: hv_placeholders_set");
3130 /* else we don't need to add magic to record 0 placeholders. */
3134 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3139 PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3141 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3146 value = &PL_sv_placeholder;
3149 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3152 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3155 case HVrhek_PV_UTF8:
3156 /* Create a string SV that directly points to the bytes in our
3158 value = newSV_type(SVt_PV);
3159 SvPV_set(value, (char *) he->refcounted_he_data + 1);
3160 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3161 /* This stops anything trying to free it */
3162 SvLEN_set(value, 0);
3164 SvREADONLY_on(value);
3165 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3169 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf,
3170 (UV)he->refcounted_he_data[0]);
3176 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
3178 Generates and returns a C<HV *> representing the content of a
3179 C<refcounted_he> chain.
3180 C<flags> is currently unused and must be zero.
3185 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3189 U32 placeholders, max;
3192 Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf,
3195 /* We could chase the chain once to get an idea of the number of keys,
3196 and call ksplit. But for now we'll make a potentially inefficient
3197 hash with only 8 entries in its array. */
3202 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3203 HvARRAY(hv) = (HE**)array;
3209 U32 hash = chain->refcounted_he_hash;
3211 U32 hash = HEK_HASH(chain->refcounted_he_hek);
3213 HE **oentry = &((HvARRAY(hv))[hash & max]);
3214 HE *entry = *oentry;
3217 for (; entry; entry = HeNEXT(entry)) {
3218 if (HeHASH(entry) == hash) {
3219 /* We might have a duplicate key here. If so, entry is older
3220 than the key we've already put in the hash, so if they are
3221 the same, skip adding entry. */
3223 const STRLEN klen = HeKLEN(entry);
3224 const char *const key = HeKEY(entry);
3225 if (klen == chain->refcounted_he_keylen
3226 && (!!HeKUTF8(entry)
3227 == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3228 && memEQ(key, REF_HE_KEY(chain), klen))
3231 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3233 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3234 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3235 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3246 = share_hek_flags(REF_HE_KEY(chain),
3247 chain->refcounted_he_keylen,
3248 chain->refcounted_he_hash,
3249 (chain->refcounted_he_data[0]
3250 & (HVhek_UTF8|HVhek_WASUTF8)));
3252 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3254 value = refcounted_he_value(chain);
3255 if (value == &PL_sv_placeholder)
3257 HeVAL(entry) = value;
3259 /* Link it into the chain. */
3260 HeNEXT(entry) = *oentry;
3266 chain = chain->refcounted_he_next;
3270 clear_placeholders(hv, placeholders);
3271 HvTOTALKEYS(hv) -= placeholders;
3274 /* We could check in the loop to see if we encounter any keys with key
3275 flags, but it's probably not worth it, as this per-hash flag is only
3276 really meant as an optimisation for things like Storable. */
3278 DEBUG_A(Perl_hv_assert(aTHX_ hv));
3284 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
3286 Search along a C<refcounted_he> chain for an entry with the key specified
3287 by C<keypv> and C<keylen>. If C<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3288 bit set, the key octets are interpreted as UTF-8, otherwise they
3289 are interpreted as Latin-1. C<hash> is a precomputed hash of the key
3290 string, or zero if it has not been precomputed. Returns a mortal scalar
3291 representing the value associated with the key, or C<&PL_sv_placeholder>
3292 if there is no value associated with the key.
3298 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3299 const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3303 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3305 if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3306 Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf,
3310 if (flags & REFCOUNTED_HE_KEY_UTF8) {
3311 /* For searching purposes, canonicalise to Latin-1 where possible. */
3312 const char *keyend = keypv + keylen, *p;
3313 STRLEN nonascii_count = 0;
3314 for (p = keypv; p != keyend; p++) {
3315 if (! UTF8_IS_INVARIANT(*p)) {
3316 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3317 goto canonicalised_key;
3323 if (nonascii_count) {
3325 const char *p = keypv, *keyend = keypv + keylen;
3326 keylen -= nonascii_count;
3327 Newx(q, keylen, char);
3330 for (; p != keyend; p++, q++) {
3332 if (UTF8_IS_INVARIANT(c)) {
3337 *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3341 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3342 canonicalised_key: ;
3344 utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3346 PERL_HASH(hash, keypv, keylen);
3348 for (; chain; chain = chain->refcounted_he_next) {
3351 hash == chain->refcounted_he_hash &&
3352 keylen == chain->refcounted_he_keylen &&
3353 memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3354 utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3356 hash == HEK_HASH(chain->refcounted_he_hek) &&
3357 keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3358 memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3359 utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3362 if (flags & REFCOUNTED_HE_EXISTS)
3363 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3365 ? NULL : &PL_sv_yes;
3366 return sv_2mortal(refcounted_he_value(chain));
3370 return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3374 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3376 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3377 instead of a string/length pair.
3383 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3384 const char *key, U32 hash, U32 flags)
3386 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3387 return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3391 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3393 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3400 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3401 SV *key, U32 hash, U32 flags)
3405 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3406 if (flags & REFCOUNTED_HE_KEY_UTF8)
3407 Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf,
3409 keypv = SvPV_const(key, keylen);
3411 flags |= REFCOUNTED_HE_KEY_UTF8;
3412 if (!hash && SvIsCOW_shared_hash(key))
3413 hash = SvSHARED_HASH(key);
3414 return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3418 =for apidoc m|struct refcounted_he *|refcounted_he_new_pvn|struct refcounted_he *parent|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
3420 Creates a new C<refcounted_he>. This consists of a single key/value
3421 pair and a reference to an existing C<refcounted_he> chain (which may
3422 be empty), and thus forms a longer chain. When using the longer chain,
3423 the new key/value pair takes precedence over any entry for the same key
3424 further along the chain.
3426 The new key is specified by C<keypv> and C<keylen>. If C<flags> has
3427 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3428 as UTF-8, otherwise they are interpreted as Latin-1. C<hash> is
3429 a precomputed hash of the key string, or zero if it has not been
3432 C<value> is the scalar value to store for this key. C<value> is copied
3433 by this function, which thus does not take ownership of any reference
3434 to it, and later changes to the scalar will not be reflected in the
3435 value visible in the C<refcounted_he>. Complex types of scalar will not
3436 be stored with referential integrity, but will be coerced to strings.
3437 C<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3438 value is to be associated with the key; this, as with any non-null value,
3439 takes precedence over the existence of a value for the key further along
3442 C<parent> points to the rest of the C<refcounted_he> chain to be
3443 attached to the new C<refcounted_he>. This function takes ownership
3444 of one reference to C<parent>, and returns one reference to the new
3450 struct refcounted_he *
3451 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3452 const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3455 STRLEN value_len = 0;
3456 const char *value_p = NULL;
3460 STRLEN key_offset = 1;
3461 struct refcounted_he *he;
3462 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3464 if (!value || value == &PL_sv_placeholder) {
3465 value_type = HVrhek_delete;
3466 } else if (SvPOK(value)) {
3467 value_type = HVrhek_PV;
3468 } else if (SvIOK(value)) {
3469 value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3470 } else if (!SvOK(value)) {
3471 value_type = HVrhek_undef;
3473 value_type = HVrhek_PV;
3475 is_pv = value_type == HVrhek_PV;
3477 /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3478 the value is overloaded, and doesn't yet have the UTF-8flag set. */
3479 value_p = SvPV_const(value, value_len);
3481 value_type = HVrhek_PV_UTF8;
3482 key_offset = value_len + 2;
3484 hekflags = value_type;
3486 if (flags & REFCOUNTED_HE_KEY_UTF8) {
3487 /* Canonicalise to Latin-1 where possible. */
3488 const char *keyend = keypv + keylen, *p;
3489 STRLEN nonascii_count = 0;
3490 for (p = keypv; p != keyend; p++) {
3491 if (! UTF8_IS_INVARIANT(*p)) {
3492 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3493 goto canonicalised_key;
3499 if (nonascii_count) {
3501 const char *p = keypv, *keyend = keypv + keylen;
3502 keylen -= nonascii_count;
3503 Newx(q, keylen, char);
3506 for (; p != keyend; p++, q++) {
3508 if (UTF8_IS_INVARIANT(c)) {
3513 *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3517 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3518 canonicalised_key: ;
3520 if (flags & REFCOUNTED_HE_KEY_UTF8)
3521 hekflags |= HVhek_UTF8;
3523 PERL_HASH(hash, keypv, keylen);
3526 he = (struct refcounted_he*)
3527 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3531 he = (struct refcounted_he*)
3532 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3536 he->refcounted_he_next = parent;
3539 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3540 he->refcounted_he_val.refcounted_he_u_len = value_len;
3541 } else if (value_type == HVrhek_IV) {
3542 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3543 } else if (value_type == HVrhek_UV) {
3544 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3548 he->refcounted_he_hash = hash;
3549 he->refcounted_he_keylen = keylen;
3550 Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3552 he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3555 he->refcounted_he_data[0] = hekflags;
3556 he->refcounted_he_refcnt = 1;
3562 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3564 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3565 of a string/length pair.
3570 struct refcounted_he *
3571 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3572 const char *key, U32 hash, SV *value, U32 flags)
3574 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3575 return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3579 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3581 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3587 struct refcounted_he *
3588 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3589 SV *key, U32 hash, SV *value, U32 flags)
3593 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3594 if (flags & REFCOUNTED_HE_KEY_UTF8)
3595 Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf,
3597 keypv = SvPV_const(key, keylen);
3599 flags |= REFCOUNTED_HE_KEY_UTF8;
3600 if (!hash && SvIsCOW_shared_hash(key))
3601 hash = SvSHARED_HASH(key);
3602 return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3606 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3608 Decrements the reference count of a C<refcounted_he> by one. If the
3609 reference count reaches zero the structure's memory is freed, which
3610 (recursively) causes a reduction of its parent C<refcounted_he>'s
3611 reference count. It is safe to pass a null pointer to this function:
3612 no action occurs in this case.
3618 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3622 PERL_UNUSED_CONTEXT;
3625 struct refcounted_he *copy;
3629 new_count = --he->refcounted_he_refcnt;
3630 HINTS_REFCNT_UNLOCK;
3636 #ifndef USE_ITHREADS
3637 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3640 he = he->refcounted_he_next;
3641 PerlMemShared_free(copy);
3646 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3648 Increment the reference count of a C<refcounted_he>. The pointer to the
3649 C<refcounted_he> is also returned. It is safe to pass a null pointer
3650 to this function: no action occurs and a null pointer is returned.
3655 struct refcounted_he *
3656 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3661 PERL_UNUSED_CONTEXT;
3664 he->refcounted_he_refcnt++;
3665 HINTS_REFCNT_UNLOCK;
3671 =for apidoc cop_fetch_label
3673 Returns the label attached to a cop.
3674 The flags pointer may be set to C<SVf_UTF8> or 0.
3679 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3682 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3683 struct refcounted_he *const chain = cop->cop_hints_hash;
3685 PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3686 PERL_UNUSED_CONTEXT;
3691 if (chain->refcounted_he_keylen != 1)
3693 if (*REF_HE_KEY(chain) != ':')
3696 if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3698 if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3701 /* Stop anyone trying to really mess us up by adding their own value for
3703 if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3704 && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3708 *len = chain->refcounted_he_val.refcounted_he_u_len;
3710 *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3711 == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3713 return chain->refcounted_he_data + 1;
3717 =for apidoc cop_store_label
3719 Save a label into a C<cop_hints_hash>.
3720 You need to set flags to C<SVf_UTF8>
3727 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3731 PERL_ARGS_ASSERT_COP_STORE_LABEL;
3733 if (flags & ~(SVf_UTF8))
3734 Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3736 labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3737 if (flags & SVf_UTF8)
3740 = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3744 =for apidoc hv_assert
3746 Check that a hash is in an internally consistent state.
3754 Perl_hv_assert(pTHX_ HV *hv)
3759 int placeholders = 0;
3762 const I32 riter = HvRITER_get(hv);
3763 HE *eiter = HvEITER_get(hv);
3765 PERL_ARGS_ASSERT_HV_ASSERT;
3767 (void)hv_iterinit(hv);
3769 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3770 /* sanity check the values */
3771 if (HeVAL(entry) == &PL_sv_placeholder)
3775 /* sanity check the keys */
3776 if (HeSVKEY(entry)) {
3777 NOOP; /* Don't know what to check on SV keys. */
3778 } else if (HeKUTF8(entry)) {
3780 if (HeKWASUTF8(entry)) {
3781 PerlIO_printf(Perl_debug_log,
3782 "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3783 (int) HeKLEN(entry), HeKEY(entry));
3786 } else if (HeKWASUTF8(entry))
3789 if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3790 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3791 const int nhashkeys = HvUSEDKEYS(hv);
3792 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3794 if (nhashkeys != real) {
3795 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3798 if (nhashplaceholders != placeholders) {
3799 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3803 if (withflags && ! HvHASKFLAGS(hv)) {
3804 PerlIO_printf(Perl_debug_log,
3805 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3810 sv_dump(MUTABLE_SV(hv));
3812 HvRITER_set(hv, riter); /* Restore hash iterator state */
3813 HvEITER_set(hv, eiter);
3819 * ex: set ts=8 sts=4 sw=4 et: