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"]
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()
42 /* MAX_BUCKET_MAX is the maximum max bucket index, at which point we stop growing the
45 #define MAX_BUCKET_MAX ((1<<26)-1)
46 #define DO_HSPLIT(xhv) ( ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1)) > (xhv)->xhv_max ) && \
47 ((xhv)->xhv_max < MAX_BUCKET_MAX) )
49 static const char S_strtab_error[]
50 = "Cannot modify shared string table in hv_%s";
52 #define DEBUG_HASH_RAND_BITS (DEBUG_h_TEST)
54 /* Algorithm "xor" from p. 4 of Marsaglia, "Xorshift RNGs"
55 * See also https://en.wikipedia.org/wiki/Xorshift
59 #define XORSHIFT_RAND_BITS(x) PERL_XORSHIFT64_A(x)
62 #define XORSHIFT_RAND_BITS(x) PERL_XORSHIFT32_A(x)
65 #define UPDATE_HASH_RAND_BITS_KEY(key,klen) \
67 XORSHIFT_RAND_BITS(PL_hash_rand_bits); \
68 if (DEBUG_HASH_RAND_BITS) { \
69 PerlIO_printf( Perl_debug_log, \
70 "PL_hash_rand_bits=%016" UVxf" @ %s:%-4d", \
71 (UV)PL_hash_rand_bits, __FILE__, __LINE__ \
73 if (DEBUG_v_TEST && key) { \
74 PerlIO_printf( Perl_debug_log, " key:'%.*s' %" UVuf"\n", \
76 key ? key : "", /* silence warning */ \
80 PerlIO_printf( Perl_debug_log, "\n"); \
85 #define MAYBE_UPDATE_HASH_RAND_BITS_KEY(key,klen) \
87 if (PL_HASH_RAND_BITS_ENABLED) \
88 UPDATE_HASH_RAND_BITS_KEY(key,klen); \
92 #define UPDATE_HASH_RAND_BITS() \
93 UPDATE_HASH_RAND_BITS_KEY(NULL,0)
95 #define MAYBE_UPDATE_HASH_RAND_BITS() \
96 MAYBE_UPDATE_HASH_RAND_BITS_KEY(NULL,0)
98 /* HeKFLAGS(entry) is a single U8, so only provides 8 flags bits.
99 We currently use 3. All 3 we have behave differently, so if we find a use for
100 more flags it's hard to predict which they group with.
102 Hash keys are stored as flat octet sequences, not SVs. Hence we need a flag
103 bit to say whether those octet sequences represent ISO-8859-1 or UTF-8 -
104 HVhek_UTF8. The value of this flag bit matters for (regular) hash key
107 To speed up comparisons, keys are normalised to octets. But we (also)
108 preserve whether the key was supplied, so we need another flag bit to say
109 whether to reverse the normalisation when iterating the keys (converting them
110 back to SVs) - HVhek_WASUTF8. The value of this flag bit must be ignored for
111 (regular) hash key lookups.
113 But for the shared string table (the private "hash" that manages shared hash
114 keys and their reference counts), we need to be able to store both variants
115 (HVhek_WASUTF8 set and clear), so the code performing lookups in this hash
116 must be different and consider both keys.
118 However, regular hashes (now) can have a mix of shared and unshared keys.
119 (This avoids the need to reallocate all the keys into unshared storage at
120 the point where hash passes the "large" hash threshold, and no longer uses
121 the shared string table - existing keys remain shared, to avoid makework.)
123 Meaning that HVhek_NOTSHARED *may* be set in regular hashes (but should be
124 ignored for hash lookups) but must always be clear in the keys in the shared
125 string table (because the pointers to these keys are directly copied into
126 regular hashes - this is how shared keys work.)
128 Hence all 3 are different, and it's hard to predict the best way to future
129 proof what is needed next.
131 We also have HVhek_ENABLEHVKFLAGS, which is used as a mask within the code
132 below to determine whether to set HvHASKFLAGS() true on the hash as a whole.
133 This is a public "optimisation" flag provided to serealisers, to indicate
134 (up front) that a hash contains non-8-bit keys, if they want to use different
135 storage formats for hashes where all keys are simple octet sequences
136 (avoiding needing to store an extra byte per hash key), and they need to know
137 that this holds *before* iterating the hash keys. Only Storable seems to use
138 this. (For this use case, HVhek_NOTSHARED doesn't matter)
140 For now, we assume that any future flag bits will need to be distinguished
141 in the shared string table, hence we create this mask for the shared string
142 table code. It happens to be the same as HVhek_ENABLEHVKFLAGS, but that might
143 change if we add a flag bit that matters to the shared string table but not
144 to Storable (or similar). */
146 #define HVhek_STORAGE_MASK (0xFF & ~HVhek_NOTSHARED)
150 #define new_HE() (HE*)safemalloc(sizeof(HE))
151 #define del_HE(p) safefree((char*)p)
159 void ** const root = &PL_body_roots[HE_ARENA_ROOT_IX];
162 Perl_more_bodies(aTHX_ HE_ARENA_ROOT_IX, sizeof(HE), PERL_ARENA_SIZE);
169 #define new_HE() new_he()
172 HeNEXT(p) = (HE*)(PL_body_roots[HE_ARENA_ROOT_IX]); \
173 PL_body_roots[HE_ARENA_ROOT_IX] = p; \
181 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
186 PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
188 Newx(k, HEK_BASESIZE + len + 2, char);
190 Copy(str, HEK_KEY(hek), len, char);
191 HEK_KEY(hek)[len] = 0;
193 HEK_HASH(hek) = hash;
194 HEK_FLAGS(hek) = HVhek_NOTSHARED | (flags & HVhek_STORAGE_MASK);
196 if (flags & HVhek_FREEKEY)
201 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
205 Perl_free_tied_hv_pool(pTHX)
207 HE *he = PL_hv_fetch_ent_mh;
210 Safefree(HeKEY_hek(he));
214 PL_hv_fetch_ent_mh = NULL;
217 #if defined(USE_ITHREADS)
219 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
223 PERL_ARGS_ASSERT_HEK_DUP;
224 PERL_UNUSED_ARG(param);
229 shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
231 /* We already shared this hash key. */
232 (void)share_hek_hek(shared);
236 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
237 HEK_HASH(source), HEK_FLAGS(source));
238 ptr_table_store(PL_ptr_table, source, shared);
244 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
248 PERL_ARGS_ASSERT_HE_DUP;
250 /* All the *_dup functions are deemed to be API, despite most being deeply
251 tied to the internals. Hence we can't simply remove the parameter
252 "shared" from this function. */
253 /* sv_dup and sv_dup_inc seem to be the only two that are used by XS code.
254 Probably the others should be dropped from the API. See #19409 */
255 PERL_UNUSED_ARG(shared);
259 /* look for it in the table first */
260 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
264 /* create anew and remember what it is */
266 ptr_table_store(PL_ptr_table, e, ret);
268 if (HeKLEN(e) == HEf_SVKEY) {
270 Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
271 HeKEY_hek(ret) = (HEK*)k;
272 HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param);
274 else if (!(HeKFLAGS(e) & HVhek_NOTSHARED)) {
275 /* This is hek_dup inlined, which seems to be important for speed
277 HEK * const source = HeKEY_hek(e);
278 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
281 /* We already shared this hash key. */
282 (void)share_hek_hek(shared);
286 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
287 HEK_HASH(source), HEK_FLAGS(source));
288 ptr_table_store(PL_ptr_table, source, shared);
290 HeKEY_hek(ret) = shared;
293 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
295 HeVAL(ret) = sv_dup_inc(HeVAL(e), param);
297 HeNEXT(ret) = he_dup(HeNEXT(e), FALSE, param);
300 #endif /* USE_ITHREADS */
303 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
306 /* Straight to SVt_PVN here, as needed by sv_setpvn_fresh and
307 * sv_usepvn would otherwise call it */
308 SV * const sv = newSV_type_mortal(SVt_PV);
310 PERL_ARGS_ASSERT_HV_NOTALLOWED;
312 if (!(flags & HVhek_FREEKEY)) {
313 sv_setpvn_fresh(sv, key, klen);
316 /* Need to free saved eventually assign to mortal SV */
317 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
318 sv_usepvn(sv, (char *) key, klen);
320 if (flags & HVhek_UTF8) {
323 Perl_croak(aTHX_ msg, SVfARG(sv));
326 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
331 =for apidoc_item hv_stores
333 These each store SV C<val> with the specified key in hash C<hv>, returning NULL
334 if the operation failed or if the value did not need to be actually stored
335 within the hash (as in the case of tied hashes). Otherwise it can be
336 dereferenced to get the original C<SV*>.
338 They differ only in how the hash key is specified.
340 In C<hv_stores>, the key is a C language string literal, enclosed in double
341 quotes. It is never treated as being in UTF-8.
343 In C<hv_store>, C<key> is either NULL or points to the first byte of the string
344 specifying the key, and its length in bytes is given by the absolute value of
345 an additional parameter, C<klen>. A NULL key indicates the key is to be
346 treated as C<undef>, and C<klen> is ignored; otherwise the key string may
347 contain embedded-NUL bytes. If C<klen> is negative, the string is treated as
348 being encoded in UTF-8; otherwise not.
350 C<hv_store> has another extra parameter, C<hash>, a precomputed hash of the key
351 string, or zero if it has not been precomputed. This parameter is omitted from
352 C<hv_stores>, as it is computed automatically at compile time.
354 If <hv> is NULL, NULL is returned and no action is taken.
356 If C<val> is NULL, it is treated as being C<undef>; otherwise the caller is
357 responsible for suitably incrementing the reference count of C<val> before
358 the call, and decrementing it if the function returned C<NULL>. Effectively
359 a successful C<hv_store> takes ownership of one reference to C<val>. This is
360 usually what you want; a newly created SV has a reference count of one, so
361 if all your code does is create SVs then store them in a hash, C<hv_store>
362 will own the only reference to the new SV, and your code doesn't need to do
363 anything further to tidy up.
365 C<hv_store> is not implemented as a call to L</C<hv_store_ent>>, and does not
366 create a temporary SV for the key, so if your key data is not already in SV
367 form then use C<hv_store> in preference to C<hv_store_ent>.
369 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
370 information on how to use this function on tied hashes.
372 =for apidoc hv_store_ent
374 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
375 parameter is the precomputed hash value; if it is zero then Perl will
376 compute it. The return value is the new hash entry so created. It will be
377 C<NULL> if the operation failed or if the value did not need to be actually
378 stored within the hash (as in the case of tied hashes). Otherwise the
379 contents of the return value can be accessed using the C<He?> macros
380 described here. Note that the caller is responsible for suitably
381 incrementing the reference count of C<val> before the call, and
382 decrementing it if the function returned NULL. Effectively a successful
383 C<hv_store_ent> takes ownership of one reference to C<val>. This is
384 usually what you want; a newly created SV has a reference count of one, so
385 if all your code does is create SVs then store them in a hash, C<hv_store>
386 will own the only reference to the new SV, and your code doesn't need to do
387 anything further to tidy up. Note that C<hv_store_ent> only reads the C<key>;
388 unlike C<val> it does not take ownership of it, so maintaining the correct
389 reference count on C<key> is entirely the caller's responsibility. The reason
390 it does not take ownership, is that C<key> is not used after this function
391 returns, and so can be freed immediately. C<hv_store>
392 is not implemented as a call to C<hv_store_ent>, and does not create a temporary
393 SV for the key, so if your key data is not already in SV form then use
394 C<hv_store> in preference to C<hv_store_ent>.
396 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
397 information on how to use this function on tied hashes.
399 =for apidoc hv_exists
401 Returns a boolean indicating whether the specified hash key exists. The
402 absolute value of C<klen> is the length of the key. If C<klen> is
403 negative the key is assumed to be in UTF-8-encoded Unicode.
407 Returns the SV which corresponds to the specified key in the hash.
408 The absolute value of C<klen> is the length of the key. If C<klen> is
409 negative the key is assumed to be in UTF-8-encoded Unicode. If
410 C<lval> is set then the fetch will be part of a store. This means that if
411 there is no value in the hash associated with the given key, then one is
412 created and a pointer to it is returned. The C<SV*> it points to can be
413 assigned to. But always check that the
414 return value is non-null before dereferencing it to an C<SV*>.
416 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
417 information on how to use this function on tied hashes.
419 =for apidoc hv_exists_ent
421 Returns a boolean indicating whether
422 the specified hash key exists. C<hash>
423 can be a valid precomputed hash value, or 0 to ask for it to be
429 /* returns an HE * structure with the all fields set */
430 /* note that hent_val will be a mortal sv for MAGICAL hashes */
432 =for apidoc hv_fetch_ent
434 Returns the hash entry which corresponds to the specified key in the hash.
435 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
436 if you want the function to compute it. IF C<lval> is set then the fetch
437 will be part of a store. Make sure the return value is non-null before
438 accessing it. The return value when C<hv> is a tied hash is a pointer to a
439 static location, so be sure to make a copy of the structure if you need to
442 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
443 information on how to use this function on tied hashes.
448 /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */
450 Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
451 const int action, SV *val, const U32 hash)
456 PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN;
465 return hv_common(hv, NULL, key, klen, flags, action, val, hash);
469 Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
470 int flags, int action, SV *val, U32 hash)
478 const int return_svp = action & HV_FETCH_JUST_SV;
479 HEK *keysv_hek = NULL;
486 assert(SvTYPE(hv) == SVt_PVHV);
488 if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
490 if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) {
491 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
492 if (uf->uf_set == NULL) {
493 SV* obj = mg->mg_obj;
496 keysv = newSVpvn_flags(key, klen, SVs_TEMP |
497 ((flags & HVhek_UTF8)
501 mg->mg_obj = keysv; /* pass key */
502 uf->uf_index = action; /* pass action */
503 magic_getuvar(MUTABLE_SV(hv), mg);
504 keysv = mg->mg_obj; /* may have changed */
507 /* If the key may have changed, then we need to invalidate
508 any passed-in computed hash value. */
514 /* flags might have HVhek_NOTSHARED set. If so, we need to ignore that.
515 Some callers to hv_common() pass the flags value from an existing HEK,
516 and if that HEK is not shared, then it has the relevant flag bit set,
517 which must not be passed into share_hek_flags().
519 It would be "purer" to insist that all callers clear it, but we'll end up
520 with subtle bugs if we leave it to them, or runtime assertion failures if
521 we try to enforce our documentation with landmines.
523 If keysv is true, all code paths assign a new value to flags with that
524 bit clear, so we're always "good". Hence we only need to explicitly clear
525 this bit in the else block. */
527 if (flags & HVhek_FREEKEY)
529 key = SvPV_const(keysv, klen);
530 is_utf8 = (SvUTF8(keysv) != 0);
531 if (SvIsCOW_shared_hash(keysv)) {
532 flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
537 is_utf8 = cBOOL(flags & HVhek_UTF8);
538 flags &= ~HVhek_NOTSHARED;
541 if (action & HV_DELETE) {
542 return (void *) hv_delete_common(hv, keysv, key, klen,
543 flags | (is_utf8 ? HVhek_UTF8 : 0),
547 xhv = (XPVHV*)SvANY(hv);
549 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
550 if (mg_find((const SV *)hv, PERL_MAGIC_tied)
551 || SvGMAGICAL((const SV *)hv))
553 /* FIXME should be able to skimp on the HE/HEK here when
554 HV_FETCH_JUST_SV is true. */
556 keysv = newSVpvn_utf8(key, klen, is_utf8);
558 keysv = newSVsv(keysv);
561 mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY);
563 /* grab a fake HE/HEK pair from the pool or make a new one */
564 entry = PL_hv_fetch_ent_mh;
566 PL_hv_fetch_ent_mh = HeNEXT(entry);
570 Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
571 HeKEY_hek(entry) = (HEK*)k;
573 HeNEXT(entry) = NULL;
574 HeSVKEY_set(entry, keysv);
576 sv_upgrade(sv, SVt_PVLV);
578 /* so we can free entry when freeing sv */
579 LvTARG(sv) = MUTABLE_SV(entry);
581 /* XXX remove at some point? */
582 if (flags & HVhek_FREEKEY)
586 return entry ? (void *) &HeVAL(entry) : NULL;
588 return (void *) entry;
590 #ifdef ENV_IS_CASELESS
591 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
593 for (i = 0; i < klen; ++i)
594 if (isLOWER(key[i])) {
595 /* Would be nice if we had a routine to do the
596 copy and uppercase in a single pass through. */
597 const char * const nkey = strupr(savepvn(key,klen));
598 /* Note that this fetch is for nkey (the uppercased
599 key) whereas the store is for key (the original) */
600 void *result = hv_common(hv, NULL, nkey, klen,
601 HVhek_FREEKEY, /* free nkey */
602 0 /* non-LVAL fetch */
603 | HV_DISABLE_UVAR_XKEY
606 0 /* compute hash */);
607 if (!result && (action & HV_FETCH_LVALUE)) {
608 /* This call will free key if necessary.
609 Do it this way to encourage compiler to tail
611 result = hv_common(hv, keysv, key, klen, flags,
613 | HV_DISABLE_UVAR_XKEY
615 newSV_type(SVt_NULL), hash);
617 if (flags & HVhek_FREEKEY)
625 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
626 if (mg_find((const SV *)hv, PERL_MAGIC_tied)
627 || SvGMAGICAL((const SV *)hv)) {
628 /* I don't understand why hv_exists_ent has svret and sv,
629 whereas hv_exists only had one. */
630 SV * const svret = sv_newmortal();
633 if (keysv || is_utf8) {
635 keysv = newSVpvn_utf8(key, klen, TRUE);
637 keysv = newSVsv(keysv);
639 mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
641 mg_copy(MUTABLE_SV(hv), sv, key, klen);
643 if (flags & HVhek_FREEKEY)
646 MAGIC * const mg = mg_find(sv, PERL_MAGIC_tiedelem);
648 magic_existspack(svret, mg);
650 /* This cast somewhat evil, but I'm merely using NULL/
651 not NULL to return the boolean exists.
652 And I know hv is not NULL. */
653 return SvTRUE_NN(svret) ? (void *)hv : NULL;
655 #ifdef ENV_IS_CASELESS
656 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
657 /* XXX This code isn't UTF8 clean. */
658 char * const keysave = (char * const)key;
659 /* Will need to free this, so set FREEKEY flag. */
660 key = savepvn(key,klen);
661 key = (const char*)strupr((char*)key);
666 if (flags & HVhek_FREEKEY) {
669 flags |= HVhek_FREEKEY;
673 else if (action & HV_FETCH_ISSTORE) {
676 hv_magic_check (hv, &needs_copy, &needs_store);
678 const bool save_taint = TAINT_get;
679 if (keysv || is_utf8) {
681 keysv = newSVpvn_utf8(key, klen, TRUE);
684 TAINT_set(SvTAINTED(keysv));
685 keysv = sv_2mortal(newSVsv(keysv));
686 mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
688 mg_copy(MUTABLE_SV(hv), val, key, klen);
691 TAINT_IF(save_taint);
692 #ifdef NO_TAINT_SUPPORT
693 PERL_UNUSED_VAR(save_taint);
696 if (flags & HVhek_FREEKEY)
700 #ifdef ENV_IS_CASELESS
701 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
702 /* XXX This code isn't UTF8 clean. */
703 const char *keysave = key;
704 /* Will need to free this, so set FREEKEY flag. */
705 key = savepvn(key,klen);
706 key = (const char*)strupr((char*)key);
711 if (flags & HVhek_FREEKEY) {
714 flags |= HVhek_FREEKEY;
722 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
723 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
724 || (SvRMAGICAL((const SV *)hv)
725 && mg_find((const SV *)hv, PERL_MAGIC_env))
730 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
732 HvARRAY(hv) = (HE**)array;
734 #ifdef DYNAMIC_ENV_FETCH
735 else if (action & HV_FETCH_ISEXISTS) {
736 /* for an %ENV exists, if we do an insert it's by a recursive
737 store call, so avoid creating HvARRAY(hv) right now. */
741 /* XXX remove at some point? */
742 if (flags & HVhek_FREEKEY)
749 if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) {
750 char * const keysave = (char *)key;
751 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
755 flags &= ~HVhek_UTF8;
756 if (key != keysave) {
757 if (flags & HVhek_FREEKEY)
759 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
760 /* If the caller calculated a hash, it was on the sequence of
761 octets that are the UTF-8 form. We've now changed the sequence
762 of octets stored to that of the equivalent byte representation,
763 so the hash we need is different. */
768 if (keysv && (SvIsCOW_shared_hash(keysv))) {
770 keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
771 hash = SvSHARED_HASH(keysv);
774 PERL_HASH(hash, key, klen);
776 #ifdef DYNAMIC_ENV_FETCH
777 if (!HvARRAY(hv)) entry = NULL;
781 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
788 /* keysv is actually a HEK in disguise, so we can match just by
789 * comparing the HEK pointers in the HE chain. There is a slight
790 * caveat: on something like "\x80", which has both plain and utf8
791 * representations, perl's hashes do encoding-insensitive lookups,
792 * but preserve the encoding of the stored key. Thus a particular
793 * key could map to two different HEKs in PL_strtab. We only
794 * conclude 'not found' if all the flags are the same; otherwise
795 * we fall back to a full search (this should only happen in rare
798 int keysv_flags = HEK_FLAGS(keysv_hek);
799 HE *orig_entry = entry;
801 for (; entry; entry = HeNEXT(entry)) {
802 HEK *hek = HeKEY_hek(entry);
803 if (hek == keysv_hek)
805 if (HEK_FLAGS(hek) != keysv_flags)
806 break; /* need to do full match */
810 /* failed on shortcut - do full search loop */
814 for (; entry; entry = HeNEXT(entry)) {
815 if (HeHASH(entry) != hash) /* strings can't be equal */
817 if (HeKLEN(entry) != (I32)klen)
819 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
821 if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8)
825 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
826 if ((HeKFLAGS(entry) ^ flags) & HVhek_WASUTF8) {
827 /* We match if HVhek_UTF8 bit in our flags and hash key's
828 match. But if entry was set previously with HVhek_WASUTF8
829 and key now doesn't (or vice versa) then we should change
830 the key's flag, as this is assignment. */
831 if ((HeKFLAGS(entry) & HVhek_NOTSHARED) == 0) {
832 /* Need to swap the key we have for a key with the flags we
833 need. As keys are shared we can't just write to the
834 flag, so we share the new one, unshare the old one. */
836 = share_hek_flags(key, klen, hash, flags & ~HVhek_FREEKEY);
837 unshare_hek (HeKEY_hek(entry));
838 HeKEY_hek(entry) = new_hek;
840 else if (hv == PL_strtab) {
841 /* PL_strtab is usually the only hash without HvSHAREKEYS,
842 so putting this test here is cheap */
843 if (flags & HVhek_FREEKEY)
845 Perl_croak(aTHX_ S_strtab_error,
846 action & HV_FETCH_LVALUE ? "fetch" : "store");
849 /* Effectively this is save_hek_flags() for a new version
850 of the HEK and Safefree() of the old rolled together. */
851 HeKFLAGS(entry) ^= HVhek_WASUTF8;
853 if (flags & HVhek_ENABLEHVKFLAGS)
856 if (HeVAL(entry) == &PL_sv_placeholder) {
857 /* yes, can store into placeholder slot */
858 if (action & HV_FETCH_LVALUE) {
860 /* This preserves behaviour with the old hv_fetch
861 implementation which at this point would bail out
862 with a break; (at "if we find a placeholder, we
863 pretend we haven't found anything")
865 That break mean that if a placeholder were found, it
866 caused a call into hv_store, which in turn would
867 check magic, and if there is no magic end up pretty
868 much back at this point (in hv_store's code). */
871 /* LVAL fetch which actually needs a store. */
872 val = newSV_type(SVt_NULL);
873 HvPLACEHOLDERS(hv)--;
876 if (val != &PL_sv_placeholder)
877 HvPLACEHOLDERS(hv)--;
880 } else if (action & HV_FETCH_ISSTORE) {
881 SvREFCNT_dec(HeVAL(entry));
884 } else if (HeVAL(entry) == &PL_sv_placeholder) {
885 /* if we find a placeholder, we pretend we haven't found
889 if (flags & HVhek_FREEKEY)
892 return (void *) &HeVAL(entry);
898 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
899 if (!(action & HV_FETCH_ISSTORE)
900 && SvRMAGICAL((const SV *)hv)
901 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
903 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
905 sv = newSVpvn(env,len);
907 return hv_common(hv, keysv, key, klen, flags,
908 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
914 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
915 hv_notallowed(flags, key, klen,
916 "Attempt to access disallowed key '%" SVf "' in"
917 " a restricted hash");
919 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
920 /* Not doing some form of store, so return failure. */
921 if (flags & HVhek_FREEKEY)
925 if (action & HV_FETCH_LVALUE) {
926 val = action & HV_FETCH_EMPTY_HE ? NULL : newSV_type(SVt_NULL);
928 /* At this point the old hv_fetch code would call to hv_store,
929 which in turn might do some tied magic. So we need to make that
930 magic check happen. */
931 /* gonna assign to this, so it better be there */
932 /* If a fetch-as-store fails on the fetch, then the action is to
933 recurse once into "hv_store". If we didn't do this, then that
934 recursive call would call the key conversion routine again.
935 However, as we replace the original key with the converted
936 key, this would result in a double conversion, which would show
937 up as a bug if the conversion routine is not idempotent.
938 Hence the use of HV_DISABLE_UVAR_XKEY. */
939 return hv_common(hv, keysv, key, klen, flags,
940 HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
942 /* XXX Surely that could leak if the fetch-was-store fails?
943 Just like the hv_fetch. */
947 /* Welcome to hv_store... */
950 /* Not sure if we can get here. I think the only case of oentry being
951 NULL is for %ENV with dynamic env fetch. But that should disappear
952 with magic in the previous code. */
955 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
957 HvARRAY(hv) = (HE**)array;
960 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
962 /* share_hek_flags will do the free for us. This might be considered
964 if (LIKELY(HvSHAREKEYS(hv))) {
966 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
968 else if (UNLIKELY(hv == PL_strtab)) {
969 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
970 this test here is cheap */
971 if (flags & HVhek_FREEKEY)
973 Perl_croak(aTHX_ S_strtab_error,
974 action & HV_FETCH_LVALUE ? "fetch" : "store");
977 /* gotta do the real thing */
979 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
982 in_collision = cBOOL(*oentry != NULL);
985 #ifdef PERL_HASH_RANDOMIZE_KEYS
986 /* This logic semi-randomizes the insert order in a bucket.
987 * Either we insert into the top, or the slot below the top,
988 * making it harder to see if there is a collision. We also
989 * reset the iterator randomizer if there is one.
993 if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
994 UPDATE_HASH_RAND_BITS_KEY(key,klen);
995 if ( PL_hash_rand_bits & 1 ) {
996 HeNEXT(entry) = HeNEXT(*oentry);
997 HeNEXT(*oentry) = entry;
999 HeNEXT(entry) = *oentry;
1005 HeNEXT(entry) = *oentry;
1008 #ifdef PERL_HASH_RANDOMIZE_KEYS
1010 /* Currently this makes various tests warn in annoying ways.
1011 * So Silenced for now. - Yves | bogus end of comment =>* /
1012 if (HvAUX(hv)->xhv_riter != -1) {
1013 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1014 "[TESTING] Inserting into a hash during each() traversal results in undefined behavior"
1019 MAYBE_UPDATE_HASH_RAND_BITS_KEY(key,klen);
1020 HvAUX(hv)->xhv_rand= (U32)PL_hash_rand_bits;
1024 if (val == &PL_sv_placeholder)
1025 HvPLACEHOLDERS(hv)++;
1026 if (flags & HVhek_ENABLEHVKFLAGS)
1029 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
1030 if ( in_collision && DO_HSPLIT(xhv) ) {
1031 const STRLEN oldsize = xhv->xhv_max + 1;
1032 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1034 if (items /* hash has placeholders */
1035 && !SvREADONLY(hv) /* but is not a restricted hash */) {
1036 /* If this hash previously was a "restricted hash" and had
1037 placeholders, but the "restricted" flag has been turned off,
1038 then the placeholders no longer serve any useful purpose.
1039 However, they have the downsides of taking up RAM, and adding
1040 extra steps when finding used values. It's safe to clear them
1041 at this point, even though Storable rebuilds restricted hashes by
1042 putting in all the placeholders (first) before turning on the
1043 readonly flag, because Storable always pre-splits the hash.
1044 If we're lucky, then we may clear sufficient placeholders to
1045 avoid needing to split the hash at all. */
1046 clear_placeholders(hv, items);
1048 hsplit(hv, oldsize, oldsize * 2);
1050 hsplit(hv, oldsize, oldsize * 2);
1054 return entry ? (void *) &HeVAL(entry) : NULL;
1056 return (void *) entry;
1060 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
1062 const MAGIC *mg = SvMAGIC(hv);
1064 PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
1066 *needs_copy = FALSE;
1067 *needs_store = TRUE;
1069 if (isUPPER(mg->mg_type)) {
1071 if (mg->mg_type == PERL_MAGIC_tied) {
1072 *needs_store = FALSE;
1073 return; /* We've set all there is to set. */
1076 mg = mg->mg_moremagic;
1081 =for apidoc hv_scalar
1083 Evaluates the hash in scalar context and returns the result.
1085 When the hash is tied dispatches through to the SCALAR method,
1086 otherwise returns a mortal SV containing the number of keys
1089 Note, prior to 5.25 this function returned what is now
1090 returned by the hv_bucket_ratio() function.
1096 Perl_hv_scalar(pTHX_ HV *hv)
1101 PERL_ARGS_ASSERT_HV_SCALAR;
1103 if (SvRMAGICAL(hv)) {
1104 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
1106 return magic_scalarpack(hv, mg);
1109 sv = newSV_type_mortal(SVt_IV);
1111 /* Inlined sv_setuv(sv, HvUSEDKEYS(hv)) follows:*/
1114 if (u <= (UV)IV_MAX) {
1115 SvIV_set(sv, (IV)u);
1116 (void)SvIOK_only(sv);
1121 (void)SvIOK_only_UV(sv);
1130 hv_pushkv(): push all the keys and/or values of a hash onto the stack.
1131 The rough Perl equivalents:
1136 Resets the hash's iterator.
1138 flags : 1 = push keys
1140 1|2 = push keys and values
1141 XXX use symbolic flag constants at some point?
1142 I might unroll the non-tied hv_iternext() in here at some point - DAPM
1146 Perl_hv_pushkv(pTHX_ HV *hv, U32 flags)
1149 bool tied = SvRMAGICAL(hv) && (mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied)
1150 #ifdef DYNAMIC_ENV_FETCH /* might not know number of keys yet */
1151 || mg_find(MUTABLE_SV(hv), PERL_MAGIC_env)
1154 PERL_ARGS_ASSERT_HV_PUSHKV;
1155 assert(flags); /* must be pushing at least one of keys and values */
1157 (void)hv_iterinit(hv);
1160 SSize_t ext = (flags == 3) ? 2 : 1;
1161 while ((entry = hv_iternext(hv))) {
1164 rpp_push_1(hv_iterkeysv(entry));
1166 rpp_push_1(hv_iterval(hv, entry));
1170 Size_t nkeys = HvUSEDKEYS(hv);
1176 /* 2*nkeys() should never be big enough to truncate or wrap */
1177 assert(nkeys <= (SSize_t_MAX >> 1));
1178 ext = nkeys * ((flags == 3) ? 2 : 1);
1180 EXTEND_MORTAL(nkeys);
1183 while ((entry = hv_iternext(hv))) {
1185 SV *keysv = newSVhek(HeKEY_hek(entry));
1187 PL_tmps_stack[++PL_tmps_ix] = keysv;
1191 rpp_push_1(HeVAL(entry));
1198 =for apidoc hv_bucket_ratio
1200 If the hash is tied dispatches through to the SCALAR tied method,
1201 otherwise if the hash contains no keys returns 0, otherwise returns
1202 a mortal sv containing a string specifying the number of used buckets,
1203 followed by a slash, followed by the number of available buckets.
1205 This function is expensive, it must scan all of the buckets
1206 to determine which are used, and the count is NOT cached.
1207 In a large hash this could be a lot of buckets.
1213 Perl_hv_bucket_ratio(pTHX_ HV *hv)
1217 PERL_ARGS_ASSERT_HV_BUCKET_RATIO;
1219 if (SvRMAGICAL(hv)) {
1220 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
1222 return magic_scalarpack(hv, mg);
1225 if (HvUSEDKEYS((HV *)hv)) {
1226 sv = sv_newmortal();
1227 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
1228 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
1237 =for apidoc hv_delete
1239 Deletes a key/value pair in the hash. The value's SV is removed from
1240 the hash, made mortal, and returned to the caller. The absolute
1241 value of C<klen> is the length of the key. If C<klen> is negative the
1242 key is assumed to be in UTF-8-encoded Unicode. The C<flags> value
1243 will normally be zero; if set to C<G_DISCARD> then C<NULL> will be returned.
1244 C<NULL> will also be returned if the key is not found.
1246 =for apidoc hv_delete_ent
1248 Deletes a key/value pair in the hash. The value SV is removed from the hash,
1249 made mortal, and returned to the caller. The C<flags> value will normally be
1250 zero; if set to C<G_DISCARD> then C<NULL> will be returned. C<NULL> will also
1251 be returned if the key is not found. C<hash> can be a valid precomputed hash
1252 value, or 0 to ask for it to be computed.
1258 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
1259 int k_flags, I32 d_flags, U32 hash)
1265 bool is_utf8 = cBOOL(k_flags & HVhek_UTF8);
1266 HEK *keysv_hek = NULL;
1267 U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
1272 if (SvMAGICAL(hv)) {
1275 hv_magic_check (hv, &needs_copy, &needs_store);
1279 entry = (HE *) hv_common(hv, keysv, key, klen,
1280 k_flags & ~HVhek_FREEKEY,
1281 HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
1283 sv = entry ? HeVAL(entry) : NULL;
1285 if (SvMAGICAL(sv)) {
1289 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1290 /* No longer an element */
1291 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1294 return NULL; /* element cannot be deleted */
1296 #ifdef ENV_IS_CASELESS
1297 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
1298 /* XXX This code isn't UTF8 clean. */
1299 keysv = newSVpvn_flags(key, klen, SVs_TEMP);
1300 if (k_flags & HVhek_FREEKEY) {
1303 key = strupr(SvPVX(keysv));
1312 xhv = (XPVHV*)SvANY(hv);
1313 if (!HvTOTALKEYS(hv))
1316 if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
1317 const char * const keysave = key;
1318 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1321 k_flags |= HVhek_UTF8;
1323 k_flags &= ~HVhek_UTF8;
1324 if (key != keysave) {
1325 if (k_flags & HVhek_FREEKEY) {
1326 /* This shouldn't happen if our caller does what we expect,
1327 but strictly the API allows it. */
1330 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1334 if (keysv && (SvIsCOW_shared_hash(keysv))) {
1335 if (HvSHAREKEYS(hv))
1336 keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
1337 hash = SvSHARED_HASH(keysv);
1340 PERL_HASH(hash, key, klen);
1342 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1349 /* keysv is actually a HEK in disguise, so we can match just by
1350 * comparing the HEK pointers in the HE chain. There is a slight
1351 * caveat: on something like "\x80", which has both plain and utf8
1352 * representations, perl's hashes do encoding-insensitive lookups,
1353 * but preserve the encoding of the stored key. Thus a particular
1354 * key could map to two different HEKs in PL_strtab. We only
1355 * conclude 'not found' if all the flags are the same; otherwise
1356 * we fall back to a full search (this should only happen in rare
1359 int keysv_flags = HEK_FLAGS(keysv_hek);
1361 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1362 HEK *hek = HeKEY_hek(entry);
1363 if (hek == keysv_hek)
1365 if (HEK_FLAGS(hek) != keysv_flags)
1366 break; /* need to do full match */
1370 /* failed on shortcut - do full search loop */
1371 oentry = first_entry;
1375 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1376 if (HeHASH(entry) != hash) /* strings can't be equal */
1378 if (HeKLEN(entry) != (I32)klen)
1380 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
1382 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1386 if (hv == PL_strtab) {
1387 if (k_flags & HVhek_FREEKEY)
1389 Perl_croak(aTHX_ S_strtab_error, "delete");
1394 /* if placeholder is here, it's already been deleted.... */
1395 if (sv == &PL_sv_placeholder) {
1396 if (k_flags & HVhek_FREEKEY)
1400 if (SvREADONLY(hv) && sv && SvREADONLY(sv)) {
1401 hv_notallowed(k_flags, key, klen,
1402 "Attempt to delete readonly key '%" SVf "' from"
1403 " a restricted hash");
1407 * If a restricted hash, rather than really deleting the entry, put
1408 * a placeholder there. This marks the key as being "approved", so
1409 * we can still access via not-really-existing key without raising
1412 if (SvREADONLY(hv)) {
1413 /* We'll be saving this slot, so the number of allocated keys
1414 * doesn't go down, but the number placeholders goes up */
1415 HeVAL(entry) = &PL_sv_placeholder;
1416 HvPLACEHOLDERS(hv)++;
1419 HeVAL(entry) = NULL;
1420 *oentry = HeNEXT(entry);
1421 if (HvHasAUX(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) {
1425 if (HvHasAUX(hv) && HvLAZYDEL(hv) &&
1426 entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1427 HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1428 hv_free_ent(NULL, entry);
1430 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1431 if (xhv->xhv_keys == 0)
1432 HvHASKFLAGS_off(hv);
1435 /* If this is a stash and the key ends with ::, then someone is
1436 * deleting a package.
1438 if (sv && SvTYPE(sv) == SVt_PVGV && HvHasENAME(hv)) {
1441 (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1443 (klen == 1 && key[0] == ':')
1445 && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1446 && (stash = GvHV((GV *)gv))
1447 && HvHasENAME(stash)) {
1448 /* A previous version of this code checked that the
1449 * GV was still in the symbol table by fetching the
1450 * GV with its name. That is not necessary (and
1451 * sometimes incorrect), as HvENAME cannot be set
1452 * on hv if it is not in the symtab. */
1454 /* Hang on to it for a bit. */
1455 SvREFCNT_inc_simple_void_NN(
1456 sv_2mortal((SV *)gv)
1459 else if (memEQs(key, klen, "ISA") && GvAV(gv)) {
1461 MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa);
1465 if (mg->mg_obj == (SV*)gv) {
1466 /* This is the only stash this ISA was used for.
1467 * The isaelem magic asserts if there's no
1468 * isa magic on the array, so explicitly
1469 * remove the magic on both the array and its
1470 * elements. @ISA shouldn't be /too/ large.
1476 end = svp + (AvFILLp(isa)+1);
1479 mg_free_type(*svp, PERL_MAGIC_isaelem);
1483 mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
1486 /* mg_obj is an array of stashes
1487 Note that the array doesn't keep a reference
1488 count on the stashes.
1490 AV *av = (AV*)mg->mg_obj;
1495 assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
1497 /* remove the stash from the magic array */
1498 arrayp = svp = AvARRAY(av);
1499 items = AvFILLp(av) + 1;
1501 assert(*arrayp == (SV *)gv);
1503 /* avoid a double free on the last stash */
1505 /* The magic isn't MGf_REFCOUNTED, so release
1506 * the array manually.
1508 SvREFCNT_dec_NN(av);
1513 if (*svp == (SV*)gv)
1517 index = svp - arrayp;
1518 assert(index >= 0 && index <= AvFILLp(av));
1519 if (index < AvFILLp(av)) {
1520 arrayp[index] = arrayp[AvFILLp(av)];
1522 arrayp[AvFILLp(av)] = NULL;
1530 if (k_flags & HVhek_FREEKEY)
1534 /* deletion of method from stash */
1535 if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1537 mro_method_changed_in(hv);
1539 if (d_flags & G_DISCARD) {
1548 if (mro_changes == 1) mro_isa_changed_in(hv);
1549 else if (mro_changes == 2)
1550 mro_package_moved(NULL, stash, gv, 1);
1556 if (SvREADONLY(hv)) {
1557 hv_notallowed(k_flags, key, klen,
1558 "Attempt to delete disallowed key '%" SVf "' from"
1559 " a restricted hash");
1562 if (k_flags & HVhek_FREEKEY)
1567 /* HVs are used for (at least) three things
1570 3) associative arrays
1572 shared hash keys benefit the first two greatly, because keys are likely
1573 to be re-used between objects, or for constants in the optree
1575 However, for large associative arrays (lookup tables, "seen" hashes) keys are
1576 unlikely to be re-used. Hence having those keys in the shared string table as
1577 well as the hash is a memory hit, if they are never actually shared with a
1578 second hash. Hence we turn off shared hash keys if a (regular) hash gets
1581 This is a heuristic. There might be a better answer than 42, but for now
1584 NOTE: Configure with -Accflags='-DPERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES'
1585 to enable this new functionality.
1588 #ifdef PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES
1590 S_large_hash_heuristic(pTHX_ HV *hv, STRLEN size) {
1593 && !(HvHasAUX(hv) && HvENAME_get(hv))) {
1594 /* This hash appears to be growing quite large.
1595 We gamble that it is not sharing keys with other hashes. */
1603 S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1606 char *a = (char*) HvARRAY(hv);
1609 PERL_ARGS_ASSERT_HSPLIT;
1610 if (newsize > MAX_BUCKET_MAX+1)
1614 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1620 #ifdef PERL_HASH_RANDOMIZE_KEYS
1621 /* the idea of this is that we create a "random" value by hashing the address of
1622 * the array, we then use the low bit to decide if we insert at the top, or insert
1623 * second from top. After each such insert we rotate the hashed value. So we can
1624 * use the same hashed value over and over, and in normal build environments use
1625 * very few ops to do so. ROTL32() should produce a single machine operation. */
1626 MAYBE_UPDATE_HASH_RAND_BITS();
1628 HvARRAY(hv) = (HE**) a;
1629 HvMAX(hv) = newsize - 1;
1630 /* now we can safely clear the second half */
1631 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1633 if (!HvTOTALKEYS(hv)) /* skip rest if no entries */
1636 /* don't share keys in large simple hashes */
1637 if (LARGE_HASH_HEURISTIC(hv, HvTOTALKEYS(hv)))
1638 HvSHAREKEYS_off(hv);
1644 HE **oentry = aep + i;
1647 if (!entry) /* non-existent */
1650 U32 j = (HeHASH(entry) & newsize);
1652 *oentry = HeNEXT(entry);
1653 #ifdef PERL_HASH_RANDOMIZE_KEYS
1654 /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
1655 * insert to top, otherwise rotate the bucket rand 1 bit,
1656 * and use the new low bit to decide if we insert at top,
1657 * or next from top. IOW, we only rotate on a collision.*/
1658 if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
1659 UPDATE_HASH_RAND_BITS();
1660 if (PL_hash_rand_bits & 1) {
1661 HeNEXT(entry)= HeNEXT(aep[j]);
1662 HeNEXT(aep[j])= entry;
1664 /* Note, this is structured in such a way as the optimizer
1665 * should eliminate the duplicated code here and below without
1666 * us needing to explicitly use a goto. */
1667 HeNEXT(entry) = aep[j];
1673 /* see comment above about duplicated code */
1674 HeNEXT(entry) = aep[j];
1679 oentry = &HeNEXT(entry);
1683 } while (i++ < oldsize);
1687 =for apidoc hv_ksplit
1689 Attempt to grow the hash C<hv> so it has at least C<newmax> buckets available.
1690 Perl chooses the actual number for its convenience.
1692 This is the same as doing the following in Perl code:
1700 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1702 XPVHV* xhv = (XPVHV*)SvANY(hv);
1703 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 */
1709 PERL_ARGS_ASSERT_HV_KSPLIT;
1711 wantsize = (I32) newmax; /* possible truncation here */
1712 if (wantsize != newmax)
1715 wantsize= wantsize + (wantsize >> 1); /* wantsize *= 1.5 */
1716 if (wantsize < newmax) /* overflow detection */
1720 while (wantsize > newsize) {
1721 trysize = newsize << 1;
1722 if (trysize > newsize) {
1730 if (newsize <= oldsize)
1731 return; /* overflow detection */
1733 a = (char *) HvARRAY(hv);
1735 #ifdef PERL_HASH_RANDOMIZE_KEYS
1736 U32 was_ook = HvHasAUX(hv);
1738 hsplit(hv, oldsize, newsize);
1739 #ifdef PERL_HASH_RANDOMIZE_KEYS
1740 if (was_ook && HvHasAUX(hv) && HvTOTALKEYS(hv)) {
1741 MAYBE_UPDATE_HASH_RAND_BITS();
1742 HvAUX(hv)->xhv_rand = (U32)PL_hash_rand_bits;
1746 if (LARGE_HASH_HEURISTIC(hv, newmax))
1747 HvSHAREKEYS_off(hv);
1748 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1749 xhv->xhv_max = newsize - 1;
1750 HvARRAY(hv) = (HE **) a;
1754 /* IMO this should also handle cases where hv_max is smaller than hv_keys
1755 * as tied hashes could play silly buggers and mess us around. We will
1756 * do the right thing during hv_store() afterwards, but still - Yves */
1757 #define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
1758 /* Can we use fewer buckets? (hv_max is always 2^n-1) */ \
1759 if (hv_max < PERL_HASH_DEFAULT_HvMAX) { \
1760 hv_max = PERL_HASH_DEFAULT_HvMAX; \
1762 while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
1763 hv_max = hv_max / 2; \
1765 HvMAX(hv) = hv_max; \
1772 The content of C<ohv> is copied to a new hash. A pointer to the new hash is
1779 Perl_newHVhv(pTHX_ HV *ohv)
1781 HV * const hv = newHV();
1784 if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
1786 hv_max = HvMAX(ohv);
1788 if (!SvMAGICAL((const SV *)ohv)) {
1789 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1791 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1793 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1796 if (HvSHAREKEYS(ohv)) {
1797 #ifdef NODEFAULT_SHAREKEYS
1800 /* Shared is the default - it should have been set by newHV(). */
1801 assert(HvSHAREKEYS(hv));
1805 HvSHAREKEYS_off(hv);
1808 /* In each bucket... */
1809 for (i = 0; i <= hv_max; i++) {
1811 HE *oent = oents[i];
1818 /* Copy the linked list of entries. */
1819 for (; oent; oent = HeNEXT(oent)) {
1820 HE * const ent = new_HE();
1821 SV *const val = HeVAL(oent);
1822 const int flags = HeKFLAGS(oent);
1824 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1825 if ((flags & HVhek_NOTSHARED) == 0) {
1826 HeKEY_hek(ent) = share_hek_hek(HeKEY_hek(oent));
1829 const U32 hash = HeHASH(oent);
1830 const char * const key = HeKEY(oent);
1831 const STRLEN len = HeKLEN(oent);
1832 HeKEY_hek(ent) = save_hek_flags(key, len, hash, flags);
1844 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1848 /* Iterate over ohv, copying keys and values one at a time. */
1850 const I32 riter = HvRITER_get(ohv);
1851 HE * const eiter = HvEITER_get(ohv);
1852 STRLEN hv_keys = HvTOTALKEYS(ohv);
1854 HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1857 while ((entry = hv_iternext_flags(ohv, 0))) {
1858 SV *val = hv_iterval(ohv,entry);
1859 SV * const keysv = HeSVKEY(entry);
1860 val = SvIMMORTAL(val) ? val : newSVsv(val);
1862 (void)hv_store_ent(hv, keysv, val, 0);
1864 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1865 HeHASH(entry), HeKFLAGS(entry));
1867 HvRITER_set(ohv, riter);
1868 HvEITER_set(ohv, eiter);
1875 =for apidoc hv_copy_hints_hv
1877 A specialised version of L</newHVhv> for copying C<%^H>. C<ohv> must be
1878 a pointer to a hash (which may have C<%^H> magic, but should be generally
1879 non-magical), or C<NULL> (interpreted as an empty hash). The content
1880 of C<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1881 added to it. A pointer to the new hash is returned.
1887 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1889 HV * const hv = newHV();
1892 STRLEN hv_max = HvMAX(ohv);
1893 STRLEN hv_keys = HvTOTALKEYS(ohv);
1895 const I32 riter = HvRITER_get(ohv);
1896 HE * const eiter = HvEITER_get(ohv);
1901 HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1904 while ((entry = hv_iternext_flags(ohv, 0))) {
1905 SV *const sv = newSVsv(hv_iterval(ohv,entry));
1906 SV *heksv = HeSVKEY(entry);
1907 if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1908 if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1909 (char *)heksv, HEf_SVKEY);
1910 if (heksv == HeSVKEY(entry))
1911 (void)hv_store_ent(hv, heksv, sv, 0);
1913 (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1914 HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1915 SvREFCNT_dec_NN(heksv);
1918 HvRITER_set(ohv, riter);
1919 HvEITER_set(ohv, eiter);
1921 SvREFCNT_inc_simple_void_NN(hv);
1924 hv_magic(hv, NULL, PERL_MAGIC_hints);
1927 #undef HV_SET_MAX_ADJUSTED_FOR_KEYS
1929 /* like hv_free_ent, but returns the SV rather than freeing it */
1931 S_hv_free_ent_ret(pTHX_ HE *entry)
1933 PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1935 SV *val = HeVAL(entry);
1936 if (HeKLEN(entry) == HEf_SVKEY) {
1937 SvREFCNT_dec(HeKEY_sv(entry));
1938 Safefree(HeKEY_hek(entry));
1940 else if ((HeKFLAGS(entry) & HVhek_NOTSHARED) == 0) {
1941 unshare_hek(HeKEY_hek(entry));
1944 Safefree(HeKEY_hek(entry));
1952 Perl_hv_free_ent(pTHX_ HV *notused, HE *entry)
1954 PERL_UNUSED_ARG(notused);
1959 SV *val = hv_free_ent_ret(entry);
1965 Perl_hv_delayfree_ent(pTHX_ HV *notused, HE *entry)
1967 PERL_UNUSED_ARG(notused);
1971 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1972 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
1973 if (HeKLEN(entry) == HEf_SVKEY) {
1974 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1976 hv_free_ent(NULL, entry);
1980 =for apidoc hv_clear
1982 Frees all the elements of a hash, leaving it empty.
1983 The XS equivalent of C<%hash = ()>. See also L</hv_undef>.
1985 See L</av_clear> for a note about the hash possibly being invalid on
1992 Perl_hv_clear(pTHX_ HV *hv)
1999 DEBUG_A(Perl_hv_assert(aTHX_ hv));
2001 /* avoid hv being freed when calling destructors below */
2003 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
2004 orig_ix = PL_tmps_ix;
2005 if (SvREADONLY(hv) && HvTOTALKEYS(hv)) {
2006 /* restricted hash: convert all keys to placeholders */
2007 STRLEN max = HvMAX(hv);
2009 for (i = 0; i <= max; i++) {
2010 HE *entry = (HvARRAY(hv))[i];
2011 for (; entry; entry = HeNEXT(entry)) {
2012 /* not already placeholder */
2013 if (HeVAL(entry) != &PL_sv_placeholder) {
2015 if (SvREADONLY(HeVAL(entry))) {
2016 SV* const keysv = hv_iterkeysv(entry);
2017 Perl_croak_nocontext(
2018 "Attempt to delete readonly key '%" SVf "' from a restricted hash",
2021 SvREFCNT_dec_NN(HeVAL(entry));
2023 HeVAL(entry) = &PL_sv_placeholder;
2024 HvPLACEHOLDERS(hv)++;
2030 hv_free_entries(hv);
2031 HvPLACEHOLDERS_set(hv, 0);
2034 mg_clear(MUTABLE_SV(hv));
2036 HvHASKFLAGS_off(hv);
2040 mro_isa_changed_in(hv);
2041 HvEITER_set(hv, NULL);
2043 /* disarm hv's premature free guard */
2044 if (LIKELY(PL_tmps_ix == orig_ix))
2047 PL_tmps_stack[orig_ix] = &PL_sv_undef;
2048 SvREFCNT_dec_NN(hv);
2052 =for apidoc hv_clear_placeholders
2054 Clears any placeholders from a hash. If a restricted hash has any of its keys
2055 marked as readonly and the key is subsequently deleted, the key is not actually
2056 deleted but is marked by assigning it a value of C<&PL_sv_placeholder>. This tags
2057 it so it will be ignored by future operations such as iterating over the hash,
2058 but will still allow the hash to have a value reassigned to the key at some
2059 future point. This function clears any such placeholder keys from the hash.
2060 See C<L<Hash::Util::lock_keys()|Hash::Util/lock_keys>> for an example of its
2067 Perl_hv_clear_placeholders(pTHX_ HV *hv)
2069 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
2071 PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
2074 clear_placeholders(hv, items);
2078 S_clear_placeholders(pTHX_ HV *hv, const U32 placeholders)
2081 U32 to_find = placeholders;
2083 PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
2089 /* Loop down the linked list heads */
2090 HE **oentry = &(HvARRAY(hv))[i];
2093 while ((entry = *oentry)) {
2094 if (HeVAL(entry) == &PL_sv_placeholder) {
2095 *oentry = HeNEXT(entry);
2096 if (entry == HvEITER_get(hv))
2099 if (HvHasAUX(hv) && HvLAZYDEL(hv) &&
2100 entry == HeNEXT(HvAUX(hv)->xhv_eiter))
2101 HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
2102 hv_free_ent(NULL, entry);
2105 if (--to_find == 0) {
2107 HvTOTALKEYS(hv) -= (IV)placeholders;
2108 if (HvTOTALKEYS(hv) == 0)
2109 HvHASKFLAGS_off(hv);
2110 HvPLACEHOLDERS_set(hv, 0);
2114 oentry = &HeNEXT(entry);
2118 /* You can't get here, hence assertion should always fail. */
2119 assert (to_find == 0);
2120 NOT_REACHED; /* NOTREACHED */
2124 S_hv_free_entries(pTHX_ HV *hv)
2129 PERL_ARGS_ASSERT_HV_FREE_ENTRIES;
2131 while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index)) || HvTOTALKEYS(hv)) {
2137 /* hfree_next_entry()
2138 * For use only by S_hv_free_entries() and sv_clear().
2139 * Delete the next available HE from hv and return the associated SV.
2140 * Returns null on empty hash. Nevertheless null is not a reliable
2141 * indicator that the hash is empty, as the deleted entry may have a
2143 * indexp is a pointer to the current index into HvARRAY. The index should
2144 * initially be set to 0. hfree_next_entry() may update it. */
2147 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
2149 struct xpvhv_aux *iter;
2153 STRLEN orig_index = *indexp;
2156 PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
2158 if (HvHasAUX(hv) && ((iter = HvAUX(hv)))) {
2159 if ((entry = iter->xhv_eiter)) {
2160 /* the iterator may get resurrected after each
2161 * destructor call, so check each time */
2162 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2164 hv_free_ent(NULL, entry);
2165 /* warning: at this point HvARRAY may have been
2166 * re-allocated, HvMAX changed etc */
2168 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2169 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2170 #ifdef PERL_HASH_RANDOMIZE_KEYS
2171 iter->xhv_last_rand = iter->xhv_rand;
2176 if (!((XPVHV*)SvANY(hv))->xhv_keys)
2179 array = HvARRAY(hv);
2181 while ( ! ((entry = array[*indexp])) ) {
2182 if ((*indexp)++ >= HvMAX(hv))
2184 assert(*indexp != orig_index);
2186 array[*indexp] = HeNEXT(entry);
2187 ((XPVHV*) SvANY(hv))->xhv_keys--;
2189 if ( PL_phase != PERL_PHASE_DESTRUCT && HvHasENAME(hv)
2190 && HeVAL(entry) && isGV(HeVAL(entry))
2191 && GvHV(HeVAL(entry)) && HvHasENAME(GvHV(HeVAL(entry)))
2194 const char * const key = HePV(entry,klen);
2195 if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
2196 || (klen == 1 && key[0] == ':')) {
2198 NULL, GvHV(HeVAL(entry)),
2199 (GV *)HeVAL(entry), 0
2203 return hv_free_ent_ret(entry);
2208 =for apidoc hv_undef
2210 Undefines the hash. The XS equivalent of C<undef(%hash)>.
2212 As well as freeing all the elements of the hash (like C<hv_clear()>), this
2213 also frees any auxiliary data and storage associated with the hash.
2215 See L</av_clear> for a note about the hash possibly being invalid on
2222 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
2225 SSize_t orig_ix = PL_tmps_ix; /* silence compiler warning about uninitialized vars */
2229 save = cBOOL(SvREFCNT(hv));
2230 DEBUG_A(Perl_hv_assert(aTHX_ hv));
2232 /* The name must be deleted before the call to hv_free_entries so that
2233 CVs are anonymised properly. But the effective name must be pre-
2234 served until after that call (and only deleted afterwards if the
2235 call originated from sv_clear). For stashes with one name that is
2236 both the canonical name and the effective name, hv_name_set has to
2237 allocate an array for storing the effective name. We can skip that
2238 during global destruction, as it does not matter where the CVs point
2239 if they will be freed anyway. */
2240 /* note that the code following prior to hv_free_entries is duplicated
2241 * in sv_clear(), and changes here should be done there too */
2242 if (PL_phase != PERL_PHASE_DESTRUCT && HvHasNAME(hv)) {
2243 if (PL_stashcache) {
2244 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
2245 HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
2246 (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
2248 hv_name_set(hv, NULL, 0, 0);
2251 /* avoid hv being freed when calling destructors below */
2253 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
2254 orig_ix = PL_tmps_ix;
2257 /* As well as any/all HE*s in HvARRAY(), this call also ensures that
2258 xhv_eiter is NULL, including handling the case of a tied hash partway
2259 through iteration where HvLAZYDEL() is true and xhv_eiter points to an
2260 HE* that needs to be explicitly freed. */
2261 hv_free_entries(hv);
2263 /* HvHasAUX() is true for a hash if it has struct xpvhv_aux allocated. That
2264 structure has several other pieces of allocated memory - hence those must
2265 be freed before the structure itself can be freed. Some can be freed when
2266 a hash is "undefined" (this function), but some must persist until it is
2267 destroyed (which might be this function's immediate caller).
2269 Hence the code in this block frees what it is logical to free (and NULLs
2270 out anything freed) so that the structure is left in a logically
2271 consistent state - pointers are NULL or point to valid memory, and
2272 non-pointer values are correct for an empty hash. The structure state
2273 must remain consistent, because this code can no longer clear SVf_OOK,
2274 meaning that this structure might be read again at any point in the
2275 future without further checks or reinitialisation. */
2277 struct xpvhv_aux *aux = HvAUX(hv);
2278 struct mro_meta *meta;
2281 if (HvHasENAME(hv)) {
2282 if (PL_phase != PERL_PHASE_DESTRUCT)
2283 mro_isa_changed_in(hv);
2284 if (PL_stashcache) {
2285 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
2286 HEKf "'\n", HEKfARG(HvENAME_HEK_NN(hv))));
2287 (void)hv_deletehek(PL_stashcache, HvENAME_HEK_NN(hv), G_DISCARD);
2291 /* If this call originated from sv_clear, then we must check for
2292 * effective names that need freeing, as well as the usual name. */
2294 if (flags & HV_NAME_SETALL
2295 ? cBOOL(aux->xhv_name_u.xhvnameu_name)
2298 if (name && PL_stashcache) {
2299 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
2300 HEKf "'\n", HEKfARG(HvNAME_HEK_NN(hv))));
2301 (void)hv_deletehek(PL_stashcache, HvNAME_HEK_NN(hv), G_DISCARD);
2303 hv_name_set(hv, NULL, 0, flags);
2305 if((meta = aux->xhv_mro_meta)) {
2306 if (meta->mro_linear_all) {
2307 SvREFCNT_dec_NN(meta->mro_linear_all);
2308 /* mro_linear_current is just acting as a shortcut pointer,
2312 /* Only the current MRO is stored, so this owns the data.
2314 SvREFCNT_dec(meta->mro_linear_current);
2315 SvREFCNT_dec(meta->mro_nextmethod);
2316 SvREFCNT_dec(meta->isa);
2317 SvREFCNT_dec(meta->super);
2319 aux->xhv_mro_meta = NULL;
2322 if(HvSTASH_IS_CLASS(hv)) {
2323 SvREFCNT_dec(aux->xhv_class_superclass);
2324 SvREFCNT_dec(aux->xhv_class_initfields_cv);
2325 SvREFCNT_dec(aux->xhv_class_adjust_blocks);
2326 if(aux->xhv_class_fields)
2327 PadnamelistREFCNT_dec(aux->xhv_class_fields);
2328 SvREFCNT_dec(aux->xhv_class_param_map);
2329 Safefree(aux->xhv_class_suspended_initfields_compcv);
2330 aux->xhv_class_suspended_initfields_compcv = NULL;
2332 aux->xhv_aux_flags &= ~HvAUXf_IS_CLASS;
2336 Safefree(HvARRAY(hv));
2337 HvMAX(hv) = PERL_HASH_DEFAULT_HvMAX; /* 7 (it's a normal hash) */
2340 /* if we're freeing the HV, the SvMAGIC field has been reused for
2341 * other purposes, and so there can't be any placeholder magic */
2343 HvPLACEHOLDERS_set(hv, 0);
2346 mg_clear(MUTABLE_SV(hv));
2349 /* disarm hv's premature free guard */
2350 if (LIKELY(PL_tmps_ix == orig_ix))
2353 PL_tmps_stack[orig_ix] = &PL_sv_undef;
2354 SvREFCNT_dec_NN(hv);
2361 Returns the number of hash buckets that happen to be in use.
2363 This function implements the L<C<HvFILL> macro|perlapi/HvFILL> which you should
2366 As of perl 5.25 this function is used only for debugging
2367 purposes, and the number of used hash buckets is not
2368 in any way cached, thus this function can be costly
2369 to execute as it must iterate over all the buckets in the
2376 Perl_hv_fill(pTHX_ HV *const hv)
2379 HE **ents = HvARRAY(hv);
2381 PERL_UNUSED_CONTEXT;
2382 PERL_ARGS_ASSERT_HV_FILL;
2384 /* No keys implies no buckets used.
2385 One key can only possibly mean one bucket used. */
2386 if (HvTOTALKEYS(hv) < 2)
2387 return HvTOTALKEYS(hv);
2390 /* I wonder why we count down here...
2391 * Is it some micro-optimisation?
2392 * I would have thought counting up was better.
2395 HE *const *const last = ents + HvMAX(hv);
2396 count = last + 1 - ents;
2401 } while (++ents <= last);
2406 static struct xpvhv_aux*
2407 S_hv_auxinit(pTHX_ HV *hv) {
2408 struct xpvhv_aux *iter;
2410 PERL_ARGS_ASSERT_HV_AUXINIT;
2412 if (!HvHasAUX(hv)) {
2413 char *array = (char *) HvARRAY(hv);
2415 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
2416 HvARRAY(hv) = (HE**)array;
2418 iter = Perl_hv_auxalloc(aTHX_ hv);
2419 #ifdef PERL_HASH_RANDOMIZE_KEYS
2420 MAYBE_UPDATE_HASH_RAND_BITS();
2421 iter->xhv_rand = (U32)PL_hash_rand_bits;
2427 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2428 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2429 #ifdef PERL_HASH_RANDOMIZE_KEYS
2430 iter->xhv_last_rand = iter->xhv_rand;
2432 iter->xhv_name_u.xhvnameu_name = 0;
2433 iter->xhv_name_count = 0;
2434 iter->xhv_backreferences = 0;
2435 iter->xhv_mro_meta = NULL;
2436 iter->xhv_aux_flags = 0;
2441 =for apidoc hv_iterinit
2443 Prepares a starting point to traverse a hash table. Returns the number of
2444 keys in the hash, including placeholders (i.e. the same as C<HvTOTALKEYS(hv)>).
2445 The return value is currently only meaningful for hashes without tie magic.
2447 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
2448 hash buckets that happen to be in use. If you still need that esoteric
2449 value, you can get it through the macro C<HvFILL(hv)>.
2456 Perl_hv_iterinit(pTHX_ HV *hv)
2458 PERL_ARGS_ASSERT_HV_ITERINIT;
2461 struct xpvhv_aux * iter = HvAUX(hv);
2462 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2463 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2465 hv_free_ent(NULL, entry);
2467 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2468 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2469 #ifdef PERL_HASH_RANDOMIZE_KEYS
2470 iter->xhv_last_rand = iter->xhv_rand;
2476 /* note this includes placeholders! */
2477 return HvTOTALKEYS(hv);
2481 =for apidoc hv_riter_p
2483 Implements C<HvRITER> which you should use instead.
2489 Perl_hv_riter_p(pTHX_ HV *hv) {
2490 struct xpvhv_aux *iter;
2492 PERL_ARGS_ASSERT_HV_RITER_P;
2494 iter = HvHasAUX(hv) ? HvAUX(hv) : hv_auxinit(hv);
2495 return &(iter->xhv_riter);
2499 =for apidoc hv_eiter_p
2501 Implements C<HvEITER> which you should use instead.
2507 Perl_hv_eiter_p(pTHX_ HV *hv) {
2508 struct xpvhv_aux *iter;
2510 PERL_ARGS_ASSERT_HV_EITER_P;
2512 iter = HvHasAUX(hv) ? HvAUX(hv) : hv_auxinit(hv);
2513 return &(iter->xhv_eiter);
2517 =for apidoc hv_riter_set
2519 Implements C<HvRITER_set> which you should use instead.
2525 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2526 struct xpvhv_aux *iter;
2528 PERL_ARGS_ASSERT_HV_RITER_SET;
2536 iter = hv_auxinit(hv);
2538 iter->xhv_riter = riter;
2542 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2543 struct xpvhv_aux *iter;
2545 PERL_ARGS_ASSERT_HV_RAND_SET;
2547 #ifdef PERL_HASH_RANDOMIZE_KEYS
2551 iter = hv_auxinit(hv);
2553 iter->xhv_rand = new_xhv_rand;
2555 Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2560 =for apidoc hv_eiter_set
2562 Implements C<HvEITER_set> which you should use instead.
2568 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2569 struct xpvhv_aux *iter;
2571 PERL_ARGS_ASSERT_HV_EITER_SET;
2576 /* 0 is the default so don't go malloc()ing a new structure just to
2581 iter = hv_auxinit(hv);
2583 iter->xhv_eiter = eiter;
2587 =for apidoc hv_name_set
2588 =for apidoc_item ||hv_name_sets|HV *hv|"name"|U32 flags
2590 These each set the name of stash C<hv> to the specified name.
2592 They differ only in how the name is specified.
2594 In C<hv_name_sets>, the name is a literal C string, enclosed in double quotes.
2596 In C<hv_name_set>, C<name> points to the first byte of the name, and an
2597 additional parameter, C<len>, specifies its length in bytes. Hence, the name
2598 may contain embedded-NUL characters.
2600 If C<SVf_UTF8> is set in C<flags>, the name is treated as being in UTF-8;
2603 If C<HV_NAME_SETALL> is set in C<flags>, both the name and the effective name
2606 =for apidoc Amnh||HV_NAME_SETALL
2612 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2614 struct xpvhv_aux *iter;
2618 PERL_ARGS_ASSERT_HV_NAME_SET;
2621 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2625 if (iter->xhv_name_u.xhvnameu_name) {
2626 if(iter->xhv_name_count) {
2627 if(flags & HV_NAME_SETALL) {
2628 HEK ** const this_name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2629 HEK **hekp = this_name + (
2630 iter->xhv_name_count < 0
2631 ? -iter->xhv_name_count
2632 : iter->xhv_name_count
2634 while(hekp-- > this_name+1)
2635 unshare_hek_or_pvn(*hekp, 0, 0, 0);
2636 /* The first elem may be null. */
2637 if(*this_name) unshare_hek_or_pvn(*this_name, 0, 0, 0);
2638 Safefree(this_name);
2639 spot = &iter->xhv_name_u.xhvnameu_name;
2640 iter->xhv_name_count = 0;
2643 if(iter->xhv_name_count > 0) {
2644 /* shift some things over */
2646 iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2648 spot = iter->xhv_name_u.xhvnameu_names;
2649 spot[iter->xhv_name_count] = spot[1];
2651 iter->xhv_name_count = -(iter->xhv_name_count + 1);
2653 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2654 unshare_hek_or_pvn(*spot, 0, 0, 0);
2658 else if (flags & HV_NAME_SETALL) {
2659 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2660 spot = &iter->xhv_name_u.xhvnameu_name;
2663 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2664 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2665 iter->xhv_name_count = -2;
2666 spot = iter->xhv_name_u.xhvnameu_names;
2667 spot[1] = existing_name;
2670 else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2675 iter = hv_auxinit(hv);
2676 spot = &iter->xhv_name_u.xhvnameu_name;
2678 PERL_HASH(hash, name, len);
2679 *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2683 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2688 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2689 if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2690 if (flags & SVf_UTF8)
2691 return (bytes_cmp_utf8(
2692 (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2693 (const U8*)pv, pvlen) == 0);
2695 return (bytes_cmp_utf8(
2696 (const U8*)pv, pvlen,
2697 (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2700 return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2701 || memEQ(HEK_KEY(hek), pv, pvlen));
2705 =for apidoc hv_ename_add
2707 Adds a name to a stash's internal list of effective names. See
2708 C<L</hv_ename_delete>>.
2710 This is called when a stash is assigned to a new location in the symbol
2717 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2719 struct xpvhv_aux *aux = HvHasAUX(hv) ? HvAUX(hv) : hv_auxinit(hv);
2722 PERL_ARGS_ASSERT_HV_ENAME_ADD;
2725 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2727 PERL_HASH(hash, name, len);
2729 if (aux->xhv_name_count) {
2730 I32 count = aux->xhv_name_count;
2731 HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0);
2732 HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count);
2733 while (hekp-- > xhv_name)
2737 (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
2738 ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2739 : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2741 if (hekp == xhv_name && count < 0)
2742 aux->xhv_name_count = -count;
2746 if (count < 0) aux->xhv_name_count--, count = -count;
2747 else aux->xhv_name_count++;
2748 Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2749 (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2752 HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2755 (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2756 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2757 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2760 Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2761 aux->xhv_name_count = existing_name ? 2 : -2;
2762 *aux->xhv_name_u.xhvnameu_names = existing_name;
2763 (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2768 =for apidoc hv_ename_delete
2770 Removes a name from a stash's internal list of effective names. If this is
2771 the name returned by C<HvENAME>, then another name in the list will take
2772 its place (C<HvENAME> will use it).
2774 This is called when a stash is deleted from the symbol table.
2780 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2782 struct xpvhv_aux *aux;
2784 PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2787 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2789 if (!HvHasAUX(hv)) return;
2792 if (!aux->xhv_name_u.xhvnameu_name) return;
2794 if (aux->xhv_name_count) {
2795 HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2796 I32 const count = aux->xhv_name_count;
2797 HEK **victim = namep + (count < 0 ? -count : count);
2798 while (victim-- > namep + 1)
2800 (HEK_UTF8(*victim) || (flags & SVf_UTF8))
2801 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2802 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2804 unshare_hek_or_pvn(*victim, 0, 0, 0);
2805 if (count < 0) ++aux->xhv_name_count;
2806 else --aux->xhv_name_count;
2808 (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2810 ) { /* if there are none left */
2812 aux->xhv_name_u.xhvnameu_names = NULL;
2813 aux->xhv_name_count = 0;
2816 /* Move the last one back to fill the empty slot. It
2817 does not matter what order they are in. */
2818 *victim = *(namep + (count < 0 ? -count : count) - 1);
2823 count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8))
2824 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2825 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2828 aux->xhv_name_count = -count;
2832 (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
2833 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2834 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2835 memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2837 HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2838 Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2839 *aux->xhv_name_u.xhvnameu_names = namehek;
2840 aux->xhv_name_count = -1;
2845 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2846 PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2847 /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
2849 struct xpvhv_aux * const iter = HvHasAUX(hv) ? HvAUX(hv) : hv_auxinit(hv);
2850 return &(iter->xhv_backreferences);
2855 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2858 PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2863 av = HvAUX(hv)->xhv_backreferences;
2866 HvAUX(hv)->xhv_backreferences = 0;
2867 Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2868 if (SvTYPE(av) == SVt_PVAV)
2869 SvREFCNT_dec_NN(av);
2874 hv_iternext is implemented as a macro in hv.h
2876 =for apidoc hv_iternext
2878 Returns entries from a hash iterator. See C<L</hv_iterinit>>.
2880 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2881 iterator currently points to, without losing your place or invalidating your
2882 iterator. Note that in this case the current entry is deleted from the hash
2883 with your iterator holding the last reference to it. Your iterator is flagged
2884 to free the entry on the next call to C<hv_iternext>, so you must not discard
2885 your iterator immediately else the entry will leak - call C<hv_iternext> to
2886 trigger the resource deallocation.
2888 =for apidoc hv_iternext_flags
2890 Returns entries from a hash iterator. See C<L</hv_iterinit>> and
2892 The C<flags> value will normally be zero; if C<HV_ITERNEXT_WANTPLACEHOLDERS> is
2893 set the placeholders keys (for restricted hashes) will be returned in addition
2894 to normal keys. By default placeholders are automatically skipped over.
2895 Currently a placeholder is implemented with a value that is
2896 C<&PL_sv_placeholder>. Note that the implementation of placeholders and
2897 restricted hashes may change, and the implementation currently is
2898 insufficiently abstracted for any change to be tidy.
2900 =for apidoc Amnh||HV_ITERNEXT_WANTPLACEHOLDERS
2906 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2911 struct xpvhv_aux *iter;
2913 PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2915 if (!HvHasAUX(hv)) {
2916 /* Too many things (well, pp_each at least) merrily assume that you can
2917 call hv_iternext without calling hv_iterinit, so we'll have to deal
2921 else if (!HvARRAY(hv)) {
2922 /* Since 5.002 calling hv_iternext() has ensured that HvARRAY() is
2923 non-NULL. There was explicit code for this added as part of commit
2924 4633a7c4bad06b47, without any explicit comment as to why, but from
2925 code inspection it seems to be a fix to ensure that the later line
2926 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
2927 was accessing a valid address, because that lookup in the loop was
2928 always reached even if the hash had no keys.
2930 That explicit code was removed in 2005 as part of b79f7545f218479c:
2931 Store the xhv_aux structure after the main array.
2932 This reduces the size of HV bodies from 24 to 20 bytes on a 32 bit
2933 build. It has the side effect of defined %symbol_table:: now always
2934 being true. defined %hash is already deprecated.
2936 with a comment and assertion added to note that after the call to
2937 hv_iterinit() HvARRAY() will now always be non-NULL.
2939 In turn, that potential NULL-pointer access within the loop was made
2940 unreachable in 2009 by commit 9eb4ebd1619c0362
2941 In Perl_hv_iternext_flags(), clarify and generalise the empty hash bailout code.
2943 which skipped the entire while loop if the hash had no keys.
2944 (If the hash has any keys, HvARRAY() cannot be NULL.)
2945 Hence the code in hv_iternext_flags() has long been able to handle
2946 HvARRAY() being NULL because no keys are allocated.
2948 Now that we have decoupled the aux structure from HvARRAY(),
2949 HvARRAY() can now be NULL even when SVf_OOK is true (and the aux
2950 struct is allocated and correction initialised).
2952 Is this actually a guarantee that we need to make? We should check
2953 whether anything is actually relying on this, or if we are simply
2954 making work for ourselves.
2956 For now, keep the behaviour as-was - after calling hv_iternext_flags
2957 ensure that HvARRAY() is non-NULL. Many (other) things are changing -
2958 no need to add risk by changing this too. But in the future we should
2959 consider changing hv_iternext_flags() to avoid allocating HvARRAY()
2960 here, and potentially also we avoid allocating HvARRAY()
2961 automatically in hv_auxinit() */
2964 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
2965 HvARRAY(hv) = (HE**)array;
2970 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2971 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2972 if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2973 SV * const key = sv_newmortal();
2975 sv_setsv(key, HeSVKEY_force(entry));
2976 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2977 HeSVKEY_set(entry, NULL);
2983 /* one HE per MAGICAL hash */
2984 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2985 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2987 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2989 HeKEY_hek(entry) = hek;
2990 HeKLEN(entry) = HEf_SVKEY;
2992 magic_nextpack(MUTABLE_SV(hv),mg,key);
2994 /* force key to stay around until next time */
2995 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2996 return entry; /* beware, hent_val is not set */
2998 SvREFCNT_dec(HeVAL(entry));
2999 Safefree(HeKEY_hek(entry));
3001 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
3006 #if defined(DYNAMIC_ENV_FETCH) && defined(VMS) /* set up %ENV for iteration */
3007 if (!entry && SvRMAGICAL((const SV *)hv)
3008 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
3013 /* hv_iterinit now ensures this. */
3014 assert (HvARRAY(hv));
3016 /* At start of hash, entry is NULL. */
3019 entry = HeNEXT(entry);
3020 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
3022 * Skip past any placeholders -- don't want to include them in
3025 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
3026 entry = HeNEXT(entry);
3031 #ifdef PERL_HASH_RANDOMIZE_KEYS
3032 if (iter->xhv_last_rand != iter->xhv_rand) {
3033 if (iter->xhv_riter != -1) {
3034 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
3035 "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
3039 iter->xhv_last_rand = iter->xhv_rand;
3043 /* Skip the entire loop if the hash is empty. */
3044 if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
3045 ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
3046 STRLEN max = HvMAX(hv);
3048 /* OK. Come to the end of the current list. Grab the next one. */
3050 iter->xhv_riter++; /* HvRITER(hv)++ */
3051 if (iter->xhv_riter > (I32)max /* HvRITER(hv) > HvMAX(hv) */) {
3052 /* There is no next one. End of the hash. */
3053 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
3054 #ifdef PERL_HASH_RANDOMIZE_KEYS
3055 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
3059 entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & max ];
3061 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
3062 /* If we have an entry, but it's a placeholder, don't count it.
3064 while (entry && HeVAL(entry) == &PL_sv_placeholder)
3065 entry = HeNEXT(entry);
3067 /* Will loop again if this linked list starts NULL
3068 (for HV_ITERNEXT_WANTPLACEHOLDERS)
3069 or if we run through it and find only placeholders. */
3073 iter->xhv_riter = -1;
3074 #ifdef PERL_HASH_RANDOMIZE_KEYS
3075 iter->xhv_last_rand = iter->xhv_rand;
3079 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
3081 hv_free_ent(NULL, oldentry);
3084 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
3089 =for apidoc hv_iterkey
3091 Returns the key from the current position of the hash iterator. See
3098 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
3100 PERL_ARGS_ASSERT_HV_ITERKEY;
3102 if (HeKLEN(entry) == HEf_SVKEY) {
3104 char * const p = SvPV(HeKEY_sv(entry), len);
3109 *retlen = HeKLEN(entry);
3110 return HeKEY(entry);
3114 /* unlike hv_iterval(), this always returns a mortal copy of the key */
3116 =for apidoc hv_iterkeysv
3118 Returns the key as an C<SV*> from the current position of the hash
3119 iterator. The return value will always be a mortal copy of the key. Also
3120 see C<L</hv_iterinit>>.
3126 Perl_hv_iterkeysv(pTHX_ HE *entry)
3128 PERL_ARGS_ASSERT_HV_ITERKEYSV;
3130 return newSVhek_mortal(HeKEY_hek(entry));
3134 =for apidoc hv_iterval
3136 Returns the value from the current position of the hash iterator. See
3143 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
3145 PERL_ARGS_ASSERT_HV_ITERVAL;
3147 if (SvRMAGICAL(hv)) {
3148 if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
3149 SV* const sv = sv_newmortal();
3150 if (HeKLEN(entry) == HEf_SVKEY)
3151 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
3153 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
3157 return HeVAL(entry);
3161 =for apidoc hv_iternextsv
3163 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
3170 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
3172 HE * const he = hv_iternext_flags(hv, 0);
3174 PERL_ARGS_ASSERT_HV_ITERNEXTSV;
3178 *key = hv_iterkey(he, retlen);
3179 return hv_iterval(hv, he);
3186 =for apidoc hv_magic
3188 Adds magic to a hash. See C<L</sv_magic>>.
3190 =for apidoc unsharepvn
3192 If no one has access to shared string C<str> with length C<len>, free it.
3194 C<len> and C<hash> must both be valid for C<str>.
3200 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
3202 unshare_hek_or_pvn (NULL, str, len, hash);
3207 Perl_unshare_hek(pTHX_ HEK *hek)
3210 unshare_hek_or_pvn(hek, NULL, 0, 0);
3213 /* possibly free a shared string if no one has access to it
3214 hek if non-NULL takes priority over the other 3, else str, len and hash
3215 are used. If so, len and hash must both be valid for str.
3218 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
3222 bool is_utf8 = FALSE;
3224 const char * const save = str;
3225 struct shared_he *he = NULL;
3228 assert((HEK_FLAGS(hek) & HVhek_NOTSHARED) == 0);
3229 /* Find the shared he which is just before us in memory. */
3230 he = (struct shared_he *)(((char *)hek)
3231 - STRUCT_OFFSET(struct shared_he,
3234 /* Assert that the caller passed us a genuine (or at least consistent)
3236 assert (he->shared_he_he.hent_hek == hek);
3238 if (he->shared_he_he.he_valu.hent_refcount - 1) {
3239 --he->shared_he_he.he_valu.hent_refcount;
3243 hash = HEK_HASH(hek);
3244 } else if (len < 0) {
3245 STRLEN tmplen = -len;
3247 /* See the note in hv_fetch(). --jhi */
3248 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
3251 k_flags = HVhek_UTF8;
3253 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
3256 /* what follows was the moral equivalent of:
3257 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
3259 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
3262 /* assert(xhv_array != 0) */
3263 oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
3265 const HE *const he_he = &(he->shared_he_he);
3266 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
3271 const U8 flags_masked = k_flags & HVhek_STORAGE_MASK;
3272 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
3273 if (HeHASH(entry) != hash) /* strings can't be equal */
3275 if (HeKLEN(entry) != len)
3277 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
3279 if (HeKFLAGS(entry) != flags_masked)
3286 if (--entry->he_valu.hent_refcount == 0) {
3287 *oentry = HeNEXT(entry);
3289 HvTOTALKEYS(PL_strtab)--;
3294 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
3295 "Attempt to free nonexistent shared string '%s'%s"
3297 hek ? HEK_KEY(hek) : str,
3298 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
3299 if (k_flags & HVhek_FREEKEY)
3303 /* get a (constant) string ptr from the global string table
3304 * string will get added if it is not already there.
3305 * len and hash must both be valid for str.
3308 Perl_share_hek(pTHX_ const char *str, SSize_t len, U32 hash)
3310 bool is_utf8 = FALSE;
3312 const char * const save = str;
3314 PERL_ARGS_ASSERT_SHARE_HEK;
3317 STRLEN tmplen = -len;
3319 /* See the note in hv_fetch(). --jhi */
3320 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
3322 /* If we were able to downgrade here, then than means that we were passed
3323 in a key which only had chars 0-255, but was utf8 encoded. */
3326 /* If we found we were able to downgrade the string to bytes, then
3327 we should flag that it needs upgrading on keys or each. Also flag
3328 that we need share_hek_flags to free the string. */
3330 PERL_HASH(hash, str, len);
3331 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
3335 return share_hek_flags (str, len, hash, flags);
3339 S_share_hek_flags(pTHX_ const char *str, STRLEN len, U32 hash, int flags)
3342 const U8 flags_masked = flags & HVhek_STORAGE_MASK;
3343 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
3345 PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
3346 assert(!(flags & HVhek_NOTSHARED));
3348 if (UNLIKELY(len > (STRLEN) I32_MAX)) {
3349 Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes");
3352 /* what follows is the moral equivalent of:
3354 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
3355 hv_store(PL_strtab, str, len, NULL, hash);
3357 Can't rehash the shared string table, so not sure if it's worth
3358 counting the number of entries in the linked list
3361 /* assert(xhv_array != 0) */
3362 entry = (HvARRAY(PL_strtab))[hindex];
3363 for (;entry; entry = HeNEXT(entry)) {
3364 if (HeHASH(entry) != hash) /* strings can't be equal */
3366 if (HeKLEN(entry) != (SSize_t) len)
3368 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
3370 if (HeKFLAGS(entry) != flags_masked)
3376 /* What used to be head of the list.
3377 If this is NULL, then we're the first entry for this slot, which
3378 means we need to increase fill. */
3379 struct shared_he *new_entry;
3382 HE **const head = &HvARRAY(PL_strtab)[hindex];
3383 HE *const next = *head;
3384 XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
3386 /* We don't actually store a HE from the arena and a regular HEK.
3387 Instead we allocate one chunk of memory big enough for both,
3388 and put the HEK straight after the HE. This way we can find the
3389 HE directly from the HEK.
3392 Newx(k, STRUCT_OFFSET(struct shared_he,
3393 shared_he_hek.hek_key[0]) + len + 2, char);
3394 new_entry = (struct shared_he *)k;
3395 entry = &(new_entry->shared_he_he);
3396 hek = &(new_entry->shared_he_hek);
3398 Copy(str, HEK_KEY(hek), len, char);
3399 HEK_KEY(hek)[len] = 0;
3401 HEK_HASH(hek) = hash;
3402 HEK_FLAGS(hek) = (unsigned char)flags_masked;
3404 /* Still "point" to the HEK, so that other code need not know what
3406 HeKEY_hek(entry) = hek;
3407 entry->he_valu.hent_refcount = 0;
3408 HeNEXT(entry) = next;
3411 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
3412 if (!next) { /* initial entry? */
3413 } else if ( DO_HSPLIT(xhv) ) {
3414 const STRLEN oldsize = xhv->xhv_max + 1;
3415 hsplit(PL_strtab, oldsize, oldsize * 2);
3419 ++entry->he_valu.hent_refcount;
3421 if (flags & HVhek_FREEKEY)
3424 return HeKEY_hek(entry);
3428 Perl_hv_placeholders_p(pTHX_ HV *hv)
3430 MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3432 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
3435 mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
3438 Perl_die(aTHX_ "panic: hv_placeholders_p");
3441 return &(mg->mg_len);
3445 =for apidoc hv_placeholders_get
3447 Implements C<HvPLACEHOLDERS_get>, which you should use instead.
3453 Perl_hv_placeholders_get(pTHX_ const HV *hv)
3455 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3457 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3458 PERL_UNUSED_CONTEXT;
3460 return mg ? mg->mg_len : 0;
3464 =for apidoc hv_placeholders_set
3466 Implements C<HvPLACEHOLDERS_set>, which you should use instead.
3472 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3474 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3476 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3481 if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3482 Perl_die(aTHX_ "panic: hv_placeholders_set");
3484 /* else we don't need to add magic to record 0 placeholders. */
3488 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3492 PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3494 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3496 value = newSV_type(SVt_NULL);
3499 value = &PL_sv_placeholder;
3502 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3505 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3508 case HVrhek_PV_UTF8:
3509 /* Create a string SV that directly points to the bytes in our
3511 value = newSV_type(SVt_PV);
3512 SvPV_set(value, (char *) he->refcounted_he_data + 1);
3513 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3514 /* This stops anything trying to free it */
3515 SvLEN_set(value, 0);
3517 SvREADONLY_on(value);
3518 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3522 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf,
3523 (UV)he->refcounted_he_data[0]);
3529 =for apidoc refcounted_he_chain_2hv
3531 Generates and returns a C<HV *> representing the content of a
3532 C<refcounted_he> chain.
3533 C<flags> is currently unused and must be zero.
3538 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3541 U32 placeholders, max;
3544 Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf,
3547 /* We could chase the chain once to get an idea of the number of keys,
3548 and call ksplit. But for now we'll make a potentially inefficient
3549 hash with only 8 entries in its array. */
3551 #ifdef NODEFAULT_SHAREKEYS
3552 /* We share keys in the COP, so it's much easier to keep sharing keys in
3553 the hash we build from it. */
3559 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3560 HvARRAY(hv) = (HE**)array;
3566 U32 hash = chain->refcounted_he_hash;
3568 U32 hash = HEK_HASH(chain->refcounted_he_hek);
3570 HE **oentry = &((HvARRAY(hv))[hash & max]);
3571 HE *entry = *oentry;
3574 for (; entry; entry = HeNEXT(entry)) {
3575 if (HeHASH(entry) == hash) {
3576 /* We might have a duplicate key here. If so, entry is older
3577 than the key we've already put in the hash, so if they are
3578 the same, skip adding entry. */
3580 const STRLEN klen = HeKLEN(entry);
3581 const char *const key = HeKEY(entry);
3582 if (klen == chain->refcounted_he_keylen
3583 && (cBOOL(HeKUTF8(entry))
3584 == cBOOL((chain->refcounted_he_data[0] & HVhek_UTF8)))
3585 && memEQ(key, REF_HE_KEY(chain), klen))
3588 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3590 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3591 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3592 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3603 = share_hek_flags(REF_HE_KEY(chain),
3604 chain->refcounted_he_keylen,
3605 chain->refcounted_he_hash,
3606 (chain->refcounted_he_data[0]
3607 & (HVhek_UTF8|HVhek_WASUTF8)));
3609 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3611 value = refcounted_he_value(chain);
3612 if (value == &PL_sv_placeholder)
3614 HeVAL(entry) = value;
3616 /* Link it into the chain. */
3617 HeNEXT(entry) = *oentry;
3623 chain = chain->refcounted_he_next;
3627 clear_placeholders(hv, placeholders);
3630 /* We could check in the loop to see if we encounter any keys with key
3631 flags, but it's probably not worth it, as this per-hash flag is only
3632 really meant as an optimisation for things like Storable. */
3634 DEBUG_A(Perl_hv_assert(aTHX_ hv));
3640 =for apidoc refcounted_he_fetch_pvn
3642 Search along a C<refcounted_he> chain for an entry with the key specified
3643 by C<keypv> and C<keylen>. If C<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3644 bit set, the key octets are interpreted as UTF-8, otherwise they
3645 are interpreted as Latin-1. C<hash> is a precomputed hash of the key
3646 string, or zero if it has not been precomputed. Returns a mortal scalar
3647 representing the value associated with the key, or C<&PL_sv_placeholder>
3648 if there is no value associated with the key.
3654 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3655 const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3658 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3660 if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3661 Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf,
3665 if (flags & REFCOUNTED_HE_KEY_UTF8) {
3666 /* For searching purposes, canonicalise to Latin-1 where possible. */
3667 const char *keyend = keypv + keylen, *p;
3668 STRLEN nonascii_count = 0;
3669 for (p = keypv; p != keyend; p++) {
3670 if (! UTF8_IS_INVARIANT(*p)) {
3671 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3672 goto canonicalised_key;
3678 if (nonascii_count) {
3680 const char *p = keypv, *keyend = keypv + keylen;
3681 keylen -= nonascii_count;
3682 Newx(q, keylen, char);
3685 for (; p != keyend; p++, q++) {
3687 if (UTF8_IS_INVARIANT(c)) {
3692 *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3696 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3697 canonicalised_key: ;
3699 utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3701 PERL_HASH(hash, keypv, keylen);
3703 for (; chain; chain = chain->refcounted_he_next) {
3706 hash == chain->refcounted_he_hash &&
3707 keylen == chain->refcounted_he_keylen &&
3708 memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3709 utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3711 hash == HEK_HASH(chain->refcounted_he_hek) &&
3712 keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3713 memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3714 utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3717 if (flags & REFCOUNTED_HE_EXISTS)
3718 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3720 ? NULL : &PL_sv_yes;
3721 return sv_2mortal(refcounted_he_value(chain));
3725 return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3729 =for apidoc refcounted_he_fetch_pv
3731 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3732 instead of a string/length pair.
3738 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3739 const char *key, U32 hash, U32 flags)
3741 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3742 return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3746 =for apidoc refcounted_he_fetch_sv
3748 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3755 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3756 SV *key, U32 hash, U32 flags)
3760 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3761 if (flags & REFCOUNTED_HE_KEY_UTF8)
3762 Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf,
3764 keypv = SvPV_const(key, keylen);
3766 flags |= REFCOUNTED_HE_KEY_UTF8;
3767 if (!hash && SvIsCOW_shared_hash(key))
3768 hash = SvSHARED_HASH(key);
3769 return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3773 =for apidoc refcounted_he_new_pvn
3775 Creates a new C<refcounted_he>. This consists of a single key/value
3776 pair and a reference to an existing C<refcounted_he> chain (which may
3777 be empty), and thus forms a longer chain. When using the longer chain,
3778 the new key/value pair takes precedence over any entry for the same key
3779 further along the chain.
3781 The new key is specified by C<keypv> and C<keylen>. If C<flags> has
3782 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3783 as UTF-8, otherwise they are interpreted as Latin-1. C<hash> is
3784 a precomputed hash of the key string, or zero if it has not been
3787 C<value> is the scalar value to store for this key. C<value> is copied
3788 by this function, which thus does not take ownership of any reference
3789 to it, and later changes to the scalar will not be reflected in the
3790 value visible in the C<refcounted_he>. Complex types of scalar will not
3791 be stored with referential integrity, but will be coerced to strings.
3792 C<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3793 value is to be associated with the key; this, as with any non-null value,
3794 takes precedence over the existence of a value for the key further along
3797 C<parent> points to the rest of the C<refcounted_he> chain to be
3798 attached to the new C<refcounted_he>. This function takes ownership
3799 of one reference to C<parent>, and returns one reference to the new
3805 struct refcounted_he *
3806 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3807 const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3809 STRLEN value_len = 0;
3810 const char *value_p = NULL;
3814 STRLEN key_offset = 1;
3815 struct refcounted_he *he;
3816 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3818 if (!value || value == &PL_sv_placeholder) {
3819 value_type = HVrhek_delete;
3820 } else if (SvPOK(value)) {
3821 value_type = HVrhek_PV;
3822 } else if (SvIOK(value)) {
3823 value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3824 } else if (!SvOK(value)) {
3825 value_type = HVrhek_undef;
3827 value_type = HVrhek_PV;
3829 is_pv = value_type == HVrhek_PV;
3831 /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3832 the value is overloaded, and doesn't yet have the UTF-8flag set. */
3833 value_p = SvPV_const(value, value_len);
3835 value_type = HVrhek_PV_UTF8;
3836 key_offset = value_len + 2;
3838 hekflags = value_type;
3840 if (flags & REFCOUNTED_HE_KEY_UTF8) {
3841 /* Canonicalise to Latin-1 where possible. */
3842 const char *keyend = keypv + keylen, *p;
3843 STRLEN nonascii_count = 0;
3844 for (p = keypv; p != keyend; p++) {
3845 if (! UTF8_IS_INVARIANT(*p)) {
3846 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3847 goto canonicalised_key;
3853 if (nonascii_count) {
3855 const char *p = keypv, *keyend = keypv + keylen;
3856 keylen -= nonascii_count;
3857 Newx(q, keylen, char);
3860 for (; p != keyend; p++, q++) {
3862 if (UTF8_IS_INVARIANT(c)) {
3867 *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3871 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3872 canonicalised_key: ;
3874 if (flags & REFCOUNTED_HE_KEY_UTF8)
3875 hekflags |= HVhek_UTF8;
3877 PERL_HASH(hash, keypv, keylen);
3880 he = (struct refcounted_he*)
3881 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3885 he = (struct refcounted_he*)
3886 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3890 he->refcounted_he_next = parent;
3893 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3894 he->refcounted_he_val.refcounted_he_u_len = value_len;
3895 } else if (value_type == HVrhek_IV) {
3896 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3897 } else if (value_type == HVrhek_UV) {
3898 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3902 he->refcounted_he_hash = hash;
3903 he->refcounted_he_keylen = keylen;
3904 Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3906 he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3909 he->refcounted_he_data[0] = hekflags;
3910 he->refcounted_he_refcnt = 1;
3916 =for apidoc refcounted_he_new_pv
3918 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3919 of a string/length pair.
3924 struct refcounted_he *
3925 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3926 const char *key, U32 hash, SV *value, U32 flags)
3928 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3929 return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3933 =for apidoc refcounted_he_new_sv
3935 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3941 struct refcounted_he *
3942 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3943 SV *key, U32 hash, SV *value, U32 flags)
3947 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3948 if (flags & REFCOUNTED_HE_KEY_UTF8)
3949 Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf,
3951 keypv = SvPV_const(key, keylen);
3953 flags |= REFCOUNTED_HE_KEY_UTF8;
3954 if (!hash && SvIsCOW_shared_hash(key))
3955 hash = SvSHARED_HASH(key);
3956 return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3960 =for apidoc refcounted_he_free
3962 Decrements the reference count of a C<refcounted_he> by one. If the
3963 reference count reaches zero the structure's memory is freed, which
3964 (recursively) causes a reduction of its parent C<refcounted_he>'s
3965 reference count. It is safe to pass a null pointer to this function:
3966 no action occurs in this case.
3972 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3973 PERL_UNUSED_CONTEXT;
3976 struct refcounted_he *copy;
3980 new_count = --he->refcounted_he_refcnt;
3981 HINTS_REFCNT_UNLOCK;
3987 #ifndef USE_ITHREADS
3988 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3991 he = he->refcounted_he_next;
3992 PerlMemShared_free(copy);
3997 =for apidoc refcounted_he_inc
3999 Increment the reference count of a C<refcounted_he>. The pointer to the
4000 C<refcounted_he> is also returned. It is safe to pass a null pointer
4001 to this function: no action occurs and a null pointer is returned.
4006 struct refcounted_he *
4007 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
4009 PERL_UNUSED_CONTEXT;
4012 he->refcounted_he_refcnt++;
4013 HINTS_REFCNT_UNLOCK;
4019 =for apidoc_section $COP
4020 =for apidoc cop_fetch_label
4022 Returns the label attached to a cop, and stores its length in bytes into
4024 Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0.
4026 Alternatively, use the macro C<L</CopLABEL_len_flags>>;
4027 or if you don't need to know if the label is UTF-8 or not, the macro
4028 C<L</CopLABEL_len>>;
4029 or if you additionally don't need to know the length, C<L</CopLABEL>>.
4034 /* pp_entereval is aware that labels are stored with a key ':' at the top of
4037 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
4038 struct refcounted_he *const chain = cop->cop_hints_hash;
4040 PERL_ARGS_ASSERT_COP_FETCH_LABEL;
4041 PERL_UNUSED_CONTEXT;
4046 if (chain->refcounted_he_keylen != 1)
4048 if (*REF_HE_KEY(chain) != ':')
4051 if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
4053 if (*HEK_KEY(chain->refcounted_he_hek) != ':')
4056 /* Stop anyone trying to really mess us up by adding their own value for
4058 if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
4059 && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
4063 *len = chain->refcounted_he_val.refcounted_he_u_len;
4065 *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
4066 == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
4068 return chain->refcounted_he_data + 1;
4072 =for apidoc cop_store_label
4074 Save a label into a C<cop_hints_hash>.
4075 You need to set flags to C<SVf_UTF8>
4076 for a UTF-8 label. Any other flag is ignored.
4082 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
4086 PERL_ARGS_ASSERT_COP_STORE_LABEL;
4088 if (flags & ~(SVf_UTF8))
4089 Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
4091 labelsv = newSVpvn_flags(label, len, SVs_TEMP);
4092 if (flags & SVf_UTF8)
4095 = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
4099 =for apidoc_section $HV
4100 =for apidoc hv_assert
4102 Check that a hash is in an internally consistent state.
4110 Perl_hv_assert(pTHX_ HV *hv)
4114 int placeholders = 0;
4117 const I32 riter = HvRITER_get(hv);
4118 HE *eiter = HvEITER_get(hv);
4120 PERL_ARGS_ASSERT_HV_ASSERT;
4122 (void)hv_iterinit(hv);
4124 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
4125 /* sanity check the values */
4126 if (HeVAL(entry) == &PL_sv_placeholder)
4130 /* sanity check the keys */
4131 if (HeSVKEY(entry)) {
4132 NOOP; /* Don't know what to check on SV keys. */
4133 } else if (HeKUTF8(entry)) {
4135 if (HeKWASUTF8(entry)) {
4136 PerlIO_printf(Perl_debug_log,
4137 "hash key has both WASUTF8 and UTF8: '%.*s'\n",
4138 (int) HeKLEN(entry), HeKEY(entry));
4141 } else if (HeKWASUTF8(entry))
4144 if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
4145 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
4146 const int nhashkeys = HvUSEDKEYS(hv);
4147 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
4149 if (nhashkeys != real) {
4150 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
4153 if (nhashplaceholders != placeholders) {
4154 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
4158 if (withflags && ! HvHASKFLAGS(hv)) {
4159 PerlIO_printf(Perl_debug_log,
4160 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
4165 sv_dump(MUTABLE_SV(hv));
4167 HvRITER_set(hv, riter); /* Restore hash iterator state */
4168 HvEITER_set(hv, eiter);
4174 * ex: set ts=8 sts=4 sw=4 et: