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;
483 if (SvTYPE(hv) == (svtype)SVTYPEMASK)
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 upercase 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)
1156 PERL_ARGS_ASSERT_HV_PUSHKV;
1157 assert(flags); /* must be pushing at least one of keys and values */
1159 (void)hv_iterinit(hv);
1162 SSize_t ext = (flags == 3) ? 2 : 1;
1163 while ((entry = hv_iternext(hv))) {
1166 PUSHs(hv_iterkeysv(entry));
1168 PUSHs(hv_iterval(hv, entry));
1172 Size_t nkeys = HvUSEDKEYS(hv);
1178 /* 2*nkeys() should never be big enough to truncate or wrap */
1179 assert(nkeys <= (SSize_t_MAX >> 1));
1180 ext = nkeys * ((flags == 3) ? 2 : 1);
1182 EXTEND_MORTAL(nkeys);
1185 while ((entry = hv_iternext(hv))) {
1187 SV *keysv = newSVhek(HeKEY_hek(entry));
1189 PL_tmps_stack[++PL_tmps_ix] = keysv;
1193 PUSHs(HeVAL(entry));
1202 =for apidoc hv_bucket_ratio
1204 If the hash is tied dispatches through to the SCALAR tied method,
1205 otherwise if the hash contains no keys returns 0, otherwise returns
1206 a mortal sv containing a string specifying the number of used buckets,
1207 followed by a slash, followed by the number of available buckets.
1209 This function is expensive, it must scan all of the buckets
1210 to determine which are used, and the count is NOT cached.
1211 In a large hash this could be a lot of buckets.
1217 Perl_hv_bucket_ratio(pTHX_ HV *hv)
1221 PERL_ARGS_ASSERT_HV_BUCKET_RATIO;
1223 if (SvRMAGICAL(hv)) {
1224 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
1226 return magic_scalarpack(hv, mg);
1229 if (HvUSEDKEYS((HV *)hv)) {
1230 sv = sv_newmortal();
1231 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
1232 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
1241 =for apidoc hv_delete
1243 Deletes a key/value pair in the hash. The value's SV is removed from
1244 the hash, made mortal, and returned to the caller. The absolute
1245 value of C<klen> is the length of the key. If C<klen> is negative the
1246 key is assumed to be in UTF-8-encoded Unicode. The C<flags> value
1247 will normally be zero; if set to C<G_DISCARD> then C<NULL> will be returned.
1248 C<NULL> will also be returned if the key is not found.
1250 =for apidoc hv_delete_ent
1252 Deletes a key/value pair in the hash. The value SV is removed from the hash,
1253 made mortal, and returned to the caller. The C<flags> value will normally be
1254 zero; if set to C<G_DISCARD> then C<NULL> will be returned. C<NULL> will also
1255 be returned if the key is not found. C<hash> can be a valid precomputed hash
1256 value, or 0 to ask for it to be computed.
1262 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
1263 int k_flags, I32 d_flags, U32 hash)
1269 bool is_utf8 = cBOOL(k_flags & HVhek_UTF8);
1270 HEK *keysv_hek = NULL;
1271 U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
1276 if (SvMAGICAL(hv)) {
1279 hv_magic_check (hv, &needs_copy, &needs_store);
1283 entry = (HE *) hv_common(hv, keysv, key, klen,
1284 k_flags & ~HVhek_FREEKEY,
1285 HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
1287 sv = entry ? HeVAL(entry) : NULL;
1289 if (SvMAGICAL(sv)) {
1293 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1294 /* No longer an element */
1295 sv_unmagic(sv, PERL_MAGIC_tiedelem);
1298 return NULL; /* element cannot be deleted */
1300 #ifdef ENV_IS_CASELESS
1301 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
1302 /* XXX This code isn't UTF8 clean. */
1303 keysv = newSVpvn_flags(key, klen, SVs_TEMP);
1304 if (k_flags & HVhek_FREEKEY) {
1307 key = strupr(SvPVX(keysv));
1316 xhv = (XPVHV*)SvANY(hv);
1317 if (!HvTOTALKEYS(hv))
1320 if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
1321 const char * const keysave = key;
1322 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1325 k_flags |= HVhek_UTF8;
1327 k_flags &= ~HVhek_UTF8;
1328 if (key != keysave) {
1329 if (k_flags & HVhek_FREEKEY) {
1330 /* This shouldn't happen if our caller does what we expect,
1331 but strictly the API allows it. */
1334 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1338 if (keysv && (SvIsCOW_shared_hash(keysv))) {
1339 if (HvSHAREKEYS(hv))
1340 keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
1341 hash = SvSHARED_HASH(keysv);
1344 PERL_HASH(hash, key, klen);
1346 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1353 /* keysv is actually a HEK in disguise, so we can match just by
1354 * comparing the HEK pointers in the HE chain. There is a slight
1355 * caveat: on something like "\x80", which has both plain and utf8
1356 * representations, perl's hashes do encoding-insensitive lookups,
1357 * but preserve the encoding of the stored key. Thus a particular
1358 * key could map to two different HEKs in PL_strtab. We only
1359 * conclude 'not found' if all the flags are the same; otherwise
1360 * we fall back to a full search (this should only happen in rare
1363 int keysv_flags = HEK_FLAGS(keysv_hek);
1365 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1366 HEK *hek = HeKEY_hek(entry);
1367 if (hek == keysv_hek)
1369 if (HEK_FLAGS(hek) != keysv_flags)
1370 break; /* need to do full match */
1374 /* failed on shortcut - do full search loop */
1375 oentry = first_entry;
1379 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1380 if (HeHASH(entry) != hash) /* strings can't be equal */
1382 if (HeKLEN(entry) != (I32)klen)
1384 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
1386 if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8)
1390 if (hv == PL_strtab) {
1391 if (k_flags & HVhek_FREEKEY)
1393 Perl_croak(aTHX_ S_strtab_error, "delete");
1398 /* if placeholder is here, it's already been deleted.... */
1399 if (sv == &PL_sv_placeholder) {
1400 if (k_flags & HVhek_FREEKEY)
1404 if (SvREADONLY(hv) && sv && SvREADONLY(sv)) {
1405 hv_notallowed(k_flags, key, klen,
1406 "Attempt to delete readonly key '%" SVf "' from"
1407 " a restricted hash");
1411 * If a restricted hash, rather than really deleting the entry, put
1412 * a placeholder there. This marks the key as being "approved", so
1413 * we can still access via not-really-existing key without raising
1416 if (SvREADONLY(hv)) {
1417 /* We'll be saving this slot, so the number of allocated keys
1418 * doesn't go down, but the number placeholders goes up */
1419 HeVAL(entry) = &PL_sv_placeholder;
1420 HvPLACEHOLDERS(hv)++;
1423 HeVAL(entry) = NULL;
1424 *oentry = HeNEXT(entry);
1425 if (HvHasAUX(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) {
1429 if (HvHasAUX(hv) && HvLAZYDEL(hv) &&
1430 entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1431 HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1432 hv_free_ent(NULL, entry);
1434 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1435 if (xhv->xhv_keys == 0)
1436 HvHASKFLAGS_off(hv);
1439 /* If this is a stash and the key ends with ::, then someone is
1440 * deleting a package.
1442 if (sv && SvTYPE(sv) == SVt_PVGV && HvENAME_get(hv)) {
1445 (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1447 (klen == 1 && key[0] == ':')
1449 && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1450 && (stash = GvHV((GV *)gv))
1451 && HvENAME_get(stash)) {
1452 /* A previous version of this code checked that the
1453 * GV was still in the symbol table by fetching the
1454 * GV with its name. That is not necessary (and
1455 * sometimes incorrect), as HvENAME cannot be set
1456 * on hv if it is not in the symtab. */
1458 /* Hang on to it for a bit. */
1459 SvREFCNT_inc_simple_void_NN(
1460 sv_2mortal((SV *)gv)
1463 else if (memEQs(key, klen, "ISA") && GvAV(gv)) {
1465 MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa);
1469 if (mg->mg_obj == (SV*)gv) {
1470 /* This is the only stash this ISA was used for.
1471 * The isaelem magic asserts if there's no
1472 * isa magic on the array, so explicitly
1473 * remove the magic on both the array and its
1474 * elements. @ISA shouldn't be /too/ large.
1480 end = svp + (AvFILLp(isa)+1);
1483 mg_free_type(*svp, PERL_MAGIC_isaelem);
1487 mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
1490 /* mg_obj is an array of stashes
1491 Note that the array doesn't keep a reference
1492 count on the stashes.
1494 AV *av = (AV*)mg->mg_obj;
1499 assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
1501 /* remove the stash from the magic array */
1502 arrayp = svp = AvARRAY(av);
1503 items = AvFILLp(av) + 1;
1505 assert(*arrayp == (SV *)gv);
1507 /* avoid a double free on the last stash */
1509 /* The magic isn't MGf_REFCOUNTED, so release
1510 * the array manually.
1512 SvREFCNT_dec_NN(av);
1517 if (*svp == (SV*)gv)
1521 index = svp - arrayp;
1522 assert(index >= 0 && index <= AvFILLp(av));
1523 if (index < AvFILLp(av)) {
1524 arrayp[index] = arrayp[AvFILLp(av)];
1526 arrayp[AvFILLp(av)] = NULL;
1534 if (k_flags & HVhek_FREEKEY)
1538 /* deletion of method from stash */
1539 if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1541 mro_method_changed_in(hv);
1543 if (d_flags & G_DISCARD) {
1552 if (mro_changes == 1) mro_isa_changed_in(hv);
1553 else if (mro_changes == 2)
1554 mro_package_moved(NULL, stash, gv, 1);
1560 if (SvREADONLY(hv)) {
1561 hv_notallowed(k_flags, key, klen,
1562 "Attempt to delete disallowed key '%" SVf "' from"
1563 " a restricted hash");
1566 if (k_flags & HVhek_FREEKEY)
1571 /* HVs are used for (at least) three things
1574 3) associative arrays
1576 shared hash keys benefit the first two greatly, because keys are likely
1577 to be re-used between objects, or for constants in the optree
1579 However, for large associative arrays (lookup tables, "seen" hashes) keys are
1580 unlikely to be re-used. Hence having those keys in the shared string table as
1581 well as the hash is a memory hit, if they are never actually shared with a
1582 second hash. Hence we turn off shared hash keys if a (regular) hash gets
1585 This is a heuristic. There might be a better answer than 42, but for now
1588 NOTE: Configure with -Accflags='-DPERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES'
1589 to enable this new functionality.
1592 #ifdef PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES
1594 S_large_hash_heuristic(pTHX_ HV *hv, STRLEN size) {
1597 && !(HvHasAUX(hv) && HvENAME_get(hv))) {
1598 /* This hash appears to be growing quite large.
1599 We gamble that it is not sharing keys with other hashes. */
1607 S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1610 char *a = (char*) HvARRAY(hv);
1613 PERL_ARGS_ASSERT_HSPLIT;
1614 if (newsize > MAX_BUCKET_MAX+1)
1618 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1624 #ifdef PERL_HASH_RANDOMIZE_KEYS
1625 /* the idea of this is that we create a "random" value by hashing the address of
1626 * the array, we then use the low bit to decide if we insert at the top, or insert
1627 * second from top. After each such insert we rotate the hashed value. So we can
1628 * use the same hashed value over and over, and in normal build environments use
1629 * very few ops to do so. ROTL32() should produce a single machine operation. */
1630 MAYBE_UPDATE_HASH_RAND_BITS();
1632 HvARRAY(hv) = (HE**) a;
1633 HvMAX(hv) = newsize - 1;
1634 /* now we can safely clear the second half */
1635 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1637 if (!HvTOTALKEYS(hv)) /* skip rest if no entries */
1640 /* don't share keys in large simple hashes */
1641 if (LARGE_HASH_HEURISTIC(hv, HvTOTALKEYS(hv)))
1642 HvSHAREKEYS_off(hv);
1648 HE **oentry = aep + i;
1651 if (!entry) /* non-existent */
1654 U32 j = (HeHASH(entry) & newsize);
1656 *oentry = HeNEXT(entry);
1657 #ifdef PERL_HASH_RANDOMIZE_KEYS
1658 /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
1659 * insert to top, otherwise rotate the bucket rand 1 bit,
1660 * and use the new low bit to decide if we insert at top,
1661 * or next from top. IOW, we only rotate on a collision.*/
1662 if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
1663 UPDATE_HASH_RAND_BITS();
1664 if (PL_hash_rand_bits & 1) {
1665 HeNEXT(entry)= HeNEXT(aep[j]);
1666 HeNEXT(aep[j])= entry;
1668 /* Note, this is structured in such a way as the optimizer
1669 * should eliminate the duplicated code here and below without
1670 * us needing to explicitly use a goto. */
1671 HeNEXT(entry) = aep[j];
1677 /* see comment above about duplicated code */
1678 HeNEXT(entry) = aep[j];
1683 oentry = &HeNEXT(entry);
1687 } while (i++ < oldsize);
1691 =for apidoc hv_ksplit
1693 Attempt to grow the hash C<hv> so it has at least C<newmax> buckets available.
1694 Perl chooses the actual number for its convenience.
1696 This is the same as doing the following in Perl code:
1704 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1706 XPVHV* xhv = (XPVHV*)SvANY(hv);
1707 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 */
1713 PERL_ARGS_ASSERT_HV_KSPLIT;
1715 wantsize = (I32) newmax; /* possible truncation here */
1716 if (wantsize != newmax)
1719 wantsize= wantsize + (wantsize >> 1); /* wantsize *= 1.5 */
1720 if (wantsize < newmax) /* overflow detection */
1724 while (wantsize > newsize) {
1725 trysize = newsize << 1;
1726 if (trysize > newsize) {
1734 if (newsize <= oldsize)
1735 return; /* overflow detection */
1737 a = (char *) HvARRAY(hv);
1739 #ifdef PERL_HASH_RANDOMIZE_KEYS
1740 U32 was_ook = HvHasAUX(hv);
1742 hsplit(hv, oldsize, newsize);
1743 #ifdef PERL_HASH_RANDOMIZE_KEYS
1744 if (was_ook && HvHasAUX(hv) && HvTOTALKEYS(hv)) {
1745 MAYBE_UPDATE_HASH_RAND_BITS();
1746 HvAUX(hv)->xhv_rand = (U32)PL_hash_rand_bits;
1750 if (LARGE_HASH_HEURISTIC(hv, newmax))
1751 HvSHAREKEYS_off(hv);
1752 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1753 xhv->xhv_max = newsize - 1;
1754 HvARRAY(hv) = (HE **) a;
1758 /* IMO this should also handle cases where hv_max is smaller than hv_keys
1759 * as tied hashes could play silly buggers and mess us around. We will
1760 * do the right thing during hv_store() afterwards, but still - Yves */
1761 #define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
1762 /* Can we use fewer buckets? (hv_max is always 2^n-1) */ \
1763 if (hv_max < PERL_HASH_DEFAULT_HvMAX) { \
1764 hv_max = PERL_HASH_DEFAULT_HvMAX; \
1766 while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
1767 hv_max = hv_max / 2; \
1769 HvMAX(hv) = hv_max; \
1776 The content of C<ohv> is copied to a new hash. A pointer to the new hash is
1783 Perl_newHVhv(pTHX_ HV *ohv)
1785 HV * const hv = newHV();
1788 if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
1790 hv_max = HvMAX(ohv);
1792 if (!SvMAGICAL((const SV *)ohv)) {
1793 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1795 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1797 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1800 if (HvSHAREKEYS(ohv)) {
1801 #ifdef NODEFAULT_SHAREKEYS
1804 /* Shared is the default - it should have been set by newHV(). */
1805 assert(HvSHAREKEYS(hv));
1809 HvSHAREKEYS_off(hv);
1812 /* In each bucket... */
1813 for (i = 0; i <= hv_max; i++) {
1815 HE *oent = oents[i];
1822 /* Copy the linked list of entries. */
1823 for (; oent; oent = HeNEXT(oent)) {
1824 HE * const ent = new_HE();
1825 SV *const val = HeVAL(oent);
1826 const int flags = HeKFLAGS(oent);
1828 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1829 if ((flags & HVhek_NOTSHARED) == 0) {
1830 HeKEY_hek(ent) = share_hek_hek(HeKEY_hek(oent));
1833 const U32 hash = HeHASH(oent);
1834 const char * const key = HeKEY(oent);
1835 const STRLEN len = HeKLEN(oent);
1836 HeKEY_hek(ent) = save_hek_flags(key, len, hash, flags);
1848 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1852 /* Iterate over ohv, copying keys and values one at a time. */
1854 const I32 riter = HvRITER_get(ohv);
1855 HE * const eiter = HvEITER_get(ohv);
1856 STRLEN hv_keys = HvTOTALKEYS(ohv);
1858 HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1861 while ((entry = hv_iternext_flags(ohv, 0))) {
1862 SV *val = hv_iterval(ohv,entry);
1863 SV * const keysv = HeSVKEY(entry);
1864 val = SvIMMORTAL(val) ? val : newSVsv(val);
1866 (void)hv_store_ent(hv, keysv, val, 0);
1868 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1869 HeHASH(entry), HeKFLAGS(entry));
1871 HvRITER_set(ohv, riter);
1872 HvEITER_set(ohv, eiter);
1879 =for apidoc hv_copy_hints_hv
1881 A specialised version of L</newHVhv> for copying C<%^H>. C<ohv> must be
1882 a pointer to a hash (which may have C<%^H> magic, but should be generally
1883 non-magical), or C<NULL> (interpreted as an empty hash). The content
1884 of C<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1885 added to it. A pointer to the new hash is returned.
1891 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1893 HV * const hv = newHV();
1896 STRLEN hv_max = HvMAX(ohv);
1897 STRLEN hv_keys = HvTOTALKEYS(ohv);
1899 const I32 riter = HvRITER_get(ohv);
1900 HE * const eiter = HvEITER_get(ohv);
1905 HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1908 while ((entry = hv_iternext_flags(ohv, 0))) {
1909 SV *const sv = newSVsv(hv_iterval(ohv,entry));
1910 SV *heksv = HeSVKEY(entry);
1911 if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1912 if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1913 (char *)heksv, HEf_SVKEY);
1914 if (heksv == HeSVKEY(entry))
1915 (void)hv_store_ent(hv, heksv, sv, 0);
1917 (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1918 HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1919 SvREFCNT_dec_NN(heksv);
1922 HvRITER_set(ohv, riter);
1923 HvEITER_set(ohv, eiter);
1925 SvREFCNT_inc_simple_void_NN(hv);
1928 hv_magic(hv, NULL, PERL_MAGIC_hints);
1931 #undef HV_SET_MAX_ADJUSTED_FOR_KEYS
1933 /* like hv_free_ent, but returns the SV rather than freeing it */
1935 S_hv_free_ent_ret(pTHX_ HE *entry)
1937 PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1939 SV *val = HeVAL(entry);
1940 if (HeKLEN(entry) == HEf_SVKEY) {
1941 SvREFCNT_dec(HeKEY_sv(entry));
1942 Safefree(HeKEY_hek(entry));
1944 else if ((HeKFLAGS(entry) & HVhek_NOTSHARED) == 0) {
1945 unshare_hek(HeKEY_hek(entry));
1948 Safefree(HeKEY_hek(entry));
1956 Perl_hv_free_ent(pTHX_ HV *notused, HE *entry)
1958 PERL_UNUSED_ARG(notused);
1963 SV *val = hv_free_ent_ret(entry);
1969 Perl_hv_delayfree_ent(pTHX_ HV *notused, HE *entry)
1971 PERL_UNUSED_ARG(notused);
1975 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1976 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
1977 if (HeKLEN(entry) == HEf_SVKEY) {
1978 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1980 hv_free_ent(NULL, entry);
1984 =for apidoc hv_clear
1986 Frees all the elements of a hash, leaving it empty.
1987 The XS equivalent of C<%hash = ()>. See also L</hv_undef>.
1989 See L</av_clear> for a note about the hash possibly being invalid on
1996 Perl_hv_clear(pTHX_ HV *hv)
2003 DEBUG_A(Perl_hv_assert(aTHX_ hv));
2005 /* avoid hv being freed when calling destructors below */
2007 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
2008 orig_ix = PL_tmps_ix;
2009 if (SvREADONLY(hv) && HvTOTALKEYS(hv)) {
2010 /* restricted hash: convert all keys to placeholders */
2011 STRLEN max = HvMAX(hv);
2013 for (i = 0; i <= max; i++) {
2014 HE *entry = (HvARRAY(hv))[i];
2015 for (; entry; entry = HeNEXT(entry)) {
2016 /* not already placeholder */
2017 if (HeVAL(entry) != &PL_sv_placeholder) {
2019 if (SvREADONLY(HeVAL(entry))) {
2020 SV* const keysv = hv_iterkeysv(entry);
2021 Perl_croak_nocontext(
2022 "Attempt to delete readonly key '%" SVf "' from a restricted hash",
2025 SvREFCNT_dec_NN(HeVAL(entry));
2027 HeVAL(entry) = &PL_sv_placeholder;
2028 HvPLACEHOLDERS(hv)++;
2034 hv_free_entries(hv);
2035 HvPLACEHOLDERS_set(hv, 0);
2038 mg_clear(MUTABLE_SV(hv));
2040 HvHASKFLAGS_off(hv);
2044 mro_isa_changed_in(hv);
2045 HvEITER_set(hv, NULL);
2047 /* disarm hv's premature free guard */
2048 if (LIKELY(PL_tmps_ix == orig_ix))
2051 PL_tmps_stack[orig_ix] = &PL_sv_undef;
2052 SvREFCNT_dec_NN(hv);
2056 =for apidoc hv_clear_placeholders
2058 Clears any placeholders from a hash. If a restricted hash has any of its keys
2059 marked as readonly and the key is subsequently deleted, the key is not actually
2060 deleted but is marked by assigning it a value of C<&PL_sv_placeholder>. This tags
2061 it so it will be ignored by future operations such as iterating over the hash,
2062 but will still allow the hash to have a value reassigned to the key at some
2063 future point. This function clears any such placeholder keys from the hash.
2064 See C<L<Hash::Util::lock_keys()|Hash::Util/lock_keys>> for an example of its
2071 Perl_hv_clear_placeholders(pTHX_ HV *hv)
2073 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
2075 PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
2078 clear_placeholders(hv, items);
2082 S_clear_placeholders(pTHX_ HV *hv, const U32 placeholders)
2085 U32 to_find = placeholders;
2087 PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
2093 /* Loop down the linked list heads */
2094 HE **oentry = &(HvARRAY(hv))[i];
2097 while ((entry = *oentry)) {
2098 if (HeVAL(entry) == &PL_sv_placeholder) {
2099 *oentry = HeNEXT(entry);
2100 if (entry == HvEITER_get(hv))
2103 if (HvHasAUX(hv) && HvLAZYDEL(hv) &&
2104 entry == HeNEXT(HvAUX(hv)->xhv_eiter))
2105 HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
2106 hv_free_ent(NULL, entry);
2109 if (--to_find == 0) {
2111 HvTOTALKEYS(hv) -= (IV)placeholders;
2112 if (HvTOTALKEYS(hv) == 0)
2113 HvHASKFLAGS_off(hv);
2114 HvPLACEHOLDERS_set(hv, 0);
2118 oentry = &HeNEXT(entry);
2122 /* You can't get here, hence assertion should always fail. */
2123 assert (to_find == 0);
2124 NOT_REACHED; /* NOTREACHED */
2128 S_hv_free_entries(pTHX_ HV *hv)
2133 PERL_ARGS_ASSERT_HV_FREE_ENTRIES;
2135 while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index)) || HvTOTALKEYS(hv)) {
2141 /* hfree_next_entry()
2142 * For use only by S_hv_free_entries() and sv_clear().
2143 * Delete the next available HE from hv and return the associated SV.
2144 * Returns null on empty hash. Nevertheless null is not a reliable
2145 * indicator that the hash is empty, as the deleted entry may have a
2147 * indexp is a pointer to the current index into HvARRAY. The index should
2148 * initially be set to 0. hfree_next_entry() may update it. */
2151 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
2153 struct xpvhv_aux *iter;
2157 STRLEN orig_index = *indexp;
2160 PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
2162 if (HvHasAUX(hv) && ((iter = HvAUX(hv)))) {
2163 if ((entry = iter->xhv_eiter)) {
2164 /* the iterator may get resurrected after each
2165 * destructor call, so check each time */
2166 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2168 hv_free_ent(NULL, entry);
2169 /* warning: at this point HvARRAY may have been
2170 * re-allocated, HvMAX changed etc */
2172 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2173 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2174 #ifdef PERL_HASH_RANDOMIZE_KEYS
2175 iter->xhv_last_rand = iter->xhv_rand;
2180 if (!((XPVHV*)SvANY(hv))->xhv_keys)
2183 array = HvARRAY(hv);
2185 while ( ! ((entry = array[*indexp])) ) {
2186 if ((*indexp)++ >= HvMAX(hv))
2188 assert(*indexp != orig_index);
2190 array[*indexp] = HeNEXT(entry);
2191 ((XPVHV*) SvANY(hv))->xhv_keys--;
2193 if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
2194 && HeVAL(entry) && isGV(HeVAL(entry))
2195 && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
2198 const char * const key = HePV(entry,klen);
2199 if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
2200 || (klen == 1 && key[0] == ':')) {
2202 NULL, GvHV(HeVAL(entry)),
2203 (GV *)HeVAL(entry), 0
2207 return hv_free_ent_ret(entry);
2212 =for apidoc hv_undef
2214 Undefines the hash. The XS equivalent of C<undef(%hash)>.
2216 As well as freeing all the elements of the hash (like C<hv_clear()>), this
2217 also frees any auxiliary data and storage associated with the hash.
2219 See L</av_clear> for a note about the hash possibly being invalid on
2226 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
2229 SSize_t orig_ix = PL_tmps_ix; /* silence compiler warning about unitialized vars */
2233 save = cBOOL(SvREFCNT(hv));
2234 DEBUG_A(Perl_hv_assert(aTHX_ hv));
2236 /* The name must be deleted before the call to hv_free_entries so that
2237 CVs are anonymised properly. But the effective name must be pre-
2238 served until after that call (and only deleted afterwards if the
2239 call originated from sv_clear). For stashes with one name that is
2240 both the canonical name and the effective name, hv_name_set has to
2241 allocate an array for storing the effective name. We can skip that
2242 during global destruction, as it does not matter where the CVs point
2243 if they will be freed anyway. */
2244 /* note that the code following prior to hv_free_entries is duplicated
2245 * in sv_clear(), and changes here should be done there too */
2246 if (PL_phase != PERL_PHASE_DESTRUCT && HvNAME(hv)) {
2247 if (PL_stashcache) {
2248 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
2249 HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
2250 (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
2252 hv_name_set(hv, NULL, 0, 0);
2255 /* avoid hv being freed when calling destructors below */
2257 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
2258 orig_ix = PL_tmps_ix;
2261 /* As well as any/all HE*s in HvARRAY(), this call also ensures that
2262 xhv_eiter is NULL, including handling the case of a tied hash partway
2263 through iteration where HvLAZYDEL() is true and xhv_eiter points to an
2264 HE* that needs to be explicitly freed. */
2265 hv_free_entries(hv);
2267 /* HvHasAUX() is true for a hash if it has struct xpvhv_aux allocated. That
2268 structure has several other pieces of allocated memory - hence those must
2269 be freed before the structure itself can be freed. Some can be freed when
2270 a hash is "undefined" (this function), but some must persist until it is
2271 destroyed (which might be this function's immediate caller).
2273 Hence the code in this block frees what it is logical to free (and NULLs
2274 out anything freed) so that the structure is left in a logically
2275 consistent state - pointers are NULL or point to valid memory, and
2276 non-pointer values are correct for an empty hash. The structure state
2277 must remain consistent, because this code can no longer clear SVf_OOK,
2278 meaning that this structure might be read again at any point in the
2279 future without further checks or reinitialisation. */
2281 struct mro_meta *meta;
2284 if (HvENAME_get(hv)) {
2285 if (PL_phase != PERL_PHASE_DESTRUCT)
2286 mro_isa_changed_in(hv);
2287 if (PL_stashcache) {
2288 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
2289 HEKf "'\n", HEKfARG(HvENAME_HEK(hv))));
2290 (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD);
2294 /* If this call originated from sv_clear, then we must check for
2295 * effective names that need freeing, as well as the usual name. */
2297 if (flags & HV_NAME_SETALL
2298 ? cBOOL(HvAUX(hv)->xhv_name_u.xhvnameu_name)
2301 if (name && PL_stashcache) {
2302 DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
2303 HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
2304 (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
2306 hv_name_set(hv, NULL, 0, flags);
2308 if((meta = HvAUX(hv)->xhv_mro_meta)) {
2309 if (meta->mro_linear_all) {
2310 SvREFCNT_dec_NN(meta->mro_linear_all);
2311 /* mro_linear_current is just acting as a shortcut pointer,
2315 /* Only the current MRO is stored, so this owns the data.
2317 SvREFCNT_dec(meta->mro_linear_current);
2318 SvREFCNT_dec(meta->mro_nextmethod);
2319 SvREFCNT_dec(meta->isa);
2320 SvREFCNT_dec(meta->super);
2322 HvAUX(hv)->xhv_mro_meta = NULL;
2326 Safefree(HvARRAY(hv));
2327 HvMAX(hv) = PERL_HASH_DEFAULT_HvMAX; /* 7 (it's a normal hash) */
2330 /* if we're freeing the HV, the SvMAGIC field has been reused for
2331 * other purposes, and so there can't be any placeholder magic */
2333 HvPLACEHOLDERS_set(hv, 0);
2336 mg_clear(MUTABLE_SV(hv));
2339 /* disarm hv's premature free guard */
2340 if (LIKELY(PL_tmps_ix == orig_ix))
2343 PL_tmps_stack[orig_ix] = &PL_sv_undef;
2344 SvREFCNT_dec_NN(hv);
2351 Returns the number of hash buckets that happen to be in use.
2353 This function implements the L<C<HvFILL> macro|perlapi/HvFILL> which you should
2356 As of perl 5.25 this function is used only for debugging
2357 purposes, and the number of used hash buckets is not
2358 in any way cached, thus this function can be costly
2359 to execute as it must iterate over all the buckets in the
2366 Perl_hv_fill(pTHX_ HV *const hv)
2369 HE **ents = HvARRAY(hv);
2371 PERL_UNUSED_CONTEXT;
2372 PERL_ARGS_ASSERT_HV_FILL;
2374 /* No keys implies no buckets used.
2375 One key can only possibly mean one bucket used. */
2376 if (HvTOTALKEYS(hv) < 2)
2377 return HvTOTALKEYS(hv);
2380 /* I wonder why we count down here...
2381 * Is it some micro-optimisation?
2382 * I would have thought counting up was better.
2385 HE *const *const last = ents + HvMAX(hv);
2386 count = last + 1 - ents;
2391 } while (++ents <= last);
2396 static struct xpvhv_aux*
2397 S_hv_auxinit(pTHX_ HV *hv) {
2398 struct xpvhv_aux *iter;
2400 PERL_ARGS_ASSERT_HV_AUXINIT;
2402 if (!HvHasAUX(hv)) {
2403 char *array = (char *) HvARRAY(hv);
2405 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
2406 HvARRAY(hv) = (HE**)array;
2408 iter = Perl_hv_auxalloc(aTHX_ hv);
2409 #ifdef PERL_HASH_RANDOMIZE_KEYS
2410 MAYBE_UPDATE_HASH_RAND_BITS();
2411 iter->xhv_rand = (U32)PL_hash_rand_bits;
2417 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2418 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2419 #ifdef PERL_HASH_RANDOMIZE_KEYS
2420 iter->xhv_last_rand = iter->xhv_rand;
2422 iter->xhv_name_u.xhvnameu_name = 0;
2423 iter->xhv_name_count = 0;
2424 iter->xhv_backreferences = 0;
2425 iter->xhv_mro_meta = NULL;
2426 iter->xhv_aux_flags = 0;
2431 =for apidoc hv_iterinit
2433 Prepares a starting point to traverse a hash table. Returns the number of
2434 keys in the hash, including placeholders (i.e. the same as C<HvTOTALKEYS(hv)>).
2435 The return value is currently only meaningful for hashes without tie magic.
2437 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
2438 hash buckets that happen to be in use. If you still need that esoteric
2439 value, you can get it through the macro C<HvFILL(hv)>.
2446 Perl_hv_iterinit(pTHX_ HV *hv)
2448 PERL_ARGS_ASSERT_HV_ITERINIT;
2451 struct xpvhv_aux * iter = HvAUX(hv);
2452 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2453 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2455 hv_free_ent(NULL, entry);
2457 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2458 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2459 #ifdef PERL_HASH_RANDOMIZE_KEYS
2460 iter->xhv_last_rand = iter->xhv_rand;
2466 /* note this includes placeholders! */
2467 return HvTOTALKEYS(hv);
2471 =for apidoc hv_riter_p
2473 Implements C<HvRITER> which you should use instead.
2479 Perl_hv_riter_p(pTHX_ HV *hv) {
2480 struct xpvhv_aux *iter;
2482 PERL_ARGS_ASSERT_HV_RITER_P;
2484 iter = HvHasAUX(hv) ? HvAUX(hv) : hv_auxinit(hv);
2485 return &(iter->xhv_riter);
2489 =for apidoc hv_eiter_p
2491 Implements C<HvEITER> which you should use instead.
2497 Perl_hv_eiter_p(pTHX_ HV *hv) {
2498 struct xpvhv_aux *iter;
2500 PERL_ARGS_ASSERT_HV_EITER_P;
2502 iter = HvHasAUX(hv) ? HvAUX(hv) : hv_auxinit(hv);
2503 return &(iter->xhv_eiter);
2507 =for apidoc hv_riter_set
2509 Implements C<HvRITER_set> which you should use instead.
2515 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2516 struct xpvhv_aux *iter;
2518 PERL_ARGS_ASSERT_HV_RITER_SET;
2526 iter = hv_auxinit(hv);
2528 iter->xhv_riter = riter;
2532 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2533 struct xpvhv_aux *iter;
2535 PERL_ARGS_ASSERT_HV_RAND_SET;
2537 #ifdef PERL_HASH_RANDOMIZE_KEYS
2541 iter = hv_auxinit(hv);
2543 iter->xhv_rand = new_xhv_rand;
2545 Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2550 =for apidoc hv_eiter_set
2552 Implements C<HvEITER_set> which you should use instead.
2558 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2559 struct xpvhv_aux *iter;
2561 PERL_ARGS_ASSERT_HV_EITER_SET;
2566 /* 0 is the default so don't go malloc()ing a new structure just to
2571 iter = hv_auxinit(hv);
2573 iter->xhv_eiter = eiter;
2577 =for apidoc hv_name_set
2578 =for apidoc_item ||hv_name_sets|HV *hv|"name"|U32 flags
2580 These each set the name of stash C<hv> to the specified name.
2582 They differ only in how the name is specified.
2584 In C<hv_name_sets>, the name is a literal C string, enclosed in double quotes.
2586 In C<hv_name_set>, C<name> points to the first byte of the name, and an
2587 additional parameter, C<len>, specifies its length in bytes. Hence, the name
2588 may contain embedded-NUL characters.
2590 If C<SVf_UTF8> is set in C<flags>, the name is treated as being in UTF-8;
2593 If C<HV_NAME_SETALL> is set in C<flags>, both the name and the effective name
2596 =for apidoc Amnh||HV_NAME_SETALL
2602 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2604 struct xpvhv_aux *iter;
2608 PERL_ARGS_ASSERT_HV_NAME_SET;
2611 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2615 if (iter->xhv_name_u.xhvnameu_name) {
2616 if(iter->xhv_name_count) {
2617 if(flags & HV_NAME_SETALL) {
2618 HEK ** const this_name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2619 HEK **hekp = this_name + (
2620 iter->xhv_name_count < 0
2621 ? -iter->xhv_name_count
2622 : iter->xhv_name_count
2624 while(hekp-- > this_name+1)
2625 unshare_hek_or_pvn(*hekp, 0, 0, 0);
2626 /* The first elem may be null. */
2627 if(*this_name) unshare_hek_or_pvn(*this_name, 0, 0, 0);
2628 Safefree(this_name);
2629 spot = &iter->xhv_name_u.xhvnameu_name;
2630 iter->xhv_name_count = 0;
2633 if(iter->xhv_name_count > 0) {
2634 /* shift some things over */
2636 iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2638 spot = iter->xhv_name_u.xhvnameu_names;
2639 spot[iter->xhv_name_count] = spot[1];
2641 iter->xhv_name_count = -(iter->xhv_name_count + 1);
2643 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2644 unshare_hek_or_pvn(*spot, 0, 0, 0);
2648 else if (flags & HV_NAME_SETALL) {
2649 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2650 spot = &iter->xhv_name_u.xhvnameu_name;
2653 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2654 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2655 iter->xhv_name_count = -2;
2656 spot = iter->xhv_name_u.xhvnameu_names;
2657 spot[1] = existing_name;
2660 else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2665 iter = hv_auxinit(hv);
2666 spot = &iter->xhv_name_u.xhvnameu_name;
2668 PERL_HASH(hash, name, len);
2669 *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2673 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2678 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2679 if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2680 if (flags & SVf_UTF8)
2681 return (bytes_cmp_utf8(
2682 (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2683 (const U8*)pv, pvlen) == 0);
2685 return (bytes_cmp_utf8(
2686 (const U8*)pv, pvlen,
2687 (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2690 return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2691 || memEQ(HEK_KEY(hek), pv, pvlen));
2695 =for apidoc hv_ename_add
2697 Adds a name to a stash's internal list of effective names. See
2698 C<L</hv_ename_delete>>.
2700 This is called when a stash is assigned to a new location in the symbol
2707 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2709 struct xpvhv_aux *aux = HvHasAUX(hv) ? HvAUX(hv) : hv_auxinit(hv);
2712 PERL_ARGS_ASSERT_HV_ENAME_ADD;
2715 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2717 PERL_HASH(hash, name, len);
2719 if (aux->xhv_name_count) {
2720 I32 count = aux->xhv_name_count;
2721 HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0);
2722 HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count);
2723 while (hekp-- > xhv_name)
2727 (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
2728 ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2729 : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2731 if (hekp == xhv_name && count < 0)
2732 aux->xhv_name_count = -count;
2736 if (count < 0) aux->xhv_name_count--, count = -count;
2737 else aux->xhv_name_count++;
2738 Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2739 (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2742 HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2745 (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2746 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2747 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2750 Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2751 aux->xhv_name_count = existing_name ? 2 : -2;
2752 *aux->xhv_name_u.xhvnameu_names = existing_name;
2753 (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2758 =for apidoc hv_ename_delete
2760 Removes a name from a stash's internal list of effective names. If this is
2761 the name returned by C<HvENAME>, then another name in the list will take
2762 its place (C<HvENAME> will use it).
2764 This is called when a stash is deleted from the symbol table.
2770 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2772 struct xpvhv_aux *aux;
2774 PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2777 Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2779 if (!HvHasAUX(hv)) return;
2782 if (!aux->xhv_name_u.xhvnameu_name) return;
2784 if (aux->xhv_name_count) {
2785 HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2786 I32 const count = aux->xhv_name_count;
2787 HEK **victim = namep + (count < 0 ? -count : count);
2788 while (victim-- > namep + 1)
2790 (HEK_UTF8(*victim) || (flags & SVf_UTF8))
2791 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2792 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2794 unshare_hek_or_pvn(*victim, 0, 0, 0);
2795 if (count < 0) ++aux->xhv_name_count;
2796 else --aux->xhv_name_count;
2798 (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2800 ) { /* if there are none left */
2802 aux->xhv_name_u.xhvnameu_names = NULL;
2803 aux->xhv_name_count = 0;
2806 /* Move the last one back to fill the empty slot. It
2807 does not matter what order they are in. */
2808 *victim = *(namep + (count < 0 ? -count : count) - 1);
2813 count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8))
2814 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2815 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2818 aux->xhv_name_count = -count;
2822 (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
2823 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2824 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2825 memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2827 HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2828 Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2829 *aux->xhv_name_u.xhvnameu_names = namehek;
2830 aux->xhv_name_count = -1;
2835 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2836 PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2837 /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
2839 struct xpvhv_aux * const iter = HvHasAUX(hv) ? HvAUX(hv) : hv_auxinit(hv);
2840 return &(iter->xhv_backreferences);
2845 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2848 PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2853 av = HvAUX(hv)->xhv_backreferences;
2856 HvAUX(hv)->xhv_backreferences = 0;
2857 Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2858 if (SvTYPE(av) == SVt_PVAV)
2859 SvREFCNT_dec_NN(av);
2864 hv_iternext is implemented as a macro in hv.h
2866 =for apidoc hv_iternext
2868 Returns entries from a hash iterator. See C<L</hv_iterinit>>.
2870 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2871 iterator currently points to, without losing your place or invalidating your
2872 iterator. Note that in this case the current entry is deleted from the hash
2873 with your iterator holding the last reference to it. Your iterator is flagged
2874 to free the entry on the next call to C<hv_iternext>, so you must not discard
2875 your iterator immediately else the entry will leak - call C<hv_iternext> to
2876 trigger the resource deallocation.
2878 =for apidoc hv_iternext_flags
2880 Returns entries from a hash iterator. See C<L</hv_iterinit>> and
2882 The C<flags> value will normally be zero; if C<HV_ITERNEXT_WANTPLACEHOLDERS> is
2883 set the placeholders keys (for restricted hashes) will be returned in addition
2884 to normal keys. By default placeholders are automatically skipped over.
2885 Currently a placeholder is implemented with a value that is
2886 C<&PL_sv_placeholder>. Note that the implementation of placeholders and
2887 restricted hashes may change, and the implementation currently is
2888 insufficiently abstracted for any change to be tidy.
2890 =for apidoc Amnh||HV_ITERNEXT_WANTPLACEHOLDERS
2896 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2901 struct xpvhv_aux *iter;
2903 PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2905 if (!HvHasAUX(hv)) {
2906 /* Too many things (well, pp_each at least) merrily assume that you can
2907 call hv_iternext without calling hv_iterinit, so we'll have to deal
2911 else if (!HvARRAY(hv)) {
2912 /* Since 5.002 calling hv_iternext() has ensured that HvARRAY() is
2913 non-NULL. There was explicit code for this added as part of commit
2914 4633a7c4bad06b47, without any explicit comment as to why, but from
2915 code inspection it seems to be a fix to ensure that the later line
2916 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
2917 was accessing a valid address, because that lookup in the loop was
2918 always reached even if the hash had no keys.
2920 That explicit code was removed in 2005 as part of b79f7545f218479c:
2921 Store the xhv_aux structure after the main array.
2922 This reduces the size of HV bodies from 24 to 20 bytes on a 32 bit
2923 build. It has the side effect of defined %symbol_table:: now always
2924 being true. defined %hash is already deprecated.
2926 with a comment and assertion added to note that after the call to
2927 hv_iterinit() HvARRAY() will now always be non-NULL.
2929 In turn, that potential NULL-pointer access within the loop was made
2930 unreachable in 2009 by commit 9eb4ebd1619c0362
2931 In Perl_hv_iternext_flags(), clarify and generalise the empty hash bailout code.
2933 which skipped the entire while loop if the hash had no keys.
2934 (If the hash has any keys, HvARRAY() cannot be NULL.)
2935 Hence the code in hv_iternext_flags() has long been able to handle
2936 HvARRAY() being NULL because no keys are allocated.
2938 Now that we have decoupled the aux structure from HvARRAY(),
2939 HvARRAY() can now be NULL even when SVf_OOK is true (and the aux
2940 struct is allocated and correction initialised).
2942 Is this actually a guarantee that we need to make? We should check
2943 whether anything is actually relying on this, or if we are simply
2944 making work for ourselves.
2946 For now, keep the behaviour as-was - after calling hv_iternext_flags
2947 ensure that HvARRAY() is non-NULL. Many (other) things are changing -
2948 no need to add risk by changing this too. But in the future we should
2949 consider changing hv_iternext_flags() to avoid allocating HvARRAY()
2950 here, and potentially also we avoid allocating HvARRAY()
2951 automatically in hv_auxinit() */
2954 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), char);
2955 HvARRAY(hv) = (HE**)array;
2960 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2961 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2962 if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2963 SV * const key = sv_newmortal();
2965 sv_setsv(key, HeSVKEY_force(entry));
2966 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2967 HeSVKEY_set(entry, NULL);
2973 /* one HE per MAGICAL hash */
2974 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2975 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2977 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2979 HeKEY_hek(entry) = hek;
2980 HeKLEN(entry) = HEf_SVKEY;
2982 magic_nextpack(MUTABLE_SV(hv),mg,key);
2984 /* force key to stay around until next time */
2985 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2986 return entry; /* beware, hent_val is not set */
2988 SvREFCNT_dec(HeVAL(entry));
2989 Safefree(HeKEY_hek(entry));
2991 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2996 #if defined(DYNAMIC_ENV_FETCH) && defined(VMS) /* set up %ENV for iteration */
2997 if (!entry && SvRMAGICAL((const SV *)hv)
2998 && mg_find((const SV *)hv, PERL_MAGIC_env)) {
3003 /* hv_iterinit now ensures this. */
3004 assert (HvARRAY(hv));
3006 /* At start of hash, entry is NULL. */
3009 entry = HeNEXT(entry);
3010 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
3012 * Skip past any placeholders -- don't want to include them in
3015 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
3016 entry = HeNEXT(entry);
3021 #ifdef PERL_HASH_RANDOMIZE_KEYS
3022 if (iter->xhv_last_rand != iter->xhv_rand) {
3023 if (iter->xhv_riter != -1) {
3024 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
3025 "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
3029 iter->xhv_last_rand = iter->xhv_rand;
3033 /* Skip the entire loop if the hash is empty. */
3034 if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
3035 ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
3036 STRLEN max = HvMAX(hv);
3038 /* OK. Come to the end of the current list. Grab the next one. */
3040 iter->xhv_riter++; /* HvRITER(hv)++ */
3041 if (iter->xhv_riter > (I32)max /* HvRITER(hv) > HvMAX(hv) */) {
3042 /* There is no next one. End of the hash. */
3043 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
3044 #ifdef PERL_HASH_RANDOMIZE_KEYS
3045 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
3049 entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & max ];
3051 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
3052 /* If we have an entry, but it's a placeholder, don't count it.
3054 while (entry && HeVAL(entry) == &PL_sv_placeholder)
3055 entry = HeNEXT(entry);
3057 /* Will loop again if this linked list starts NULL
3058 (for HV_ITERNEXT_WANTPLACEHOLDERS)
3059 or if we run through it and find only placeholders. */
3063 iter->xhv_riter = -1;
3064 #ifdef PERL_HASH_RANDOMIZE_KEYS
3065 iter->xhv_last_rand = iter->xhv_rand;
3069 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
3071 hv_free_ent(NULL, oldentry);
3074 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
3079 =for apidoc hv_iterkey
3081 Returns the key from the current position of the hash iterator. See
3088 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
3090 PERL_ARGS_ASSERT_HV_ITERKEY;
3092 if (HeKLEN(entry) == HEf_SVKEY) {
3094 char * const p = SvPV(HeKEY_sv(entry), len);
3099 *retlen = HeKLEN(entry);
3100 return HeKEY(entry);
3104 /* unlike hv_iterval(), this always returns a mortal copy of the key */
3106 =for apidoc hv_iterkeysv
3108 Returns the key as an C<SV*> from the current position of the hash
3109 iterator. The return value will always be a mortal copy of the key. Also
3110 see C<L</hv_iterinit>>.
3116 Perl_hv_iterkeysv(pTHX_ HE *entry)
3118 PERL_ARGS_ASSERT_HV_ITERKEYSV;
3120 return newSVhek_mortal(HeKEY_hek(entry));
3124 =for apidoc hv_iterval
3126 Returns the value from the current position of the hash iterator. See
3133 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
3135 PERL_ARGS_ASSERT_HV_ITERVAL;
3137 if (SvRMAGICAL(hv)) {
3138 if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
3139 SV* const sv = sv_newmortal();
3140 if (HeKLEN(entry) == HEf_SVKEY)
3141 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
3143 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
3147 return HeVAL(entry);
3151 =for apidoc hv_iternextsv
3153 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
3160 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
3162 HE * const he = hv_iternext_flags(hv, 0);
3164 PERL_ARGS_ASSERT_HV_ITERNEXTSV;
3168 *key = hv_iterkey(he, retlen);
3169 return hv_iterval(hv, he);
3176 =for apidoc hv_magic
3178 Adds magic to a hash. See C<L</sv_magic>>.
3180 =for apidoc unsharepvn
3182 If no one has access to shared string C<str> with length C<len>, free it.
3184 C<len> and C<hash> must both be valid for C<str>.
3190 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
3192 unshare_hek_or_pvn (NULL, str, len, hash);
3197 Perl_unshare_hek(pTHX_ HEK *hek)
3200 unshare_hek_or_pvn(hek, NULL, 0, 0);
3203 /* possibly free a shared string if no one has access to it
3204 hek if non-NULL takes priority over the other 3, else str, len and hash
3205 are used. If so, len and hash must both be valid for str.
3208 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
3212 bool is_utf8 = FALSE;
3214 const char * const save = str;
3215 struct shared_he *he = NULL;
3218 assert((HEK_FLAGS(hek) & HVhek_NOTSHARED) == 0);
3219 /* Find the shared he which is just before us in memory. */
3220 he = (struct shared_he *)(((char *)hek)
3221 - STRUCT_OFFSET(struct shared_he,
3224 /* Assert that the caller passed us a genuine (or at least consistent)
3226 assert (he->shared_he_he.hent_hek == hek);
3228 if (he->shared_he_he.he_valu.hent_refcount - 1) {
3229 --he->shared_he_he.he_valu.hent_refcount;
3233 hash = HEK_HASH(hek);
3234 } else if (len < 0) {
3235 STRLEN tmplen = -len;
3237 /* See the note in hv_fetch(). --jhi */
3238 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
3241 k_flags = HVhek_UTF8;
3243 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
3246 /* what follows was the moral equivalent of:
3247 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
3249 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
3252 /* assert(xhv_array != 0) */
3253 oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
3255 const HE *const he_he = &(he->shared_he_he);
3256 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
3261 const U8 flags_masked = k_flags & HVhek_STORAGE_MASK;
3262 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
3263 if (HeHASH(entry) != hash) /* strings can't be equal */
3265 if (HeKLEN(entry) != len)
3267 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
3269 if (HeKFLAGS(entry) != flags_masked)
3276 if (--entry->he_valu.hent_refcount == 0) {
3277 *oentry = HeNEXT(entry);
3279 HvTOTALKEYS(PL_strtab)--;
3284 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
3285 "Attempt to free nonexistent shared string '%s'%s"
3287 hek ? HEK_KEY(hek) : str,
3288 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
3289 if (k_flags & HVhek_FREEKEY)
3293 /* get a (constant) string ptr from the global string table
3294 * string will get added if it is not already there.
3295 * len and hash must both be valid for str.
3298 Perl_share_hek(pTHX_ const char *str, SSize_t len, U32 hash)
3300 bool is_utf8 = FALSE;
3302 const char * const save = str;
3304 PERL_ARGS_ASSERT_SHARE_HEK;
3307 STRLEN tmplen = -len;
3309 /* See the note in hv_fetch(). --jhi */
3310 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
3312 /* If we were able to downgrade here, then than means that we were passed
3313 in a key which only had chars 0-255, but was utf8 encoded. */
3316 /* If we found we were able to downgrade the string to bytes, then
3317 we should flag that it needs upgrading on keys or each. Also flag
3318 that we need share_hek_flags to free the string. */
3320 PERL_HASH(hash, str, len);
3321 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
3325 return share_hek_flags (str, len, hash, flags);
3329 S_share_hek_flags(pTHX_ const char *str, STRLEN len, U32 hash, int flags)
3332 const U8 flags_masked = flags & HVhek_STORAGE_MASK;
3333 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
3335 PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
3336 assert(!(flags & HVhek_NOTSHARED));
3338 if (UNLIKELY(len > (STRLEN) I32_MAX)) {
3339 Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes");
3342 /* what follows is the moral equivalent of:
3344 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
3345 hv_store(PL_strtab, str, len, NULL, hash);
3347 Can't rehash the shared string table, so not sure if it's worth
3348 counting the number of entries in the linked list
3351 /* assert(xhv_array != 0) */
3352 entry = (HvARRAY(PL_strtab))[hindex];
3353 for (;entry; entry = HeNEXT(entry)) {
3354 if (HeHASH(entry) != hash) /* strings can't be equal */
3356 if (HeKLEN(entry) != (SSize_t) len)
3358 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
3360 if (HeKFLAGS(entry) != flags_masked)
3366 /* What used to be head of the list.
3367 If this is NULL, then we're the first entry for this slot, which
3368 means we need to increate fill. */
3369 struct shared_he *new_entry;
3372 HE **const head = &HvARRAY(PL_strtab)[hindex];
3373 HE *const next = *head;
3374 XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
3376 /* We don't actually store a HE from the arena and a regular HEK.
3377 Instead we allocate one chunk of memory big enough for both,
3378 and put the HEK straight after the HE. This way we can find the
3379 HE directly from the HEK.
3382 Newx(k, STRUCT_OFFSET(struct shared_he,
3383 shared_he_hek.hek_key[0]) + len + 2, char);
3384 new_entry = (struct shared_he *)k;
3385 entry = &(new_entry->shared_he_he);
3386 hek = &(new_entry->shared_he_hek);
3388 Copy(str, HEK_KEY(hek), len, char);
3389 HEK_KEY(hek)[len] = 0;
3391 HEK_HASH(hek) = hash;
3392 HEK_FLAGS(hek) = (unsigned char)flags_masked;
3394 /* Still "point" to the HEK, so that other code need not know what
3396 HeKEY_hek(entry) = hek;
3397 entry->he_valu.hent_refcount = 0;
3398 HeNEXT(entry) = next;
3401 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
3402 if (!next) { /* initial entry? */
3403 } else if ( DO_HSPLIT(xhv) ) {
3404 const STRLEN oldsize = xhv->xhv_max + 1;
3405 hsplit(PL_strtab, oldsize, oldsize * 2);
3409 ++entry->he_valu.hent_refcount;
3411 if (flags & HVhek_FREEKEY)
3414 return HeKEY_hek(entry);
3418 Perl_hv_placeholders_p(pTHX_ HV *hv)
3420 MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3422 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
3425 mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
3428 Perl_die(aTHX_ "panic: hv_placeholders_p");
3431 return &(mg->mg_len);
3435 =for apidoc hv_placeholders_get
3437 Implements C<HvPLACEHOLDERS_get>, which you should use instead.
3443 Perl_hv_placeholders_get(pTHX_ const HV *hv)
3445 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3447 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3448 PERL_UNUSED_CONTEXT;
3450 return mg ? mg->mg_len : 0;
3454 =for apidoc hv_placeholders_set
3456 Implements C<HvPLACEHOLDERS_set>, which you should use instead.
3462 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3464 MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3466 PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3471 if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3472 Perl_die(aTHX_ "panic: hv_placeholders_set");
3474 /* else we don't need to add magic to record 0 placeholders. */
3478 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3482 PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3484 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3486 value = newSV_type(SVt_NULL);
3489 value = &PL_sv_placeholder;
3492 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3495 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3498 case HVrhek_PV_UTF8:
3499 /* Create a string SV that directly points to the bytes in our
3501 value = newSV_type(SVt_PV);
3502 SvPV_set(value, (char *) he->refcounted_he_data + 1);
3503 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3504 /* This stops anything trying to free it */
3505 SvLEN_set(value, 0);
3507 SvREADONLY_on(value);
3508 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3512 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf,
3513 (UV)he->refcounted_he_data[0]);
3519 =for apidoc refcounted_he_chain_2hv
3521 Generates and returns a C<HV *> representing the content of a
3522 C<refcounted_he> chain.
3523 C<flags> is currently unused and must be zero.
3528 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3531 U32 placeholders, max;
3534 Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf,
3537 /* We could chase the chain once to get an idea of the number of keys,
3538 and call ksplit. But for now we'll make a potentially inefficient
3539 hash with only 8 entries in its array. */
3541 #ifdef NODEFAULT_SHAREKEYS
3542 /* We share keys in the COP, so it's much easier to keep sharing keys in
3543 the hash we build from it. */
3549 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3550 HvARRAY(hv) = (HE**)array;
3556 U32 hash = chain->refcounted_he_hash;
3558 U32 hash = HEK_HASH(chain->refcounted_he_hek);
3560 HE **oentry = &((HvARRAY(hv))[hash & max]);
3561 HE *entry = *oentry;
3564 for (; entry; entry = HeNEXT(entry)) {
3565 if (HeHASH(entry) == hash) {
3566 /* We might have a duplicate key here. If so, entry is older
3567 than the key we've already put in the hash, so if they are
3568 the same, skip adding entry. */
3570 const STRLEN klen = HeKLEN(entry);
3571 const char *const key = HeKEY(entry);
3572 if (klen == chain->refcounted_he_keylen
3573 && (cBOOL(HeKUTF8(entry))
3574 == cBOOL((chain->refcounted_he_data[0] & HVhek_UTF8)))
3575 && memEQ(key, REF_HE_KEY(chain), klen))
3578 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3580 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3581 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3582 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3593 = share_hek_flags(REF_HE_KEY(chain),
3594 chain->refcounted_he_keylen,
3595 chain->refcounted_he_hash,
3596 (chain->refcounted_he_data[0]
3597 & (HVhek_UTF8|HVhek_WASUTF8)));
3599 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3601 value = refcounted_he_value(chain);
3602 if (value == &PL_sv_placeholder)
3604 HeVAL(entry) = value;
3606 /* Link it into the chain. */
3607 HeNEXT(entry) = *oentry;
3613 chain = chain->refcounted_he_next;
3617 clear_placeholders(hv, placeholders);
3620 /* We could check in the loop to see if we encounter any keys with key
3621 flags, but it's probably not worth it, as this per-hash flag is only
3622 really meant as an optimisation for things like Storable. */
3624 DEBUG_A(Perl_hv_assert(aTHX_ hv));
3630 =for apidoc refcounted_he_fetch_pvn
3632 Search along a C<refcounted_he> chain for an entry with the key specified
3633 by C<keypv> and C<keylen>. If C<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3634 bit set, the key octets are interpreted as UTF-8, otherwise they
3635 are interpreted as Latin-1. C<hash> is a precomputed hash of the key
3636 string, or zero if it has not been precomputed. Returns a mortal scalar
3637 representing the value associated with the key, or C<&PL_sv_placeholder>
3638 if there is no value associated with the key.
3644 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3645 const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3648 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3650 if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3651 Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf,
3655 if (flags & REFCOUNTED_HE_KEY_UTF8) {
3656 /* For searching purposes, canonicalise to Latin-1 where possible. */
3657 const char *keyend = keypv + keylen, *p;
3658 STRLEN nonascii_count = 0;
3659 for (p = keypv; p != keyend; p++) {
3660 if (! UTF8_IS_INVARIANT(*p)) {
3661 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3662 goto canonicalised_key;
3668 if (nonascii_count) {
3670 const char *p = keypv, *keyend = keypv + keylen;
3671 keylen -= nonascii_count;
3672 Newx(q, keylen, char);
3675 for (; p != keyend; p++, q++) {
3677 if (UTF8_IS_INVARIANT(c)) {
3682 *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3686 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3687 canonicalised_key: ;
3689 utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3691 PERL_HASH(hash, keypv, keylen);
3693 for (; chain; chain = chain->refcounted_he_next) {
3696 hash == chain->refcounted_he_hash &&
3697 keylen == chain->refcounted_he_keylen &&
3698 memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3699 utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3701 hash == HEK_HASH(chain->refcounted_he_hek) &&
3702 keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3703 memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3704 utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3707 if (flags & REFCOUNTED_HE_EXISTS)
3708 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3710 ? NULL : &PL_sv_yes;
3711 return sv_2mortal(refcounted_he_value(chain));
3715 return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3719 =for apidoc refcounted_he_fetch_pv
3721 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3722 instead of a string/length pair.
3728 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3729 const char *key, U32 hash, U32 flags)
3731 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3732 return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3736 =for apidoc refcounted_he_fetch_sv
3738 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3745 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3746 SV *key, U32 hash, U32 flags)
3750 PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3751 if (flags & REFCOUNTED_HE_KEY_UTF8)
3752 Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf,
3754 keypv = SvPV_const(key, keylen);
3756 flags |= REFCOUNTED_HE_KEY_UTF8;
3757 if (!hash && SvIsCOW_shared_hash(key))
3758 hash = SvSHARED_HASH(key);
3759 return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3763 =for apidoc refcounted_he_new_pvn
3765 Creates a new C<refcounted_he>. This consists of a single key/value
3766 pair and a reference to an existing C<refcounted_he> chain (which may
3767 be empty), and thus forms a longer chain. When using the longer chain,
3768 the new key/value pair takes precedence over any entry for the same key
3769 further along the chain.
3771 The new key is specified by C<keypv> and C<keylen>. If C<flags> has
3772 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3773 as UTF-8, otherwise they are interpreted as Latin-1. C<hash> is
3774 a precomputed hash of the key string, or zero if it has not been
3777 C<value> is the scalar value to store for this key. C<value> is copied
3778 by this function, which thus does not take ownership of any reference
3779 to it, and later changes to the scalar will not be reflected in the
3780 value visible in the C<refcounted_he>. Complex types of scalar will not
3781 be stored with referential integrity, but will be coerced to strings.
3782 C<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3783 value is to be associated with the key; this, as with any non-null value,
3784 takes precedence over the existence of a value for the key further along
3787 C<parent> points to the rest of the C<refcounted_he> chain to be
3788 attached to the new C<refcounted_he>. This function takes ownership
3789 of one reference to C<parent>, and returns one reference to the new
3795 struct refcounted_he *
3796 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3797 const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3799 STRLEN value_len = 0;
3800 const char *value_p = NULL;
3804 STRLEN key_offset = 1;
3805 struct refcounted_he *he;
3806 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3808 if (!value || value == &PL_sv_placeholder) {
3809 value_type = HVrhek_delete;
3810 } else if (SvPOK(value)) {
3811 value_type = HVrhek_PV;
3812 } else if (SvIOK(value)) {
3813 value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3814 } else if (!SvOK(value)) {
3815 value_type = HVrhek_undef;
3817 value_type = HVrhek_PV;
3819 is_pv = value_type == HVrhek_PV;
3821 /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3822 the value is overloaded, and doesn't yet have the UTF-8flag set. */
3823 value_p = SvPV_const(value, value_len);
3825 value_type = HVrhek_PV_UTF8;
3826 key_offset = value_len + 2;
3828 hekflags = value_type;
3830 if (flags & REFCOUNTED_HE_KEY_UTF8) {
3831 /* Canonicalise to Latin-1 where possible. */
3832 const char *keyend = keypv + keylen, *p;
3833 STRLEN nonascii_count = 0;
3834 for (p = keypv; p != keyend; p++) {
3835 if (! UTF8_IS_INVARIANT(*p)) {
3836 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3837 goto canonicalised_key;
3843 if (nonascii_count) {
3845 const char *p = keypv, *keyend = keypv + keylen;
3846 keylen -= nonascii_count;
3847 Newx(q, keylen, char);
3850 for (; p != keyend; p++, q++) {
3852 if (UTF8_IS_INVARIANT(c)) {
3857 *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3861 flags &= ~REFCOUNTED_HE_KEY_UTF8;
3862 canonicalised_key: ;
3864 if (flags & REFCOUNTED_HE_KEY_UTF8)
3865 hekflags |= HVhek_UTF8;
3867 PERL_HASH(hash, keypv, keylen);
3870 he = (struct refcounted_he*)
3871 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3875 he = (struct refcounted_he*)
3876 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3880 he->refcounted_he_next = parent;
3883 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3884 he->refcounted_he_val.refcounted_he_u_len = value_len;
3885 } else if (value_type == HVrhek_IV) {
3886 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3887 } else if (value_type == HVrhek_UV) {
3888 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3892 he->refcounted_he_hash = hash;
3893 he->refcounted_he_keylen = keylen;
3894 Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3896 he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3899 he->refcounted_he_data[0] = hekflags;
3900 he->refcounted_he_refcnt = 1;
3906 =for apidoc refcounted_he_new_pv
3908 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3909 of a string/length pair.
3914 struct refcounted_he *
3915 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3916 const char *key, U32 hash, SV *value, U32 flags)
3918 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3919 return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3923 =for apidoc refcounted_he_new_sv
3925 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3931 struct refcounted_he *
3932 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3933 SV *key, U32 hash, SV *value, U32 flags)
3937 PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3938 if (flags & REFCOUNTED_HE_KEY_UTF8)
3939 Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf,
3941 keypv = SvPV_const(key, keylen);
3943 flags |= REFCOUNTED_HE_KEY_UTF8;
3944 if (!hash && SvIsCOW_shared_hash(key))
3945 hash = SvSHARED_HASH(key);
3946 return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3950 =for apidoc refcounted_he_free
3952 Decrements the reference count of a C<refcounted_he> by one. If the
3953 reference count reaches zero the structure's memory is freed, which
3954 (recursively) causes a reduction of its parent C<refcounted_he>'s
3955 reference count. It is safe to pass a null pointer to this function:
3956 no action occurs in this case.
3962 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3963 PERL_UNUSED_CONTEXT;
3966 struct refcounted_he *copy;
3970 new_count = --he->refcounted_he_refcnt;
3971 HINTS_REFCNT_UNLOCK;
3977 #ifndef USE_ITHREADS
3978 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3981 he = he->refcounted_he_next;
3982 PerlMemShared_free(copy);
3987 =for apidoc refcounted_he_inc
3989 Increment the reference count of a C<refcounted_he>. The pointer to the
3990 C<refcounted_he> is also returned. It is safe to pass a null pointer
3991 to this function: no action occurs and a null pointer is returned.
3996 struct refcounted_he *
3997 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3999 PERL_UNUSED_CONTEXT;
4002 he->refcounted_he_refcnt++;
4003 HINTS_REFCNT_UNLOCK;
4009 =for apidoc_section $COP
4010 =for apidoc cop_fetch_label
4012 Returns the label attached to a cop, and stores its length in bytes into
4014 Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0.
4016 Alternatively, use the macro C<L</CopLABEL_len_flags>>;
4017 or if you don't need to know if the label is UTF-8 or not, the macro
4018 C<L</CopLABEL_len>>;
4019 or if you additionally dont need to know the length, C<L</CopLABEL>>.
4024 /* pp_entereval is aware that labels are stored with a key ':' at the top of
4027 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
4028 struct refcounted_he *const chain = cop->cop_hints_hash;
4030 PERL_ARGS_ASSERT_COP_FETCH_LABEL;
4031 PERL_UNUSED_CONTEXT;
4036 if (chain->refcounted_he_keylen != 1)
4038 if (*REF_HE_KEY(chain) != ':')
4041 if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
4043 if (*HEK_KEY(chain->refcounted_he_hek) != ':')
4046 /* Stop anyone trying to really mess us up by adding their own value for
4048 if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
4049 && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
4053 *len = chain->refcounted_he_val.refcounted_he_u_len;
4055 *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
4056 == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
4058 return chain->refcounted_he_data + 1;
4062 =for apidoc cop_store_label
4064 Save a label into a C<cop_hints_hash>.
4065 You need to set flags to C<SVf_UTF8>
4066 for a UTF-8 label. Any other flag is ignored.
4072 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
4076 PERL_ARGS_ASSERT_COP_STORE_LABEL;
4078 if (flags & ~(SVf_UTF8))
4079 Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
4081 labelsv = newSVpvn_flags(label, len, SVs_TEMP);
4082 if (flags & SVf_UTF8)
4085 = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
4089 =for apidoc_section $HV
4090 =for apidoc hv_assert
4092 Check that a hash is in an internally consistent state.
4100 Perl_hv_assert(pTHX_ HV *hv)
4104 int placeholders = 0;
4107 const I32 riter = HvRITER_get(hv);
4108 HE *eiter = HvEITER_get(hv);
4110 PERL_ARGS_ASSERT_HV_ASSERT;
4112 (void)hv_iterinit(hv);
4114 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
4115 /* sanity check the values */
4116 if (HeVAL(entry) == &PL_sv_placeholder)
4120 /* sanity check the keys */
4121 if (HeSVKEY(entry)) {
4122 NOOP; /* Don't know what to check on SV keys. */
4123 } else if (HeKUTF8(entry)) {
4125 if (HeKWASUTF8(entry)) {
4126 PerlIO_printf(Perl_debug_log,
4127 "hash key has both WASUTF8 and UTF8: '%.*s'\n",
4128 (int) HeKLEN(entry), HeKEY(entry));
4131 } else if (HeKWASUTF8(entry))
4134 if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
4135 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
4136 const int nhashkeys = HvUSEDKEYS(hv);
4137 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
4139 if (nhashkeys != real) {
4140 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
4143 if (nhashplaceholders != placeholders) {
4144 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
4148 if (withflags && ! HvHASKFLAGS(hv)) {
4149 PerlIO_printf(Perl_debug_log,
4150 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
4155 sv_dump(MUTABLE_SV(hv));
4157 HvRITER_set(hv, riter); /* Restore hash iterator state */
4158 HvEITER_set(hv, eiter);
4164 * ex: set ts=8 sts=4 sw=4 et: