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
22 A HV structure represents a Perl hash. It consists mainly of an array
23 of pointers, each of which points to a linked list of HE structures. The
24 array is indexed by the hash function of the key, so each linked list
25 represents all the hash entries with the same hash value. Each HE contains
26 a pointer to the actual value, plus a pointer to a HEK structure which
27 holds the key and hash value.
35 #define PERL_HASH_INTERNAL_ACCESS
38 #define DO_HSPLIT(xhv) ((xhv)->xhv_keys > (xhv)->xhv_max) /* HvTOTALKEYS(hv) > HvMAX(hv) */
40 static const char S_strtab_error[]
41 = "Cannot modify shared string table in hv_%s";
45 #define new_HE() (HE*)safemalloc(sizeof(HE))
46 #define del_HE(p) safefree((char*)p)
55 void ** const root = &PL_body_roots[HE_SVSLOT];
58 Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE);
65 #define new_HE() new_he()
68 HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \
69 PL_body_roots[HE_SVSLOT] = p; \
77 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
79 const int flags_masked = flags & HVhek_MASK;
83 PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
85 Newx(k, HEK_BASESIZE + len + 2, char);
87 Copy(str, HEK_KEY(hek), len, char);
88 HEK_KEY(hek)[len] = 0;
91 HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
93 if (flags & HVhek_FREEKEY)
98 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
102 Perl_free_tied_hv_pool(pTHX)
105 HE *he = PL_hv_fetch_ent_mh;
108 Safefree(HeKEY_hek(he));
112 PL_hv_fetch_ent_mh = NULL;
115 #if defined(USE_ITHREADS)
117 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
121 PERL_ARGS_ASSERT_HEK_DUP;
122 PERL_UNUSED_ARG(param);
127 shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
129 /* We already shared this hash key. */
130 (void)share_hek_hek(shared);
134 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
135 HEK_HASH(source), HEK_FLAGS(source));
136 ptr_table_store(PL_ptr_table, source, shared);
142 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
146 PERL_ARGS_ASSERT_HE_DUP;
150 /* look for it in the table first */
151 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
155 /* create anew and remember what it is */
157 ptr_table_store(PL_ptr_table, e, ret);
159 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
160 if (HeKLEN(e) == HEf_SVKEY) {
162 Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
163 HeKEY_hek(ret) = (HEK*)k;
164 HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param);
167 /* This is hek_dup inlined, which seems to be important for speed
169 HEK * const source = HeKEY_hek(e);
170 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
173 /* We already shared this hash key. */
174 (void)share_hek_hek(shared);
178 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
179 HEK_HASH(source), HEK_FLAGS(source));
180 ptr_table_store(PL_ptr_table, source, shared);
182 HeKEY_hek(ret) = shared;
185 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
187 HeVAL(ret) = sv_dup_inc(HeVAL(e), param);
190 #endif /* USE_ITHREADS */
193 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
196 SV * const sv = sv_newmortal();
198 PERL_ARGS_ASSERT_HV_NOTALLOWED;
200 if (!(flags & HVhek_FREEKEY)) {
201 sv_setpvn(sv, key, klen);
204 /* Need to free saved eventually assign to mortal SV */
205 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
206 sv_usepvn(sv, (char *) key, klen);
208 if (flags & HVhek_UTF8) {
211 Perl_croak(aTHX_ msg, SVfARG(sv));
214 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
220 Stores an SV in a hash. The hash key is specified as C<key> and the
221 absolute value of C<klen> is the length of the key. If C<klen> is
222 negative the key is assumed to be in UTF-8-encoded Unicode. The
223 C<hash> parameter is the precomputed hash value; if it is zero then
224 Perl will compute it.
226 The return value will be
227 NULL if the operation failed or if the value did not need to be actually
228 stored within the hash (as in the case of tied hashes). Otherwise it can
229 be dereferenced to get the original C<SV*>. Note that the caller is
230 responsible for suitably incrementing the reference count of C<val> before
231 the call, and decrementing it if the function returned NULL. Effectively
232 a successful hv_store takes ownership of one reference to C<val>. This is
233 usually what you want; a newly created SV has a reference count of one, so
234 if all your code does is create SVs then store them in a hash, hv_store
235 will own the only reference to the new SV, and your code doesn't need to do
236 anything further to tidy up. hv_store is not implemented as a call to
237 hv_store_ent, and does not create a temporary SV for the key, so if your
238 key data is not already in SV form then use hv_store in preference to
241 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
242 information on how to use this function on tied hashes.
244 =for apidoc hv_store_ent
246 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
247 parameter is the precomputed hash value; if it is zero then Perl will
248 compute it. The return value is the new hash entry so created. It will be
249 NULL if the operation failed or if the value did not need to be actually
250 stored within the hash (as in the case of tied hashes). Otherwise the
251 contents of the return value can be accessed using the C<He?> macros
252 described here. Note that the caller is responsible for suitably
253 incrementing the reference count of C<val> before the call, and
254 decrementing it if the function returned NULL. Effectively a successful
255 hv_store_ent takes ownership of one reference to C<val>. This is
256 usually what you want; a newly created SV has a reference count of one, so
257 if all your code does is create SVs then store them in a hash, hv_store
258 will own the only reference to the new SV, and your code doesn't need to do
259 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
260 unlike C<val> it does not take ownership of it, so maintaining the correct
261 reference count on C<key> is entirely the caller's responsibility. hv_store
262 is not implemented as a call to hv_store_ent, and does not create a temporary
263 SV for the key, so if your key data is not already in SV form then use
264 hv_store in preference to hv_store_ent.
266 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
267 information on how to use this function on tied hashes.
269 =for apidoc hv_exists
271 Returns a boolean indicating whether the specified hash key exists. The
272 absolute value of C<klen> is the length of the key. If C<klen> is
273 negative the key is assumed to be in UTF-8-encoded Unicode.
277 Returns the SV which corresponds to the specified key in the hash.
278 The absolute value of C<klen> is the length of the key. If C<klen> is
279 negative the key is assumed to be in UTF-8-encoded Unicode. If
280 C<lval> is set then the fetch will be part of a store. This means that if
281 there is no value in the hash associated with the given key, then one is
282 created and a pointer to it is returned. The C<SV*> it points to can be
283 assigned to. But always check that the
284 return value is non-null before dereferencing it to an C<SV*>.
286 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
287 information on how to use this function on tied hashes.
289 =for apidoc hv_exists_ent
291 Returns a boolean indicating whether
292 the specified hash key exists. C<hash>
293 can be a valid precomputed hash value, or 0 to ask for it to be
299 /* returns an HE * structure with the all fields set */
300 /* note that hent_val will be a mortal sv for MAGICAL hashes */
302 =for apidoc hv_fetch_ent
304 Returns the hash entry which corresponds to the specified key in the hash.
305 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
306 if you want the function to compute it. IF C<lval> is set then the fetch
307 will be part of a store. Make sure the return value is non-null before
308 accessing it. The return value when C<hv> is a tied hash is a pointer to a
309 static location, so be sure to make a copy of the structure if you need to
312 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
313 information on how to use this function on tied hashes.
318 /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */
320 Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
321 const int action, SV *val, const U32 hash)
326 PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN;
335 return hv_common(hv, NULL, key, klen, flags, action, val, hash);
339 Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
340 int flags, int action, SV *val, U32 hash)
349 const int return_svp = action & HV_FETCH_JUST_SV;
353 if (SvTYPE(hv) == (svtype)SVTYPEMASK)
356 assert(SvTYPE(hv) == SVt_PVHV);
358 if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
360 if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) {
361 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
362 if (uf->uf_set == NULL) {
363 SV* obj = mg->mg_obj;
366 keysv = newSVpvn_flags(key, klen, SVs_TEMP |
367 ((flags & HVhek_UTF8)
371 mg->mg_obj = keysv; /* pass key */
372 uf->uf_index = action; /* pass action */
373 magic_getuvar(MUTABLE_SV(hv), mg);
374 keysv = mg->mg_obj; /* may have changed */
377 /* If the key may have changed, then we need to invalidate
378 any passed-in computed hash value. */
384 if (flags & HVhek_FREEKEY)
386 key = SvPV_const(keysv, klen);
387 is_utf8 = (SvUTF8(keysv) != 0);
388 if (SvIsCOW_shared_hash(keysv)) {
389 flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
391 flags = is_utf8 ? HVhek_UTF8 : 0;
394 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
397 if (action & HV_DELETE) {
398 return (void *) hv_delete_common(hv, keysv, key, klen,
399 flags, action, hash);
402 xhv = (XPVHV*)SvANY(hv);
404 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
405 if (mg_find((const SV *)hv, PERL_MAGIC_tied)
406 || SvGMAGICAL((const SV *)hv))
408 /* FIXME should be able to skimp on the HE/HEK here when
409 HV_FETCH_JUST_SV is true. */
411 keysv = newSVpvn_utf8(key, klen, is_utf8);
413 keysv = newSVsv(keysv);
416 mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY);
418 /* grab a fake HE/HEK pair from the pool or make a new one */
419 entry = PL_hv_fetch_ent_mh;
421 PL_hv_fetch_ent_mh = HeNEXT(entry);
425 Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
426 HeKEY_hek(entry) = (HEK*)k;
428 HeNEXT(entry) = NULL;
429 HeSVKEY_set(entry, keysv);
431 sv_upgrade(sv, SVt_PVLV);
433 /* so we can free entry when freeing sv */
434 LvTARG(sv) = MUTABLE_SV(entry);
436 /* XXX remove at some point? */
437 if (flags & HVhek_FREEKEY)
441 return entry ? (void *) &HeVAL(entry) : NULL;
443 return (void *) entry;
445 #ifdef ENV_IS_CASELESS
446 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
448 for (i = 0; i < klen; ++i)
449 if (isLOWER(key[i])) {
450 /* Would be nice if we had a routine to do the
451 copy and upercase in a single pass through. */
452 const char * const nkey = strupr(savepvn(key,klen));
453 /* Note that this fetch is for nkey (the uppercased
454 key) whereas the store is for key (the original) */
455 void *result = hv_common(hv, NULL, nkey, klen,
456 HVhek_FREEKEY, /* free nkey */
457 0 /* non-LVAL fetch */
458 | HV_DISABLE_UVAR_XKEY
461 0 /* compute hash */);
462 if (!result && (action & HV_FETCH_LVALUE)) {
463 /* This call will free key if necessary.
464 Do it this way to encourage compiler to tail
466 result = hv_common(hv, keysv, key, klen, flags,
468 | HV_DISABLE_UVAR_XKEY
472 if (flags & HVhek_FREEKEY)
480 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
481 if (mg_find((const SV *)hv, PERL_MAGIC_tied)
482 || SvGMAGICAL((const SV *)hv)) {
483 /* I don't understand why hv_exists_ent has svret and sv,
484 whereas hv_exists only had one. */
485 SV * const svret = sv_newmortal();
488 if (keysv || is_utf8) {
490 keysv = newSVpvn_utf8(key, klen, TRUE);
492 keysv = newSVsv(keysv);
494 mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
496 mg_copy(MUTABLE_SV(hv), sv, key, klen);
498 if (flags & HVhek_FREEKEY)
500 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
501 /* This cast somewhat evil, but I'm merely using NULL/
502 not NULL to return the boolean exists.
503 And I know hv is not NULL. */
504 return SvTRUE(svret) ? (void *)hv : NULL;
506 #ifdef ENV_IS_CASELESS
507 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
508 /* XXX This code isn't UTF8 clean. */
509 char * const keysave = (char * const)key;
510 /* Will need to free this, so set FREEKEY flag. */
511 key = savepvn(key,klen);
512 key = (const char*)strupr((char*)key);
517 if (flags & HVhek_FREEKEY) {
520 flags |= HVhek_FREEKEY;
524 else if (action & HV_FETCH_ISSTORE) {
527 hv_magic_check (hv, &needs_copy, &needs_store);
529 const bool save_taint = TAINT_get; /* Unused var warning under NO_TAINT_SUPPORT */
530 if (keysv || is_utf8) {
532 keysv = newSVpvn_utf8(key, klen, TRUE);
535 TAINT_set(SvTAINTED(keysv));
536 keysv = sv_2mortal(newSVsv(keysv));
537 mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
539 mg_copy(MUTABLE_SV(hv), val, key, klen);
542 TAINT_IF(save_taint);
544 if (flags & HVhek_FREEKEY)
548 #ifdef ENV_IS_CASELESS
549 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
550 /* XXX This code isn't UTF8 clean. */
551 const char *keysave = key;
552 /* Will need to free this, so set FREEKEY flag. */
553 key = savepvn(key,klen);
554 key = (const char*)strupr((char*)key);
559 if (flags & HVhek_FREEKEY) {
562 flags |= HVhek_FREEKEY;
570 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
571 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
572 || (SvRMAGICAL((const SV *)hv)
573 && mg_find((const SV *)hv, PERL_MAGIC_env))
578 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
580 HvARRAY(hv) = (HE**)array;
582 #ifdef DYNAMIC_ENV_FETCH
583 else if (action & HV_FETCH_ISEXISTS) {
584 /* for an %ENV exists, if we do an insert it's by a recursive
585 store call, so avoid creating HvARRAY(hv) right now. */
589 /* XXX remove at some point? */
590 if (flags & HVhek_FREEKEY)
597 if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) {
598 char * const keysave = (char *)key;
599 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
603 flags &= ~HVhek_UTF8;
604 if (key != keysave) {
605 if (flags & HVhek_FREEKEY)
607 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
608 /* If the caller calculated a hash, it was on the sequence of
609 octets that are the UTF-8 form. We've now changed the sequence
610 of octets stored to that of the equivalent byte representation,
611 so the hash we need is different. */
617 if (keysv && (SvIsCOW_shared_hash(keysv)))
618 hash = SvSHARED_HASH(keysv);
620 PERL_HASH(hash, key, klen);
623 masked_flags = (flags & HVhek_MASK);
625 #ifdef DYNAMIC_ENV_FETCH
626 if (!HvARRAY(hv)) entry = NULL;
630 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
632 for (; entry; entry = HeNEXT(entry)) {
633 if (HeHASH(entry) != hash) /* strings can't be equal */
635 if (HeKLEN(entry) != (I32)klen)
637 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
639 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
642 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
643 if (HeKFLAGS(entry) != masked_flags) {
644 /* We match if HVhek_UTF8 bit in our flags and hash key's
645 match. But if entry was set previously with HVhek_WASUTF8
646 and key now doesn't (or vice versa) then we should change
647 the key's flag, as this is assignment. */
648 if (HvSHAREKEYS(hv)) {
649 /* Need to swap the key we have for a key with the flags we
650 need. As keys are shared we can't just write to the
651 flag, so we share the new one, unshare the old one. */
652 HEK * const new_hek = share_hek_flags(key, klen, hash,
654 unshare_hek (HeKEY_hek(entry));
655 HeKEY_hek(entry) = new_hek;
657 else if (hv == PL_strtab) {
658 /* PL_strtab is usually the only hash without HvSHAREKEYS,
659 so putting this test here is cheap */
660 if (flags & HVhek_FREEKEY)
662 Perl_croak(aTHX_ S_strtab_error,
663 action & HV_FETCH_LVALUE ? "fetch" : "store");
666 HeKFLAGS(entry) = masked_flags;
667 if (masked_flags & HVhek_ENABLEHVKFLAGS)
670 if (HeVAL(entry) == &PL_sv_placeholder) {
671 /* yes, can store into placeholder slot */
672 if (action & HV_FETCH_LVALUE) {
674 /* This preserves behaviour with the old hv_fetch
675 implementation which at this point would bail out
676 with a break; (at "if we find a placeholder, we
677 pretend we haven't found anything")
679 That break mean that if a placeholder were found, it
680 caused a call into hv_store, which in turn would
681 check magic, and if there is no magic end up pretty
682 much back at this point (in hv_store's code). */
685 /* LVAL fetch which actually needs a store. */
687 HvPLACEHOLDERS(hv)--;
690 if (val != &PL_sv_placeholder)
691 HvPLACEHOLDERS(hv)--;
694 } else if (action & HV_FETCH_ISSTORE) {
695 SvREFCNT_dec(HeVAL(entry));
698 } else if (HeVAL(entry) == &PL_sv_placeholder) {
699 /* if we find a placeholder, we pretend we haven't found
703 if (flags & HVhek_FREEKEY)
706 return entry ? (void *) &HeVAL(entry) : NULL;
710 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
711 if (!(action & HV_FETCH_ISSTORE)
712 && SvRMAGICAL((const SV *)hv)
713 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
715 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
717 sv = newSVpvn(env,len);
719 return hv_common(hv, keysv, key, klen, flags,
720 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
726 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
727 hv_notallowed(flags, key, klen,
728 "Attempt to access disallowed key '%"SVf"' in"
729 " a restricted hash");
731 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
732 /* Not doing some form of store, so return failure. */
733 if (flags & HVhek_FREEKEY)
737 if (action & HV_FETCH_LVALUE) {
738 val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0);
740 /* At this point the old hv_fetch code would call to hv_store,
741 which in turn might do some tied magic. So we need to make that
742 magic check happen. */
743 /* gonna assign to this, so it better be there */
744 /* If a fetch-as-store fails on the fetch, then the action is to
745 recurse once into "hv_store". If we didn't do this, then that
746 recursive call would call the key conversion routine again.
747 However, as we replace the original key with the converted
748 key, this would result in a double conversion, which would show
749 up as a bug if the conversion routine is not idempotent. */
750 return hv_common(hv, keysv, key, klen, flags,
751 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
753 /* XXX Surely that could leak if the fetch-was-store fails?
754 Just like the hv_fetch. */
758 /* Welcome to hv_store... */
761 /* Not sure if we can get here. I think the only case of oentry being
762 NULL is for %ENV with dynamic env fetch. But that should disappear
763 with magic in the previous code. */
766 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
768 HvARRAY(hv) = (HE**)array;
771 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
774 /* share_hek_flags will do the free for us. This might be considered
777 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
778 else if (hv == PL_strtab) {
779 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
780 this test here is cheap */
781 if (flags & HVhek_FREEKEY)
783 Perl_croak(aTHX_ S_strtab_error,
784 action & HV_FETCH_LVALUE ? "fetch" : "store");
786 else /* gotta do the real thing */
787 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
789 HeNEXT(entry) = *oentry;
792 if (val == &PL_sv_placeholder)
793 HvPLACEHOLDERS(hv)++;
794 if (masked_flags & HVhek_ENABLEHVKFLAGS)
797 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
798 if ( DO_HSPLIT(xhv) ) {
799 const STRLEN oldsize = xhv->xhv_max + 1;
801 if (HvPLACEHOLDERS_get(hv) /* hash has placeholders */
802 && !SvREADONLY(hv) /* but is not a restricted hash */) {
803 /* If this hash previously was a "restricted hash" and had
804 placeholders, but the "restricted" flag has been turned off,
805 then the placeholders no longer serve any useful purpose.
806 However, they have the downsides of taking up RAM, and adding
807 extra steps when finding used values. It's safe to clear them
808 at this point, even though Storable rebuilds restricted hashes by
809 putting in all the placeholders (first) before turning on the
810 readonly flag, because Storable always pre-splits the hash.
811 If we're lucky, then we may clear sufficient placeholders to
812 avoid needing to split the hash at all. */
813 hv_clear_placeholders(hv);
815 hsplit(hv, oldsize, oldsize * 2);
817 hsplit(hv, oldsize, oldsize * 2);
821 return entry ? (void *) &HeVAL(entry) : NULL;
823 return (void *) entry;
827 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
829 const MAGIC *mg = SvMAGIC(hv);
831 PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
836 if (isUPPER(mg->mg_type)) {
838 if (mg->mg_type == PERL_MAGIC_tied) {
839 *needs_store = FALSE;
840 return; /* We've set all there is to set. */
843 mg = mg->mg_moremagic;
848 =for apidoc hv_scalar
850 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
856 Perl_hv_scalar(pTHX_ HV *hv)
860 PERL_ARGS_ASSERT_HV_SCALAR;
862 if (SvRMAGICAL(hv)) {
863 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
865 return magic_scalarpack(hv, mg);
869 if (HvTOTALKEYS((const HV *)hv))
870 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
871 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
879 =for apidoc hv_delete
881 Deletes a key/value pair in the hash. The value's SV is removed from
882 the hash, made mortal, and returned to the caller. The absolute
883 value of C<klen> is the length of the key. If C<klen> is negative the
884 key is assumed to be in UTF-8-encoded Unicode. The C<flags> value
885 will normally be zero; if set to G_DISCARD then NULL will be returned.
886 NULL will also be returned if the key is not found.
888 =for apidoc hv_delete_ent
890 Deletes a key/value pair in the hash. The value SV is removed from the hash,
891 made mortal, and returned to the caller. The C<flags> value will normally be
892 zero; if set to G_DISCARD then NULL will be returned. NULL will also be
893 returned if the key is not found. C<hash> can be a valid precomputed hash
894 value, or 0 to ask for it to be computed.
900 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
901 int k_flags, I32 d_flags, U32 hash)
907 bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
910 if (SvRMAGICAL(hv)) {
913 hv_magic_check (hv, &needs_copy, &needs_store);
917 entry = (HE *) hv_common(hv, keysv, key, klen,
918 k_flags & ~HVhek_FREEKEY,
919 HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
921 sv = entry ? HeVAL(entry) : NULL;
927 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
928 /* No longer an element */
929 sv_unmagic(sv, PERL_MAGIC_tiedelem);
932 return NULL; /* element cannot be deleted */
934 #ifdef ENV_IS_CASELESS
935 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
936 /* XXX This code isn't UTF8 clean. */
937 keysv = newSVpvn_flags(key, klen, SVs_TEMP);
938 if (k_flags & HVhek_FREEKEY) {
941 key = strupr(SvPVX(keysv));
950 xhv = (XPVHV*)SvANY(hv);
954 if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
955 const char * const keysave = key;
956 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
959 k_flags |= HVhek_UTF8;
961 k_flags &= ~HVhek_UTF8;
962 if (key != keysave) {
963 if (k_flags & HVhek_FREEKEY) {
964 /* This shouldn't happen if our caller does what we expect,
965 but strictly the API allows it. */
968 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
970 HvHASKFLAGS_on(MUTABLE_SV(hv));
974 if (keysv && (SvIsCOW_shared_hash(keysv)))
975 hash = SvSHARED_HASH(keysv);
977 PERL_HASH(hash, key, klen);
980 masked_flags = (k_flags & HVhek_MASK);
982 oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
984 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
986 U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
990 if (HeHASH(entry) != hash) /* strings can't be equal */
992 if (HeKLEN(entry) != (I32)klen)
994 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
996 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
999 if (hv == PL_strtab) {
1000 if (k_flags & HVhek_FREEKEY)
1002 Perl_croak(aTHX_ S_strtab_error, "delete");
1005 /* if placeholder is here, it's already been deleted.... */
1006 if (HeVAL(entry) == &PL_sv_placeholder) {
1007 if (k_flags & HVhek_FREEKEY)
1011 if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))
1012 && !SvIsCOW(HeVAL(entry))) {
1013 hv_notallowed(k_flags, key, klen,
1014 "Attempt to delete readonly key '%"SVf"' from"
1015 " a restricted hash");
1017 if (k_flags & HVhek_FREEKEY)
1020 /* If this is a stash and the key ends with ::, then someone is
1021 * deleting a package.
1023 if (HeVAL(entry) && HvENAME_get(hv)) {
1024 gv = (GV *)HeVAL(entry);
1025 if (keysv) key = SvPV(keysv, klen);
1027 (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1029 (klen == 1 && key[0] == ':')
1031 && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1032 && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
1033 && HvENAME_get(stash)) {
1034 /* A previous version of this code checked that the
1035 * GV was still in the symbol table by fetching the
1036 * GV with its name. That is not necessary (and
1037 * sometimes incorrect), as HvENAME cannot be set
1038 * on hv if it is not in the symtab. */
1040 /* Hang on to it for a bit. */
1041 SvREFCNT_inc_simple_void_NN(
1042 sv_2mortal((SV *)gv)
1045 else if (klen == 3 && strnEQ(key, "ISA", 3))
1049 sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
1050 HeVAL(entry) = &PL_sv_placeholder;
1052 /* deletion of method from stash */
1053 if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1055 mro_method_changed_in(hv);
1059 * If a restricted hash, rather than really deleting the entry, put
1060 * a placeholder there. This marks the key as being "approved", so
1061 * we can still access via not-really-existing key without raising
1065 /* We'll be saving this slot, so the number of allocated keys
1066 * doesn't go down, but the number placeholders goes up */
1067 HvPLACEHOLDERS(hv)++;
1069 *oentry = HeNEXT(entry);
1070 if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1073 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1074 entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1075 HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1076 hv_free_ent(hv, entry);
1078 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1079 if (xhv->xhv_keys == 0)
1080 HvHASKFLAGS_off(hv);
1083 if (d_flags & G_DISCARD) {
1088 if (mro_changes == 1) mro_isa_changed_in(hv);
1089 else if (mro_changes == 2)
1090 mro_package_moved(NULL, stash, gv, 1);
1094 if (SvREADONLY(hv)) {
1095 hv_notallowed(k_flags, key, klen,
1096 "Attempt to delete disallowed key '%"SVf"' from"
1097 " a restricted hash");
1100 if (k_flags & HVhek_FREEKEY)
1106 S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1110 char *a = (char*) HvARRAY(hv);
1113 PERL_ARGS_ASSERT_HSPLIT;
1115 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1116 (void*)hv, (int) oldsize);*/
1119 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1120 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1126 Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1130 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1131 HvMAX(hv) = --newsize;
1132 HvARRAY(hv) = (HE**) a;
1134 if (!HvTOTALKEYS(hv)) /* skip rest if no entries */
1139 HE **oentry = aep + i;
1142 if (!entry) /* non-existent */
1145 U32 j = (HeHASH(entry) & newsize);
1147 *oentry = HeNEXT(entry);
1148 HeNEXT(entry) = aep[j];
1152 oentry = &HeNEXT(entry);
1156 } while (i++ < oldsize);
1160 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1163 XPVHV* xhv = (XPVHV*)SvANY(hv);
1164 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1168 PERL_ARGS_ASSERT_HV_KSPLIT;
1170 newsize = (I32) newmax; /* possible truncation here */
1171 if (newsize != newmax || newmax <= oldsize)
1173 while ((newsize & (1 + ~newsize)) != newsize) {
1174 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1176 if (newsize < newmax)
1178 if (newsize < newmax)
1179 return; /* overflow detection */
1181 a = (char *) HvARRAY(hv);
1183 hsplit(hv, oldsize, newsize);
1185 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1186 xhv->xhv_max = --newsize;
1187 HvARRAY(hv) = (HE **) a;
1192 Perl_newHVhv(pTHX_ HV *ohv)
1195 HV * const hv = newHV();
1198 if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
1200 hv_max = HvMAX(ohv);
1202 if (!SvMAGICAL((const SV *)ohv)) {
1203 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1205 const bool shared = !!HvSHAREKEYS(ohv);
1206 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1208 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1211 /* In each bucket... */
1212 for (i = 0; i <= hv_max; i++) {
1214 HE *oent = oents[i];
1221 /* Copy the linked list of entries. */
1222 for (; oent; oent = HeNEXT(oent)) {
1223 const U32 hash = HeHASH(oent);
1224 const char * const key = HeKEY(oent);
1225 const STRLEN len = HeKLEN(oent);
1226 const int flags = HeKFLAGS(oent);
1227 HE * const ent = new_HE();
1228 SV *const val = HeVAL(oent);
1230 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1232 = shared ? share_hek_flags(key, len, hash, flags)
1233 : save_hek_flags(key, len, hash, flags);
1244 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1248 /* Iterate over ohv, copying keys and values one at a time. */
1250 const I32 riter = HvRITER_get(ohv);
1251 HE * const eiter = HvEITER_get(ohv);
1252 STRLEN hv_fill = HvFILL(ohv);
1254 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1255 while (hv_max && hv_max + 1 >= hv_fill * 2)
1256 hv_max = hv_max / 2;
1260 while ((entry = hv_iternext_flags(ohv, 0))) {
1261 SV *val = hv_iterval(ohv,entry);
1262 SV * const keysv = HeSVKEY(entry);
1263 val = SvIMMORTAL(val) ? val : newSVsv(val);
1265 (void)hv_store_ent(hv, keysv, val, 0);
1267 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1268 HeHASH(entry), HeKFLAGS(entry));
1270 HvRITER_set(ohv, riter);
1271 HvEITER_set(ohv, eiter);
1278 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1280 A specialised version of L</newHVhv> for copying C<%^H>. I<ohv> must be
1281 a pointer to a hash (which may have C<%^H> magic, but should be generally
1282 non-magical), or C<NULL> (interpreted as an empty hash). The content
1283 of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1284 added to it. A pointer to the new hash is returned.
1290 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1292 HV * const hv = newHV();
1295 STRLEN hv_max = HvMAX(ohv);
1296 STRLEN hv_fill = HvFILL(ohv);
1298 const I32 riter = HvRITER_get(ohv);
1299 HE * const eiter = HvEITER_get(ohv);
1304 while (hv_max && hv_max + 1 >= hv_fill * 2)
1305 hv_max = hv_max / 2;
1309 while ((entry = hv_iternext_flags(ohv, 0))) {
1310 SV *const sv = newSVsv(hv_iterval(ohv,entry));
1311 SV *heksv = HeSVKEY(entry);
1312 if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1313 if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1314 (char *)heksv, HEf_SVKEY);
1315 if (heksv == HeSVKEY(entry))
1316 (void)hv_store_ent(hv, heksv, sv, 0);
1318 (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1319 HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1320 SvREFCNT_dec_NN(heksv);
1323 HvRITER_set(ohv, riter);
1324 HvEITER_set(ohv, eiter);
1326 SvREFCNT_inc_simple_void_NN(hv);
1329 hv_magic(hv, NULL, PERL_MAGIC_hints);
1333 /* like hv_free_ent, but returns the SV rather than freeing it */
1335 S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
1340 PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1343 if (HeKLEN(entry) == HEf_SVKEY) {
1344 SvREFCNT_dec(HeKEY_sv(entry));
1345 Safefree(HeKEY_hek(entry));
1347 else if (HvSHAREKEYS(hv))
1348 unshare_hek(HeKEY_hek(entry));
1350 Safefree(HeKEY_hek(entry));
1357 Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
1362 PERL_ARGS_ASSERT_HV_FREE_ENT;
1366 val = hv_free_ent_ret(hv, entry);
1372 Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
1376 PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1380 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1381 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
1382 if (HeKLEN(entry) == HEf_SVKEY) {
1383 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1385 hv_free_ent(hv, entry);
1389 =for apidoc hv_clear
1391 Frees the all the elements of a hash, leaving it empty.
1392 The XS equivalent of C<%hash = ()>. See also L</hv_undef>.
1394 If any destructors are triggered as a result, the hv itself may
1401 Perl_hv_clear(pTHX_ HV *hv)
1408 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1410 xhv = (XPVHV*)SvANY(hv);
1413 SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1414 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1415 /* restricted hash: convert all keys to placeholders */
1417 for (i = 0; i <= xhv->xhv_max; i++) {
1418 HE *entry = (HvARRAY(hv))[i];
1419 for (; entry; entry = HeNEXT(entry)) {
1420 /* not already placeholder */
1421 if (HeVAL(entry) != &PL_sv_placeholder) {
1423 if (SvREADONLY(HeVAL(entry)) && !SvIsCOW(HeVAL(entry))) {
1424 SV* const keysv = hv_iterkeysv(entry);
1425 Perl_croak_nocontext(
1426 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1429 SvREFCNT_dec_NN(HeVAL(entry));
1431 HeVAL(entry) = &PL_sv_placeholder;
1432 HvPLACEHOLDERS(hv)++;
1439 HvPLACEHOLDERS_set(hv, 0);
1442 mg_clear(MUTABLE_SV(hv));
1444 HvHASKFLAGS_off(hv);
1448 mro_isa_changed_in(hv);
1449 HvEITER_set(hv, NULL);
1455 =for apidoc hv_clear_placeholders
1457 Clears any placeholders from a hash. If a restricted hash has any of its keys
1458 marked as readonly and the key is subsequently deleted, the key is not actually
1459 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1460 it so it will be ignored by future operations such as iterating over the hash,
1461 but will still allow the hash to have a value reassigned to the key at some
1462 future point. This function clears any such placeholder keys from the hash.
1463 See Hash::Util::lock_keys() for an example of its use.
1469 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1472 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1474 PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1477 clear_placeholders(hv, items);
1481 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1486 PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1493 /* Loop down the linked list heads */
1494 HE **oentry = &(HvARRAY(hv))[i];
1497 while ((entry = *oentry)) {
1498 if (HeVAL(entry) == &PL_sv_placeholder) {
1499 *oentry = HeNEXT(entry);
1500 if (entry == HvEITER_get(hv))
1503 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1504 entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1505 HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1506 hv_free_ent(hv, entry);
1511 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1512 if (HvUSEDKEYS(hv) == 0)
1513 HvHASKFLAGS_off(hv);
1514 HvPLACEHOLDERS_set(hv, 0);
1518 oentry = &HeNEXT(entry);
1522 /* You can't get here, hence assertion should always fail. */
1523 assert (items == 0);
1528 S_hfreeentries(pTHX_ HV *hv)
1531 XPVHV * const xhv = (XPVHV*)SvANY(hv);
1534 PERL_ARGS_ASSERT_HFREEENTRIES;
1536 while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
1542 /* hfree_next_entry()
1543 * For use only by S_hfreeentries() and sv_clear().
1544 * Delete the next available HE from hv and return the associated SV.
1545 * Returns null on empty hash. Nevertheless null is not a reliable
1546 * indicator that the hash is empty, as the deleted entry may have a
1548 * indexp is a pointer to the current index into HvARRAY. The index should
1549 * initially be set to 0. hfree_next_entry() may update it. */
1552 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1554 struct xpvhv_aux *iter;
1558 STRLEN orig_index = *indexp;
1561 PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1563 if (SvOOK(hv) && ((iter = HvAUX(hv)))
1564 && ((entry = iter->xhv_eiter)) )
1566 /* the iterator may get resurrected after each
1567 * destructor call, so check each time */
1568 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1570 hv_free_ent(hv, entry);
1571 /* warning: at this point HvARRAY may have been
1572 * re-allocated, HvMAX changed etc */
1574 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1575 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1578 if (!((XPVHV*)SvANY(hv))->xhv_keys)
1581 array = HvARRAY(hv);
1583 while ( ! ((entry = array[*indexp])) ) {
1584 if ((*indexp)++ >= HvMAX(hv))
1586 assert(*indexp != orig_index);
1588 array[*indexp] = HeNEXT(entry);
1589 ((XPVHV*) SvANY(hv))->xhv_keys--;
1591 if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
1592 && HeVAL(entry) && isGV(HeVAL(entry))
1593 && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
1596 const char * const key = HePV(entry,klen);
1597 if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
1598 || (klen == 1 && key[0] == ':')) {
1600 NULL, GvHV(HeVAL(entry)),
1601 (GV *)HeVAL(entry), 0
1605 return hv_free_ent_ret(hv, entry);
1610 =for apidoc hv_undef
1612 Undefines the hash. The XS equivalent of C<undef(%hash)>.
1614 As well as freeing all the elements of the hash (like hv_clear()), this
1615 also frees any auxiliary data and storage associated with the hash.
1617 If any destructors are triggered as a result, the hv itself may
1620 See also L</hv_clear>.
1626 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1631 const bool save = !!SvREFCNT(hv);
1635 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1636 xhv = (XPVHV*)SvANY(hv);
1638 /* The name must be deleted before the call to hfreeeeentries so that
1639 CVs are anonymised properly. But the effective name must be pre-
1640 served until after that call (and only deleted afterwards if the
1641 call originated from sv_clear). For stashes with one name that is
1642 both the canonical name and the effective name, hv_name_set has to
1643 allocate an array for storing the effective name. We can skip that
1644 during global destruction, as it does not matter where the CVs point
1645 if they will be freed anyway. */
1646 /* note that the code following prior to hfreeentries is duplicated
1647 * in sv_clear(), and changes here should be done there too */
1648 if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
1649 if (PL_stashcache) {
1650 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
1651 HEKf"'\n", HvNAME_HEK(hv)));
1652 (void)hv_delete(PL_stashcache, name,
1653 HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
1657 hv_name_set(hv, NULL, 0, 0);
1661 SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1665 struct xpvhv_aux * const aux = HvAUX(hv);
1666 struct mro_meta *meta;
1668 if ((name = HvENAME_get(hv))) {
1669 if (PL_phase != PERL_PHASE_DESTRUCT)
1670 mro_isa_changed_in(hv);
1671 if (PL_stashcache) {
1672 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
1673 HEKf"'\n", HvENAME_HEK(hv)));
1675 PL_stashcache, name,
1676 HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
1682 /* If this call originated from sv_clear, then we must check for
1683 * effective names that need freeing, as well as the usual name. */
1685 if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
1686 if (name && PL_stashcache) {
1687 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
1688 HEKf"'\n", HvNAME_HEK(hv)));
1689 (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
1691 hv_name_set(hv, NULL, 0, flags);
1693 if((meta = aux->xhv_mro_meta)) {
1694 if (meta->mro_linear_all) {
1695 SvREFCNT_dec_NN(meta->mro_linear_all);
1696 /* mro_linear_current is just acting as a shortcut pointer,
1700 /* Only the current MRO is stored, so this owns the data.
1702 SvREFCNT_dec(meta->mro_linear_current);
1703 SvREFCNT_dec(meta->mro_nextmethod);
1704 SvREFCNT_dec(meta->isa);
1706 aux->xhv_mro_meta = NULL;
1708 SvREFCNT_dec(aux->xhv_super);
1709 if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
1710 SvFLAGS(hv) &= ~SVf_OOK;
1713 Safefree(HvARRAY(hv));
1714 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1717 /* if we're freeing the HV, the SvMAGIC field has been reused for
1718 * other purposes, and so there can't be any placeholder magic */
1720 HvPLACEHOLDERS_set(hv, 0);
1723 mg_clear(MUTABLE_SV(hv));
1730 Returns the number of hash buckets that happen to be in use. This function is
1731 wrapped by the macro C<HvFILL>.
1733 Previously this value was stored in the HV structure, rather than being
1734 calculated on demand.
1740 Perl_hv_fill(pTHX_ HV const *const hv)
1743 HE **ents = HvARRAY(hv);
1745 PERL_ARGS_ASSERT_HV_FILL;
1748 HE *const *const last = ents + HvMAX(hv);
1749 count = last + 1 - ents;
1754 } while (++ents <= last);
1759 static struct xpvhv_aux*
1760 S_hv_auxinit(HV *hv) {
1761 struct xpvhv_aux *iter;
1764 PERL_ARGS_ASSERT_HV_AUXINIT;
1767 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1768 + sizeof(struct xpvhv_aux), char);
1770 array = (char *) HvARRAY(hv);
1771 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1772 + sizeof(struct xpvhv_aux), char);
1774 HvARRAY(hv) = (HE**) array;
1778 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1779 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1780 iter->xhv_name_u.xhvnameu_name = 0;
1781 iter->xhv_name_count = 0;
1782 iter->xhv_backreferences = 0;
1783 iter->xhv_mro_meta = NULL;
1784 iter->xhv_super = NULL;
1789 =for apidoc hv_iterinit
1791 Prepares a starting point to traverse a hash table. Returns the number of
1792 keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>). The return value is
1793 currently only meaningful for hashes without tie magic.
1795 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1796 hash buckets that happen to be in use. If you still need that esoteric
1797 value, you can get it through the macro C<HvFILL(hv)>.
1804 Perl_hv_iterinit(pTHX_ HV *hv)
1806 PERL_ARGS_ASSERT_HV_ITERINIT;
1808 /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1811 Perl_croak(aTHX_ "Bad hash");
1814 struct xpvhv_aux * const iter = HvAUX(hv);
1815 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1816 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1818 hv_free_ent(hv, entry);
1820 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1821 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1826 /* used to be xhv->xhv_fill before 5.004_65 */
1827 return HvTOTALKEYS(hv);
1831 Perl_hv_riter_p(pTHX_ HV *hv) {
1832 struct xpvhv_aux *iter;
1834 PERL_ARGS_ASSERT_HV_RITER_P;
1837 Perl_croak(aTHX_ "Bad hash");
1839 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1840 return &(iter->xhv_riter);
1844 Perl_hv_eiter_p(pTHX_ HV *hv) {
1845 struct xpvhv_aux *iter;
1847 PERL_ARGS_ASSERT_HV_EITER_P;
1850 Perl_croak(aTHX_ "Bad hash");
1852 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1853 return &(iter->xhv_eiter);
1857 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1858 struct xpvhv_aux *iter;
1860 PERL_ARGS_ASSERT_HV_RITER_SET;
1863 Perl_croak(aTHX_ "Bad hash");
1871 iter = hv_auxinit(hv);
1873 iter->xhv_riter = riter;
1877 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1878 struct xpvhv_aux *iter;
1880 PERL_ARGS_ASSERT_HV_EITER_SET;
1883 Perl_croak(aTHX_ "Bad hash");
1888 /* 0 is the default so don't go malloc()ing a new structure just to
1893 iter = hv_auxinit(hv);
1895 iter->xhv_eiter = eiter;
1899 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
1902 struct xpvhv_aux *iter;
1906 PERL_ARGS_ASSERT_HV_NAME_SET;
1909 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
1913 if (iter->xhv_name_u.xhvnameu_name) {
1914 if(iter->xhv_name_count) {
1915 if(flags & HV_NAME_SETALL) {
1916 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
1917 HEK **hekp = name + (
1918 iter->xhv_name_count < 0
1919 ? -iter->xhv_name_count
1920 : iter->xhv_name_count
1922 while(hekp-- > name+1)
1923 unshare_hek_or_pvn(*hekp, 0, 0, 0);
1924 /* The first elem may be null. */
1925 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
1927 spot = &iter->xhv_name_u.xhvnameu_name;
1928 iter->xhv_name_count = 0;
1931 if(iter->xhv_name_count > 0) {
1932 /* shift some things over */
1934 iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
1936 spot = iter->xhv_name_u.xhvnameu_names;
1937 spot[iter->xhv_name_count] = spot[1];
1939 iter->xhv_name_count = -(iter->xhv_name_count + 1);
1941 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
1942 unshare_hek_or_pvn(*spot, 0, 0, 0);
1946 else if (flags & HV_NAME_SETALL) {
1947 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
1948 spot = &iter->xhv_name_u.xhvnameu_name;
1951 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
1952 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
1953 iter->xhv_name_count = -2;
1954 spot = iter->xhv_name_u.xhvnameu_names;
1955 spot[1] = existing_name;
1958 else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
1963 iter = hv_auxinit(hv);
1964 spot = &iter->xhv_name_u.xhvnameu_name;
1966 PERL_HASH(hash, name, len);
1967 *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
1971 This is basically sv_eq_flags() in sv.c, but we avoid the magic
1976 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
1977 if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
1978 if (flags & SVf_UTF8)
1979 return (bytes_cmp_utf8(
1980 (const U8*)HEK_KEY(hek), HEK_LEN(hek),
1981 (const U8*)pv, pvlen) == 0);
1983 return (bytes_cmp_utf8(
1984 (const U8*)pv, pvlen,
1985 (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
1988 return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
1989 || memEQ(HEK_KEY(hek), pv, pvlen));
1993 =for apidoc hv_ename_add
1995 Adds a name to a stash's internal list of effective names. See
1998 This is called when a stash is assigned to a new location in the symbol
2005 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2008 struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2011 PERL_ARGS_ASSERT_HV_ENAME_ADD;
2014 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2016 PERL_HASH(hash, name, len);
2018 if (aux->xhv_name_count) {
2019 HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
2020 I32 count = aux->xhv_name_count;
2021 HEK **hekp = xhv_name + (count < 0 ? -count : count);
2022 while (hekp-- > xhv_name)
2024 (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
2025 ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2026 : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2028 if (hekp == xhv_name && count < 0)
2029 aux->xhv_name_count = -count;
2032 if (count < 0) aux->xhv_name_count--, count = -count;
2033 else aux->xhv_name_count++;
2034 Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2035 (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2038 HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2041 (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2042 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2043 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2046 Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2047 aux->xhv_name_count = existing_name ? 2 : -2;
2048 *aux->xhv_name_u.xhvnameu_names = existing_name;
2049 (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2054 =for apidoc hv_ename_delete
2056 Removes a name from a stash's internal list of effective names. If this is
2057 the name returned by C<HvENAME>, then another name in the list will take
2058 its place (C<HvENAME> will use it).
2060 This is called when a stash is deleted from the symbol table.
2066 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2069 struct xpvhv_aux *aux;
2071 PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2074 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2076 if (!SvOOK(hv)) return;
2079 if (!aux->xhv_name_u.xhvnameu_name) return;
2081 if (aux->xhv_name_count) {
2082 HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2083 I32 const count = aux->xhv_name_count;
2084 HEK **victim = namep + (count < 0 ? -count : count);
2085 while (victim-- > namep + 1)
2087 (HEK_UTF8(*victim) || (flags & SVf_UTF8))
2088 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2089 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2091 unshare_hek_or_pvn(*victim, 0, 0, 0);
2092 if (count < 0) ++aux->xhv_name_count;
2093 else --aux->xhv_name_count;
2095 (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2097 ) { /* if there are none left */
2099 aux->xhv_name_u.xhvnameu_names = NULL;
2100 aux->xhv_name_count = 0;
2103 /* Move the last one back to fill the empty slot. It
2104 does not matter what order they are in. */
2105 *victim = *(namep + (count < 0 ? -count : count) - 1);
2110 count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
2111 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2112 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2114 aux->xhv_name_count = -count;
2118 (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
2119 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2120 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2121 memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2123 HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2124 Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2125 *aux->xhv_name_u.xhvnameu_names = namehek;
2126 aux->xhv_name_count = -1;
2131 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2132 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2134 PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2135 PERL_UNUSED_CONTEXT;
2137 return &(iter->xhv_backreferences);
2141 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2144 PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2149 av = HvAUX(hv)->xhv_backreferences;
2152 HvAUX(hv)->xhv_backreferences = 0;
2153 Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2154 if (SvTYPE(av) == SVt_PVAV)
2155 SvREFCNT_dec_NN(av);
2160 hv_iternext is implemented as a macro in hv.h
2162 =for apidoc hv_iternext
2164 Returns entries from a hash iterator. See C<hv_iterinit>.
2166 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2167 iterator currently points to, without losing your place or invalidating your
2168 iterator. Note that in this case the current entry is deleted from the hash
2169 with your iterator holding the last reference to it. Your iterator is flagged
2170 to free the entry on the next call to C<hv_iternext>, so you must not discard
2171 your iterator immediately else the entry will leak - call C<hv_iternext> to
2172 trigger the resource deallocation.
2174 =for apidoc hv_iternext_flags
2176 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
2177 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2178 set the placeholders keys (for restricted hashes) will be returned in addition
2179 to normal keys. By default placeholders are automatically skipped over.
2180 Currently a placeholder is implemented with a value that is
2181 C<&PL_sv_placeholder>. Note that the implementation of placeholders and
2182 restricted hashes may change, and the implementation currently is
2183 insufficiently abstracted for any change to be tidy.
2189 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2196 struct xpvhv_aux *iter;
2198 PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2201 Perl_croak(aTHX_ "Bad hash");
2203 xhv = (XPVHV*)SvANY(hv);
2206 /* Too many things (well, pp_each at least) merrily assume that you can
2207 call hv_iternext without calling hv_iterinit, so we'll have to deal
2213 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2214 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2215 if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2216 SV * const key = sv_newmortal();
2218 sv_setsv(key, HeSVKEY_force(entry));
2219 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2220 HeSVKEY_set(entry, NULL);
2226 /* one HE per MAGICAL hash */
2227 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2228 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2230 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2232 HeKEY_hek(entry) = hek;
2233 HeKLEN(entry) = HEf_SVKEY;
2235 magic_nextpack(MUTABLE_SV(hv),mg,key);
2237 /* force key to stay around until next time */
2238 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2239 return entry; /* beware, hent_val is not set */
2241 SvREFCNT_dec(HeVAL(entry));
2242 Safefree(HeKEY_hek(entry));
2244 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2249 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
2250 if (!entry && SvRMAGICAL((const SV *)hv)
2251 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2254 /* The prime_env_iter() on VMS just loaded up new hash values
2255 * so the iteration count needs to be reset back to the beginning
2259 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2264 /* hv_iterinit now ensures this. */
2265 assert (HvARRAY(hv));
2267 /* At start of hash, entry is NULL. */
2270 entry = HeNEXT(entry);
2271 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2273 * Skip past any placeholders -- don't want to include them in
2276 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2277 entry = HeNEXT(entry);
2282 /* Skip the entire loop if the hash is empty. */
2283 if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2284 ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2286 /* OK. Come to the end of the current list. Grab the next one. */
2288 iter->xhv_riter++; /* HvRITER(hv)++ */
2289 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2290 /* There is no next one. End of the hash. */
2291 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2294 entry = (HvARRAY(hv))[iter->xhv_riter];
2296 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2297 /* If we have an entry, but it's a placeholder, don't count it.
2299 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2300 entry = HeNEXT(entry);
2302 /* Will loop again if this linked list starts NULL
2303 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2304 or if we run through it and find only placeholders. */
2307 else iter->xhv_riter = -1;
2309 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2311 hv_free_ent(hv, oldentry);
2314 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2319 =for apidoc hv_iterkey
2321 Returns the key from the current position of the hash iterator. See
2328 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2330 PERL_ARGS_ASSERT_HV_ITERKEY;
2332 if (HeKLEN(entry) == HEf_SVKEY) {
2334 char * const p = SvPV(HeKEY_sv(entry), len);
2339 *retlen = HeKLEN(entry);
2340 return HeKEY(entry);
2344 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2346 =for apidoc hv_iterkeysv
2348 Returns the key as an C<SV*> from the current position of the hash
2349 iterator. The return value will always be a mortal copy of the key. Also
2356 Perl_hv_iterkeysv(pTHX_ HE *entry)
2358 PERL_ARGS_ASSERT_HV_ITERKEYSV;
2360 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2364 =for apidoc hv_iterval
2366 Returns the value from the current position of the hash iterator. See
2373 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2375 PERL_ARGS_ASSERT_HV_ITERVAL;
2377 if (SvRMAGICAL(hv)) {
2378 if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2379 SV* const sv = sv_newmortal();
2380 if (HeKLEN(entry) == HEf_SVKEY)
2381 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2383 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2387 return HeVAL(entry);
2391 =for apidoc hv_iternextsv
2393 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2400 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2402 HE * const he = hv_iternext_flags(hv, 0);
2404 PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2408 *key = hv_iterkey(he, retlen);
2409 return hv_iterval(hv, he);
2416 =for apidoc hv_magic
2418 Adds magic to a hash. See C<sv_magic>.
2423 /* possibly free a shared string if no one has access to it
2424 * len and hash must both be valid for str.
2427 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2429 unshare_hek_or_pvn (NULL, str, len, hash);
2434 Perl_unshare_hek(pTHX_ HEK *hek)
2437 unshare_hek_or_pvn(hek, NULL, 0, 0);
2440 /* possibly free a shared string if no one has access to it
2441 hek if non-NULL takes priority over the other 3, else str, len and hash
2442 are used. If so, len and hash must both be valid for str.
2445 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2451 bool is_utf8 = FALSE;
2453 const char * const save = str;
2454 struct shared_he *he = NULL;
2457 /* Find the shared he which is just before us in memory. */
2458 he = (struct shared_he *)(((char *)hek)
2459 - STRUCT_OFFSET(struct shared_he,
2462 /* Assert that the caller passed us a genuine (or at least consistent)
2464 assert (he->shared_he_he.hent_hek == hek);
2466 if (he->shared_he_he.he_valu.hent_refcount - 1) {
2467 --he->shared_he_he.he_valu.hent_refcount;
2471 hash = HEK_HASH(hek);
2472 } else if (len < 0) {
2473 STRLEN tmplen = -len;
2475 /* See the note in hv_fetch(). --jhi */
2476 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2479 k_flags = HVhek_UTF8;
2481 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2484 /* what follows was the moral equivalent of:
2485 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2487 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2489 xhv = (XPVHV*)SvANY(PL_strtab);
2490 /* assert(xhv_array != 0) */
2491 oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2493 const HE *const he_he = &(he->shared_he_he);
2494 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2499 const int flags_masked = k_flags & HVhek_MASK;
2500 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2501 if (HeHASH(entry) != hash) /* strings can't be equal */
2503 if (HeKLEN(entry) != len)
2505 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2507 if (HeKFLAGS(entry) != flags_masked)
2514 if (--entry->he_valu.hent_refcount == 0) {
2515 *oentry = HeNEXT(entry);
2517 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2522 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2523 "Attempt to free nonexistent shared string '%s'%s"
2525 hek ? HEK_KEY(hek) : str,
2526 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2527 if (k_flags & HVhek_FREEKEY)
2531 /* get a (constant) string ptr from the global string table
2532 * string will get added if it is not already there.
2533 * len and hash must both be valid for str.
2536 Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
2538 bool is_utf8 = FALSE;
2540 const char * const save = str;
2542 PERL_ARGS_ASSERT_SHARE_HEK;
2545 STRLEN tmplen = -len;
2547 /* See the note in hv_fetch(). --jhi */
2548 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2550 /* If we were able to downgrade here, then than means that we were passed
2551 in a key which only had chars 0-255, but was utf8 encoded. */
2554 /* If we found we were able to downgrade the string to bytes, then
2555 we should flag that it needs upgrading on keys or each. Also flag
2556 that we need share_hek_flags to free the string. */
2559 PERL_HASH(hash, str, len);
2560 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2564 return share_hek_flags (str, len, hash, flags);
2568 S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
2572 const int flags_masked = flags & HVhek_MASK;
2573 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2574 XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2576 PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2578 /* what follows is the moral equivalent of:
2580 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2581 hv_store(PL_strtab, str, len, NULL, hash);
2583 Can't rehash the shared string table, so not sure if it's worth
2584 counting the number of entries in the linked list
2587 /* assert(xhv_array != 0) */
2588 entry = (HvARRAY(PL_strtab))[hindex];
2589 for (;entry; entry = HeNEXT(entry)) {
2590 if (HeHASH(entry) != hash) /* strings can't be equal */
2592 if (HeKLEN(entry) != len)
2594 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2596 if (HeKFLAGS(entry) != flags_masked)
2602 /* What used to be head of the list.
2603 If this is NULL, then we're the first entry for this slot, which
2604 means we need to increate fill. */
2605 struct shared_he *new_entry;
2608 HE **const head = &HvARRAY(PL_strtab)[hindex];
2609 HE *const next = *head;
2611 /* We don't actually store a HE from the arena and a regular HEK.
2612 Instead we allocate one chunk of memory big enough for both,
2613 and put the HEK straight after the HE. This way we can find the
2614 HE directly from the HEK.
2617 Newx(k, STRUCT_OFFSET(struct shared_he,
2618 shared_he_hek.hek_key[0]) + len + 2, char);
2619 new_entry = (struct shared_he *)k;
2620 entry = &(new_entry->shared_he_he);
2621 hek = &(new_entry->shared_he_hek);
2623 Copy(str, HEK_KEY(hek), len, char);
2624 HEK_KEY(hek)[len] = 0;
2626 HEK_HASH(hek) = hash;
2627 HEK_FLAGS(hek) = (unsigned char)flags_masked;
2629 /* Still "point" to the HEK, so that other code need not know what
2631 HeKEY_hek(entry) = hek;
2632 entry->he_valu.hent_refcount = 0;
2633 HeNEXT(entry) = next;
2636 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2637 if (!next) { /* initial entry? */
2638 } else if ( DO_HSPLIT(xhv) ) {
2639 const STRLEN oldsize = xhv->xhv_max + 1;
2640 hsplit(PL_strtab, oldsize, oldsize * 2);
2644 ++entry->he_valu.hent_refcount;
2646 if (flags & HVhek_FREEKEY)
2649 return HeKEY_hek(entry);
2653 Perl_hv_placeholders_p(pTHX_ HV *hv)
2656 MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2658 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2661 mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2664 Perl_die(aTHX_ "panic: hv_placeholders_p");
2667 return &(mg->mg_len);
2672 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2675 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2677 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2679 return mg ? mg->mg_len : 0;
2683 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2686 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2688 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2693 if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2694 Perl_die(aTHX_ "panic: hv_placeholders_set");
2696 /* else we don't need to add magic to record 0 placeholders. */
2700 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2705 PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2707 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2712 value = &PL_sv_placeholder;
2715 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2718 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2721 case HVrhek_PV_UTF8:
2722 /* Create a string SV that directly points to the bytes in our
2724 value = newSV_type(SVt_PV);
2725 SvPV_set(value, (char *) he->refcounted_he_data + 1);
2726 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2727 /* This stops anything trying to free it */
2728 SvLEN_set(value, 0);
2730 SvREADONLY_on(value);
2731 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2735 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2736 (UV)he->refcounted_he_data[0]);
2742 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
2744 Generates and returns a C<HV *> representing the content of a
2745 C<refcounted_he> chain.
2746 I<flags> is currently unused and must be zero.
2751 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
2755 U32 placeholders, max;
2758 Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
2761 /* We could chase the chain once to get an idea of the number of keys,
2762 and call ksplit. But for now we'll make a potentially inefficient
2763 hash with only 8 entries in its array. */
2768 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2769 HvARRAY(hv) = (HE**)array;
2775 U32 hash = chain->refcounted_he_hash;
2777 U32 hash = HEK_HASH(chain->refcounted_he_hek);
2779 HE **oentry = &((HvARRAY(hv))[hash & max]);
2780 HE *entry = *oentry;
2783 for (; entry; entry = HeNEXT(entry)) {
2784 if (HeHASH(entry) == hash) {
2785 /* We might have a duplicate key here. If so, entry is older
2786 than the key we've already put in the hash, so if they are
2787 the same, skip adding entry. */
2789 const STRLEN klen = HeKLEN(entry);
2790 const char *const key = HeKEY(entry);
2791 if (klen == chain->refcounted_he_keylen
2792 && (!!HeKUTF8(entry)
2793 == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2794 && memEQ(key, REF_HE_KEY(chain), klen))
2797 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2799 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2800 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2801 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2812 = share_hek_flags(REF_HE_KEY(chain),
2813 chain->refcounted_he_keylen,
2814 chain->refcounted_he_hash,
2815 (chain->refcounted_he_data[0]
2816 & (HVhek_UTF8|HVhek_WASUTF8)));
2818 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2820 value = refcounted_he_value(chain);
2821 if (value == &PL_sv_placeholder)
2823 HeVAL(entry) = value;
2825 /* Link it into the chain. */
2826 HeNEXT(entry) = *oentry;
2832 chain = chain->refcounted_he_next;
2836 clear_placeholders(hv, placeholders);
2837 HvTOTALKEYS(hv) -= placeholders;
2840 /* We could check in the loop to see if we encounter any keys with key
2841 flags, but it's probably not worth it, as this per-hash flag is only
2842 really meant as an optimisation for things like Storable. */
2844 DEBUG_A(Perl_hv_assert(aTHX_ hv));
2850 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
2852 Search along a C<refcounted_he> chain for an entry with the key specified
2853 by I<keypv> and I<keylen>. If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
2854 bit set, the key octets are interpreted as UTF-8, otherwise they
2855 are interpreted as Latin-1. I<hash> is a precomputed hash of the key
2856 string, or zero if it has not been precomputed. Returns a mortal scalar
2857 representing the value associated with the key, or C<&PL_sv_placeholder>
2858 if there is no value associated with the key.
2864 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
2865 const char *keypv, STRLEN keylen, U32 hash, U32 flags)
2869 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
2871 if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
2872 Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
2875 return &PL_sv_placeholder;
2876 if (flags & REFCOUNTED_HE_KEY_UTF8) {
2877 /* For searching purposes, canonicalise to Latin-1 where possible. */
2878 const char *keyend = keypv + keylen, *p;
2879 STRLEN nonascii_count = 0;
2880 for (p = keypv; p != keyend; p++) {
2883 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
2884 (((U8)*p) & 0xc0) == 0x80))
2885 goto canonicalised_key;
2889 if (nonascii_count) {
2891 const char *p = keypv, *keyend = keypv + keylen;
2892 keylen -= nonascii_count;
2893 Newx(q, keylen, char);
2896 for (; p != keyend; p++, q++) {
2899 ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
2902 flags &= ~REFCOUNTED_HE_KEY_UTF8;
2903 canonicalised_key: ;
2905 utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
2907 PERL_HASH(hash, keypv, keylen);
2909 for (; chain; chain = chain->refcounted_he_next) {
2912 hash == chain->refcounted_he_hash &&
2913 keylen == chain->refcounted_he_keylen &&
2914 memEQ(REF_HE_KEY(chain), keypv, keylen) &&
2915 utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
2917 hash == HEK_HASH(chain->refcounted_he_hek) &&
2918 keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
2919 memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
2920 utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
2923 if (flags & REFCOUNTED_HE_EXISTS)
2924 return (chain->refcounted_he_data[0] & HVrhek_typemask)
2926 ? NULL : &PL_sv_yes;
2927 return sv_2mortal(refcounted_he_value(chain));
2930 return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
2934 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
2936 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
2937 instead of a string/length pair.
2943 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
2944 const char *key, U32 hash, U32 flags)
2946 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
2947 return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
2951 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
2953 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
2960 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
2961 SV *key, U32 hash, U32 flags)
2965 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
2966 if (flags & REFCOUNTED_HE_KEY_UTF8)
2967 Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
2969 keypv = SvPV_const(key, keylen);
2971 flags |= REFCOUNTED_HE_KEY_UTF8;
2972 if (!hash && SvIsCOW_shared_hash(key))
2973 hash = SvSHARED_HASH(key);
2974 return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
2978 =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
2980 Creates a new C<refcounted_he>. This consists of a single key/value
2981 pair and a reference to an existing C<refcounted_he> chain (which may
2982 be empty), and thus forms a longer chain. When using the longer chain,
2983 the new key/value pair takes precedence over any entry for the same key
2984 further along the chain.
2986 The new key is specified by I<keypv> and I<keylen>. If I<flags> has
2987 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
2988 as UTF-8, otherwise they are interpreted as Latin-1. I<hash> is
2989 a precomputed hash of the key string, or zero if it has not been
2992 I<value> is the scalar value to store for this key. I<value> is copied
2993 by this function, which thus does not take ownership of any reference
2994 to it, and later changes to the scalar will not be reflected in the
2995 value visible in the C<refcounted_he>. Complex types of scalar will not
2996 be stored with referential integrity, but will be coerced to strings.
2997 I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
2998 value is to be associated with the key; this, as with any non-null value,
2999 takes precedence over the existence of a value for the key further along
3002 I<parent> points to the rest of the C<refcounted_he> chain to be
3003 attached to the new C<refcounted_he>. This function takes ownership
3004 of one reference to I<parent>, and returns one reference to the new
3010 struct refcounted_he *
3011 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3012 const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3015 STRLEN value_len = 0;
3016 const char *value_p = NULL;
3020 STRLEN key_offset = 1;
3021 struct refcounted_he *he;
3022 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3024 if (!value || value == &PL_sv_placeholder) {
3025 value_type = HVrhek_delete;
3026 } else if (SvPOK(value)) {
3027 value_type = HVrhek_PV;
3028 } else if (SvIOK(value)) {
3029 value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3030 } else if (!SvOK(value)) {
3031 value_type = HVrhek_undef;
3033 value_type = HVrhek_PV;
3035 is_pv = value_type == HVrhek_PV;
3037 /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3038 the value is overloaded, and doesn't yet have the UTF-8flag set. */
3039 value_p = SvPV_const(value, value_len);
3041 value_type = HVrhek_PV_UTF8;
3042 key_offset = value_len + 2;
3044 hekflags = value_type;
3046 if (flags & REFCOUNTED_HE_KEY_UTF8) {
3047 /* Canonicalise to Latin-1 where possible. */
3048 const char *keyend = keypv + keylen, *p;
3049 STRLEN nonascii_count = 0;
3050 for (p = keypv; p != keyend; p++) {
3053 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3054 (((U8)*p) & 0xc0) == 0x80))
3055 goto canonicalised_key;
3059 if (nonascii_count) {
3061 const char *p = keypv, *keyend = keypv + keylen;
3062 keylen -= nonascii_count;
3063 Newx(q, keylen, char);
3066 for (; p != keyend; p++, q++) {
3069 ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3072 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3073 canonicalised_key: ;
3075 if (flags & REFCOUNTED_HE_KEY_UTF8)
3076 hekflags |= HVhek_UTF8;
3078 PERL_HASH(hash, keypv, keylen);
3081 he = (struct refcounted_he*)
3082 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3086 he = (struct refcounted_he*)
3087 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3091 he->refcounted_he_next = parent;
3094 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3095 he->refcounted_he_val.refcounted_he_u_len = value_len;
3096 } else if (value_type == HVrhek_IV) {
3097 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3098 } else if (value_type == HVrhek_UV) {
3099 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3103 he->refcounted_he_hash = hash;
3104 he->refcounted_he_keylen = keylen;
3105 Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3107 he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3110 he->refcounted_he_data[0] = hekflags;
3111 he->refcounted_he_refcnt = 1;
3117 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3119 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3120 of a string/length pair.
3125 struct refcounted_he *
3126 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3127 const char *key, U32 hash, SV *value, U32 flags)
3129 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3130 return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3134 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3136 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3142 struct refcounted_he *
3143 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3144 SV *key, U32 hash, SV *value, U32 flags)
3148 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3149 if (flags & REFCOUNTED_HE_KEY_UTF8)
3150 Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3152 keypv = SvPV_const(key, keylen);
3154 flags |= REFCOUNTED_HE_KEY_UTF8;
3155 if (!hash && SvIsCOW_shared_hash(key))
3156 hash = SvSHARED_HASH(key);
3157 return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3161 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3163 Decrements the reference count of a C<refcounted_he> by one. If the
3164 reference count reaches zero the structure's memory is freed, which
3165 (recursively) causes a reduction of its parent C<refcounted_he>'s
3166 reference count. It is safe to pass a null pointer to this function:
3167 no action occurs in this case.
3173 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3175 PERL_UNUSED_CONTEXT;
3178 struct refcounted_he *copy;
3182 new_count = --he->refcounted_he_refcnt;
3183 HINTS_REFCNT_UNLOCK;
3189 #ifndef USE_ITHREADS
3190 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3193 he = he->refcounted_he_next;
3194 PerlMemShared_free(copy);
3199 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3201 Increment the reference count of a C<refcounted_he>. The pointer to the
3202 C<refcounted_he> is also returned. It is safe to pass a null pointer
3203 to this function: no action occurs and a null pointer is returned.
3208 struct refcounted_he *
3209 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3214 he->refcounted_he_refcnt++;
3215 HINTS_REFCNT_UNLOCK;
3221 =for apidoc cop_fetch_label
3223 Returns the label attached to a cop.
3224 The flags pointer may be set to C<SVf_UTF8> or 0.
3229 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3232 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3233 struct refcounted_he *const chain = cop->cop_hints_hash;
3235 PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3240 if (chain->refcounted_he_keylen != 1)
3242 if (*REF_HE_KEY(chain) != ':')
3245 if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3247 if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3250 /* Stop anyone trying to really mess us up by adding their own value for
3252 if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3253 && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3257 *len = chain->refcounted_he_val.refcounted_he_u_len;
3259 *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3260 == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3262 return chain->refcounted_he_data + 1;
3266 =for apidoc cop_store_label
3268 Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
3275 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3279 PERL_ARGS_ASSERT_COP_STORE_LABEL;
3281 if (flags & ~(SVf_UTF8))
3282 Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3284 labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3285 if (flags & SVf_UTF8)
3288 = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3292 =for apidoc hv_assert
3294 Check that a hash is in an internally consistent state.
3302 Perl_hv_assert(pTHX_ HV *hv)
3307 int placeholders = 0;
3310 const I32 riter = HvRITER_get(hv);
3311 HE *eiter = HvEITER_get(hv);
3313 PERL_ARGS_ASSERT_HV_ASSERT;
3315 (void)hv_iterinit(hv);
3317 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3318 /* sanity check the values */
3319 if (HeVAL(entry) == &PL_sv_placeholder)
3323 /* sanity check the keys */
3324 if (HeSVKEY(entry)) {
3325 NOOP; /* Don't know what to check on SV keys. */
3326 } else if (HeKUTF8(entry)) {
3328 if (HeKWASUTF8(entry)) {
3329 PerlIO_printf(Perl_debug_log,
3330 "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3331 (int) HeKLEN(entry), HeKEY(entry));
3334 } else if (HeKWASUTF8(entry))
3337 if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3338 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3339 const int nhashkeys = HvUSEDKEYS(hv);
3340 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3342 if (nhashkeys != real) {
3343 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3346 if (nhashplaceholders != placeholders) {
3347 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3351 if (withflags && ! HvHASKFLAGS(hv)) {
3352 PerlIO_printf(Perl_debug_log,
3353 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3358 sv_dump(MUTABLE_SV(hv));
3360 HvRITER_set(hv, riter); /* Restore hash iterator state */
3361 HvEITER_set(hv, eiter);
3368 * c-indentation-style: bsd
3370 * indent-tabs-mode: nil
3373 * ex: set ts=8 sts=4 sw=4 et: