This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Various updates and fixes to some of the SysV IPC ops and their tests
[perl5.git] / hv.c
1 /*    hv.c
2  *
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
5  *
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.
8  *
9  */
10
11 /*
12  *      I sit beside the fire and think
13  *          of all that I have seen.
14  *                         --Bilbo
15  *
16  *     [p.278 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
17  */
18
19 /* 
20 =head1 HV Handling
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.
27
28 =cut
29
30 */
31
32 #include "EXTERN.h"
33 #define PERL_IN_HV_C
34 #define PERL_HASH_INTERNAL_ACCESS
35 #include "perl.h"
36
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()
40  */
41 #define DO_HSPLIT(xhv) ( ((xhv)->xhv_keys + ((xhv)->xhv_keys >> 1))  > (xhv)->xhv_max )
42
43 static const char S_strtab_error[]
44     = "Cannot modify shared string table in hv_%s";
45
46 #ifdef PURIFY
47
48 #define new_HE() (HE*)safemalloc(sizeof(HE))
49 #define del_HE(p) safefree((char*)p)
50
51 #else
52
53 STATIC HE*
54 S_new_he(pTHX)
55 {
56     HE* he;
57     void ** const root = &PL_body_roots[HE_SVSLOT];
58
59     if (!*root)
60         Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE);
61     he = (HE*) *root;
62     assert(he);
63     *root = HeNEXT(he);
64     return he;
65 }
66
67 #define new_HE() new_he()
68 #define del_HE(p) \
69     STMT_START { \
70         HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]);    \
71         PL_body_roots[HE_SVSLOT] = p; \
72     } STMT_END
73
74
75
76 #endif
77
78 STATIC HEK *
79 S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
80 {
81     const int flags_masked = flags & HVhek_MASK;
82     char *k;
83     HEK *hek;
84
85     PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
86
87     Newx(k, HEK_BASESIZE + len + 2, char);
88     hek = (HEK*)k;
89     Copy(str, HEK_KEY(hek), len, char);
90     HEK_KEY(hek)[len] = 0;
91     HEK_LEN(hek) = len;
92     HEK_HASH(hek) = hash;
93     HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
94
95     if (flags & HVhek_FREEKEY)
96         Safefree(str);
97     return hek;
98 }
99
100 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
101  * for tied hashes */
102
103 void
104 Perl_free_tied_hv_pool(pTHX)
105 {
106     HE *he = PL_hv_fetch_ent_mh;
107     while (he) {
108         HE * const ohe = he;
109         Safefree(HeKEY_hek(he));
110         he = HeNEXT(he);
111         del_HE(ohe);
112     }
113     PL_hv_fetch_ent_mh = NULL;
114 }
115
116 #if defined(USE_ITHREADS)
117 HEK *
118 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
119 {
120     HEK *shared;
121
122     PERL_ARGS_ASSERT_HEK_DUP;
123     PERL_UNUSED_ARG(param);
124
125     if (!source)
126         return NULL;
127
128     shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
129     if (shared) {
130         /* We already shared this hash key.  */
131         (void)share_hek_hek(shared);
132     }
133     else {
134         shared
135             = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
136                               HEK_HASH(source), HEK_FLAGS(source));
137         ptr_table_store(PL_ptr_table, source, shared);
138     }
139     return shared;
140 }
141
142 HE *
143 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
144 {
145     HE *ret;
146
147     PERL_ARGS_ASSERT_HE_DUP;
148
149     if (!e)
150         return NULL;
151     /* look for it in the table first */
152     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
153     if (ret)
154         return ret;
155
156     /* create anew and remember what it is */
157     ret = new_HE();
158     ptr_table_store(PL_ptr_table, e, ret);
159
160     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
161     if (HeKLEN(e) == HEf_SVKEY) {
162         char *k;
163         Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
164         HeKEY_hek(ret) = (HEK*)k;
165         HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param);
166     }
167     else if (shared) {
168         /* This is hek_dup inlined, which seems to be important for speed
169            reasons.  */
170         HEK * const source = HeKEY_hek(e);
171         HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
172
173         if (shared) {
174             /* We already shared this hash key.  */
175             (void)share_hek_hek(shared);
176         }
177         else {
178             shared
179                 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
180                                   HEK_HASH(source), HEK_FLAGS(source));
181             ptr_table_store(PL_ptr_table, source, shared);
182         }
183         HeKEY_hek(ret) = shared;
184     }
185     else
186         HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
187                                         HeKFLAGS(e));
188     HeVAL(ret) = sv_dup_inc(HeVAL(e), param);
189     return ret;
190 }
191 #endif  /* USE_ITHREADS */
192
193 static void
194 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
195                 const char *msg)
196 {
197     SV * const sv = sv_newmortal();
198
199     PERL_ARGS_ASSERT_HV_NOTALLOWED;
200
201     if (!(flags & HVhek_FREEKEY)) {
202         sv_setpvn(sv, key, klen);
203     }
204     else {
205         /* Need to free saved eventually assign to mortal SV */
206         /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
207         sv_usepvn(sv, (char *) key, klen);
208     }
209     if (flags & HVhek_UTF8) {
210         SvUTF8_on(sv);
211     }
212     Perl_croak(aTHX_ msg, SVfARG(sv));
213 }
214
215 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
216  * contains an SV* */
217
218 /*
219 =for apidoc hv_store
220
221 Stores an SV in a hash.  The hash key is specified as C<key> and the
222 absolute value of C<klen> is the length of the key.  If C<klen> is
223 negative the key is assumed to be in UTF-8-encoded Unicode.  The
224 C<hash> parameter is the precomputed hash value; if it is zero then
225 Perl will compute it.
226
227 The return value will be
228 C<NULL> if the operation failed or if the value did not need to be actually
229 stored within the hash (as in the case of tied hashes).  Otherwise it can
230 be dereferenced to get the original C<SV*>.  Note that the caller is
231 responsible for suitably incrementing the reference count of C<val> before
232 the call, and decrementing it if the function returned C<NULL>.  Effectively
233 a successful C<hv_store> takes ownership of one reference to C<val>.  This is
234 usually what you want; a newly created SV has a reference count of one, so
235 if all your code does is create SVs then store them in a hash, C<hv_store>
236 will own the only reference to the new SV, and your code doesn't need to do
237 anything further to tidy up.  C<hv_store> is not implemented as a call to
238 C<hv_store_ent>, and does not create a temporary SV for the key, so if your
239 key data is not already in SV form then use C<hv_store> in preference to
240 C<hv_store_ent>.
241
242 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
243 information on how to use this function on tied hashes.
244
245 =for apidoc hv_store_ent
246
247 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
248 parameter is the precomputed hash value; if it is zero then Perl will
249 compute it.  The return value is the new hash entry so created.  It will be
250 C<NULL> if the operation failed or if the value did not need to be actually
251 stored within the hash (as in the case of tied hashes).  Otherwise the
252 contents of the return value can be accessed using the C<He?> macros
253 described here.  Note that the caller is responsible for suitably
254 incrementing the reference count of C<val> before the call, and
255 decrementing it if the function returned NULL.  Effectively a successful
256 C<hv_store_ent> takes ownership of one reference to C<val>.  This is
257 usually what you want; a newly created SV has a reference count of one, so
258 if all your code does is create SVs then store them in a hash, C<hv_store>
259 will own the only reference to the new SV, and your code doesn't need to do
260 anything further to tidy up.  Note that C<hv_store_ent> only reads the C<key>;
261 unlike C<val> it does not take ownership of it, so maintaining the correct
262 reference count on C<key> is entirely the caller's responsibility.  The reason
263 it does not take ownership, is that C<key> is not used after this function
264 returns, and so can be freed immediately.  C<hv_store>
265 is not implemented as a call to C<hv_store_ent>, and does not create a temporary
266 SV for the key, so if your key data is not already in SV form then use
267 C<hv_store> in preference to C<hv_store_ent>.
268
269 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
270 information on how to use this function on tied hashes.
271
272 =for apidoc hv_exists
273
274 Returns a boolean indicating whether the specified hash key exists.  The
275 absolute value of C<klen> is the length of the key.  If C<klen> is
276 negative the key is assumed to be in UTF-8-encoded Unicode.
277
278 =for apidoc hv_fetch
279
280 Returns the SV which corresponds to the specified key in the hash.
281 The absolute value of C<klen> is the length of the key.  If C<klen> is
282 negative the key is assumed to be in UTF-8-encoded Unicode.  If
283 C<lval> is set then the fetch will be part of a store.  This means that if
284 there is no value in the hash associated with the given key, then one is
285 created and a pointer to it is returned.  The C<SV*> it points to can be
286 assigned to.  But always check that the
287 return value is non-null before dereferencing it to an C<SV*>.
288
289 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
290 information on how to use this function on tied hashes.
291
292 =for apidoc hv_exists_ent
293
294 Returns a boolean indicating whether
295 the specified hash key exists.  C<hash>
296 can be a valid precomputed hash value, or 0 to ask for it to be
297 computed.
298
299 =cut
300 */
301
302 /* returns an HE * structure with the all fields set */
303 /* note that hent_val will be a mortal sv for MAGICAL hashes */
304 /*
305 =for apidoc hv_fetch_ent
306
307 Returns the hash entry which corresponds to the specified key in the hash.
308 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
309 if you want the function to compute it.  IF C<lval> is set then the fetch
310 will be part of a store.  Make sure the return value is non-null before
311 accessing it.  The return value when C<hv> is a tied hash is a pointer to a
312 static location, so be sure to make a copy of the structure if you need to
313 store it somewhere.
314
315 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
316 information on how to use this function on tied hashes.
317
318 =cut
319 */
320
321 /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store()  */
322 void *
323 Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
324                        const int action, SV *val, const U32 hash)
325 {
326     STRLEN klen;
327     int flags;
328
329     PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN;
330
331     if (klen_i32 < 0) {
332         klen = -klen_i32;
333         flags = HVhek_UTF8;
334     } else {
335         klen = klen_i32;
336         flags = 0;
337     }
338     return hv_common(hv, NULL, key, klen, flags, action, val, hash);
339 }
340
341 void *
342 Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
343                int flags, int action, SV *val, U32 hash)
344 {
345     XPVHV* xhv;
346     HE *entry;
347     HE **oentry;
348     SV *sv;
349     bool is_utf8;
350     bool in_collision;
351     int masked_flags;
352     const int return_svp = action & HV_FETCH_JUST_SV;
353     HEK *keysv_hek = NULL;
354
355     if (!hv)
356         return NULL;
357     if (SvTYPE(hv) == (svtype)SVTYPEMASK)
358         return NULL;
359
360     assert(SvTYPE(hv) == SVt_PVHV);
361
362     if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
363         MAGIC* mg;
364         if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) {
365             struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
366             if (uf->uf_set == NULL) {
367                 SV* obj = mg->mg_obj;
368
369                 if (!keysv) {
370                     keysv = newSVpvn_flags(key, klen, SVs_TEMP |
371                                            ((flags & HVhek_UTF8)
372                                             ? SVf_UTF8 : 0));
373                 }
374                 
375                 mg->mg_obj = keysv;         /* pass key */
376                 uf->uf_index = action;      /* pass action */
377                 magic_getuvar(MUTABLE_SV(hv), mg);
378                 keysv = mg->mg_obj;         /* may have changed */
379                 mg->mg_obj = obj;
380
381                 /* If the key may have changed, then we need to invalidate
382                    any passed-in computed hash value.  */
383                 hash = 0;
384             }
385         }
386     }
387     if (keysv) {
388         if (flags & HVhek_FREEKEY)
389             Safefree(key);
390         key = SvPV_const(keysv, klen);
391         is_utf8 = (SvUTF8(keysv) != 0);
392         if (SvIsCOW_shared_hash(keysv)) {
393             flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
394         } else {
395             flags = 0;
396         }
397     } else {
398         is_utf8 = cBOOL(flags & HVhek_UTF8);
399     }
400
401     if (action & HV_DELETE) {
402         return (void *) hv_delete_common(hv, keysv, key, klen,
403                                          flags | (is_utf8 ? HVhek_UTF8 : 0),
404                                          action, hash);
405     }
406
407     xhv = (XPVHV*)SvANY(hv);
408     if (SvMAGICAL(hv)) {
409         if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
410             if (mg_find((const SV *)hv, PERL_MAGIC_tied)
411                 || SvGMAGICAL((const SV *)hv))
412             {
413                 /* FIXME should be able to skimp on the HE/HEK here when
414                    HV_FETCH_JUST_SV is true.  */
415                 if (!keysv) {
416                     keysv = newSVpvn_utf8(key, klen, is_utf8);
417                 } else {
418                     keysv = newSVsv(keysv);
419                 }
420                 sv = sv_newmortal();
421                 mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY);
422
423                 /* grab a fake HE/HEK pair from the pool or make a new one */
424                 entry = PL_hv_fetch_ent_mh;
425                 if (entry)
426                     PL_hv_fetch_ent_mh = HeNEXT(entry);
427                 else {
428                     char *k;
429                     entry = new_HE();
430                     Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
431                     HeKEY_hek(entry) = (HEK*)k;
432                 }
433                 HeNEXT(entry) = NULL;
434                 HeSVKEY_set(entry, keysv);
435                 HeVAL(entry) = sv;
436                 sv_upgrade(sv, SVt_PVLV);
437                 LvTYPE(sv) = 'T';
438                  /* so we can free entry when freeing sv */
439                 LvTARG(sv) = MUTABLE_SV(entry);
440
441                 /* XXX remove at some point? */
442                 if (flags & HVhek_FREEKEY)
443                     Safefree(key);
444
445                 if (return_svp) {
446                     return entry ? (void *) &HeVAL(entry) : NULL;
447                 }
448                 return (void *) entry;
449             }
450 #ifdef ENV_IS_CASELESS
451             else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
452                 U32 i;
453                 for (i = 0; i < klen; ++i)
454                     if (isLOWER(key[i])) {
455                         /* Would be nice if we had a routine to do the
456                            copy and upercase in a single pass through.  */
457                         const char * const nkey = strupr(savepvn(key,klen));
458                         /* Note that this fetch is for nkey (the uppercased
459                            key) whereas the store is for key (the original)  */
460                         void *result = hv_common(hv, NULL, nkey, klen,
461                                                  HVhek_FREEKEY, /* free nkey */
462                                                  0 /* non-LVAL fetch */
463                                                  | HV_DISABLE_UVAR_XKEY
464                                                  | return_svp,
465                                                  NULL /* no value */,
466                                                  0 /* compute hash */);
467                         if (!result && (action & HV_FETCH_LVALUE)) {
468                             /* This call will free key if necessary.
469                                Do it this way to encourage compiler to tail
470                                call optimise.  */
471                             result = hv_common(hv, keysv, key, klen, flags,
472                                                HV_FETCH_ISSTORE
473                                                | HV_DISABLE_UVAR_XKEY
474                                                | return_svp,
475                                                newSV(0), hash);
476                         } else {
477                             if (flags & HVhek_FREEKEY)
478                                 Safefree(key);
479                         }
480                         return result;
481                     }
482             }
483 #endif
484         } /* ISFETCH */
485         else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
486             if (mg_find((const SV *)hv, PERL_MAGIC_tied)
487                 || SvGMAGICAL((const SV *)hv)) {
488                 /* I don't understand why hv_exists_ent has svret and sv,
489                    whereas hv_exists only had one.  */
490                 SV * const svret = sv_newmortal();
491                 sv = sv_newmortal();
492
493                 if (keysv || is_utf8) {
494                     if (!keysv) {
495                         keysv = newSVpvn_utf8(key, klen, TRUE);
496                     } else {
497                         keysv = newSVsv(keysv);
498                     }
499                     mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
500                 } else {
501                     mg_copy(MUTABLE_SV(hv), sv, key, klen);
502                 }
503                 if (flags & HVhek_FREEKEY)
504                     Safefree(key);
505                 {
506                   MAGIC * const mg = mg_find(sv, PERL_MAGIC_tiedelem);
507                   if (mg)
508                     magic_existspack(svret, mg);
509                 }
510                 /* This cast somewhat evil, but I'm merely using NULL/
511                    not NULL to return the boolean exists.
512                    And I know hv is not NULL.  */
513                 return SvTRUE_NN(svret) ? (void *)hv : NULL;
514                 }
515 #ifdef ENV_IS_CASELESS
516             else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
517                 /* XXX This code isn't UTF8 clean.  */
518                 char * const keysave = (char * const)key;
519                 /* Will need to free this, so set FREEKEY flag.  */
520                 key = savepvn(key,klen);
521                 key = (const char*)strupr((char*)key);
522                 is_utf8 = FALSE;
523                 hash = 0;
524                 keysv = 0;
525
526                 if (flags & HVhek_FREEKEY) {
527                     Safefree(keysave);
528                 }
529                 flags |= HVhek_FREEKEY;
530             }
531 #endif
532         } /* ISEXISTS */
533         else if (action & HV_FETCH_ISSTORE) {
534             bool needs_copy;
535             bool needs_store;
536             hv_magic_check (hv, &needs_copy, &needs_store);
537             if (needs_copy) {
538                 const bool save_taint = TAINT_get;
539                 if (keysv || is_utf8) {
540                     if (!keysv) {
541                         keysv = newSVpvn_utf8(key, klen, TRUE);
542                     }
543                     if (TAINTING_get)
544                         TAINT_set(SvTAINTED(keysv));
545                     keysv = sv_2mortal(newSVsv(keysv));
546                     mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
547                 } else {
548                     mg_copy(MUTABLE_SV(hv), val, key, klen);
549                 }
550
551                 TAINT_IF(save_taint);
552 #ifdef NO_TAINT_SUPPORT
553                 PERL_UNUSED_VAR(save_taint);
554 #endif
555                 if (!needs_store) {
556                     if (flags & HVhek_FREEKEY)
557                         Safefree(key);
558                     return NULL;
559                 }
560 #ifdef ENV_IS_CASELESS
561                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
562                     /* XXX This code isn't UTF8 clean.  */
563                     const char *keysave = key;
564                     /* Will need to free this, so set FREEKEY flag.  */
565                     key = savepvn(key,klen);
566                     key = (const char*)strupr((char*)key);
567                     is_utf8 = FALSE;
568                     hash = 0;
569                     keysv = 0;
570
571                     if (flags & HVhek_FREEKEY) {
572                         Safefree(keysave);
573                     }
574                     flags |= HVhek_FREEKEY;
575                 }
576 #endif
577             }
578         } /* ISSTORE */
579     } /* SvMAGICAL */
580
581     if (!HvARRAY(hv)) {
582         if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
583 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
584                  || (SvRMAGICAL((const SV *)hv)
585                      && mg_find((const SV *)hv, PERL_MAGIC_env))
586 #endif
587                                                                   ) {
588             char *array;
589             Newxz(array,
590                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
591                  char);
592             HvARRAY(hv) = (HE**)array;
593         }
594 #ifdef DYNAMIC_ENV_FETCH
595         else if (action & HV_FETCH_ISEXISTS) {
596             /* for an %ENV exists, if we do an insert it's by a recursive
597                store call, so avoid creating HvARRAY(hv) right now.  */
598         }
599 #endif
600         else {
601             /* XXX remove at some point? */
602             if (flags & HVhek_FREEKEY)
603                 Safefree(key);
604
605             return NULL;
606         }
607     }
608
609     if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) {
610         char * const keysave = (char *)key;
611         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
612         if (is_utf8)
613             flags |= HVhek_UTF8;
614         else
615             flags &= ~HVhek_UTF8;
616         if (key != keysave) {
617             if (flags & HVhek_FREEKEY)
618                 Safefree(keysave);
619             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
620             /* If the caller calculated a hash, it was on the sequence of
621                octets that are the UTF-8 form. We've now changed the sequence
622                of octets stored to that of the equivalent byte representation,
623                so the hash we need is different.  */
624             hash = 0;
625         }
626     }
627
628     if (keysv && (SvIsCOW_shared_hash(keysv))) {
629         if (HvSHAREKEYS(hv))
630             keysv_hek  = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
631         hash = SvSHARED_HASH(keysv);
632     }
633     else if (!hash)
634         PERL_HASH(hash, key, klen);
635
636     masked_flags = (flags & HVhek_MASK);
637
638 #ifdef DYNAMIC_ENV_FETCH
639     if (!HvARRAY(hv)) entry = NULL;
640     else
641 #endif
642     {
643         entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
644     }
645
646     if (!entry)
647         goto not_found;
648
649     if (keysv_hek) {
650         /* keysv is actually a HEK in disguise, so we can match just by
651          * comparing the HEK pointers in the HE chain. There is a slight
652          * caveat: on something like "\x80", which has both plain and utf8
653          * representations, perl's hashes do encoding-insensitive lookups,
654          * but preserve the encoding of the stored key. Thus a particular
655          * key could map to two different HEKs in PL_strtab. We only
656          * conclude 'not found' if all the flags are the same; otherwise
657          * we fall back to a full search (this should only happen in rare
658          * cases).
659          */
660         int keysv_flags = HEK_FLAGS(keysv_hek);
661         HE  *orig_entry = entry;
662
663         for (; entry; entry = HeNEXT(entry)) {
664             HEK *hek = HeKEY_hek(entry);
665             if (hek == keysv_hek)
666                 goto found;
667             if (HEK_FLAGS(hek) != keysv_flags)
668                 break; /* need to do full match */
669         }
670         if (!entry)
671             goto not_found;
672         /* failed on shortcut - do full search loop */
673         entry = orig_entry;
674     }
675
676     for (; entry; entry = HeNEXT(entry)) {
677         if (HeHASH(entry) != hash)              /* strings can't be equal */
678             continue;
679         if (HeKLEN(entry) != (I32)klen)
680             continue;
681         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
682             continue;
683         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
684             continue;
685
686       found:
687         if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
688             if (HeKFLAGS(entry) != masked_flags) {
689                 /* We match if HVhek_UTF8 bit in our flags and hash key's
690                    match.  But if entry was set previously with HVhek_WASUTF8
691                    and key now doesn't (or vice versa) then we should change
692                    the key's flag, as this is assignment.  */
693                 if (HvSHAREKEYS(hv)) {
694                     /* Need to swap the key we have for a key with the flags we
695                        need. As keys are shared we can't just write to the
696                        flag, so we share the new one, unshare the old one.  */
697                     HEK * const new_hek = share_hek_flags(key, klen, hash,
698                                                    masked_flags);
699                     unshare_hek (HeKEY_hek(entry));
700                     HeKEY_hek(entry) = new_hek;
701                 }
702                 else if (hv == PL_strtab) {
703                     /* PL_strtab is usually the only hash without HvSHAREKEYS,
704                        so putting this test here is cheap  */
705                     if (flags & HVhek_FREEKEY)
706                         Safefree(key);
707                     Perl_croak(aTHX_ S_strtab_error,
708                                action & HV_FETCH_LVALUE ? "fetch" : "store");
709                 }
710                 else
711                     HeKFLAGS(entry) = masked_flags;
712                 if (masked_flags & HVhek_ENABLEHVKFLAGS)
713                     HvHASKFLAGS_on(hv);
714             }
715             if (HeVAL(entry) == &PL_sv_placeholder) {
716                 /* yes, can store into placeholder slot */
717                 if (action & HV_FETCH_LVALUE) {
718                     if (SvMAGICAL(hv)) {
719                         /* This preserves behaviour with the old hv_fetch
720                            implementation which at this point would bail out
721                            with a break; (at "if we find a placeholder, we
722                            pretend we haven't found anything")
723
724                            That break mean that if a placeholder were found, it
725                            caused a call into hv_store, which in turn would
726                            check magic, and if there is no magic end up pretty
727                            much back at this point (in hv_store's code).  */
728                         break;
729                     }
730                     /* LVAL fetch which actually needs a store.  */
731                     val = newSV(0);
732                     HvPLACEHOLDERS(hv)--;
733                 } else {
734                     /* store */
735                     if (val != &PL_sv_placeholder)
736                         HvPLACEHOLDERS(hv)--;
737                 }
738                 HeVAL(entry) = val;
739             } else if (action & HV_FETCH_ISSTORE) {
740                 SvREFCNT_dec(HeVAL(entry));
741                 HeVAL(entry) = val;
742             }
743         } else if (HeVAL(entry) == &PL_sv_placeholder) {
744             /* if we find a placeholder, we pretend we haven't found
745                anything */
746             break;
747         }
748         if (flags & HVhek_FREEKEY)
749             Safefree(key);
750         if (return_svp) {
751             return (void *) &HeVAL(entry);
752         }
753         return entry;
754     }
755
756   not_found:
757 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
758     if (!(action & HV_FETCH_ISSTORE) 
759         && SvRMAGICAL((const SV *)hv)
760         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
761         unsigned long len;
762         const char * const env = PerlEnv_ENVgetenv_len(key,&len);
763         if (env) {
764             sv = newSVpvn(env,len);
765             SvTAINTED_on(sv);
766             return hv_common(hv, keysv, key, klen, flags,
767                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
768                              sv, hash);
769         }
770     }
771 #endif
772
773     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
774         hv_notallowed(flags, key, klen,
775                         "Attempt to access disallowed key '%" SVf "' in"
776                         " a restricted hash");
777     }
778     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
779         /* Not doing some form of store, so return failure.  */
780         if (flags & HVhek_FREEKEY)
781             Safefree(key);
782         return NULL;
783     }
784     if (action & HV_FETCH_LVALUE) {
785         val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0);
786         if (SvMAGICAL(hv)) {
787             /* At this point the old hv_fetch code would call to hv_store,
788                which in turn might do some tied magic. So we need to make that
789                magic check happen.  */
790             /* gonna assign to this, so it better be there */
791             /* If a fetch-as-store fails on the fetch, then the action is to
792                recurse once into "hv_store". If we didn't do this, then that
793                recursive call would call the key conversion routine again.
794                However, as we replace the original key with the converted
795                key, this would result in a double conversion, which would show
796                up as a bug if the conversion routine is not idempotent.
797                Hence the use of HV_DISABLE_UVAR_XKEY.  */
798             return hv_common(hv, keysv, key, klen, flags,
799                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
800                              val, hash);
801             /* XXX Surely that could leak if the fetch-was-store fails?
802                Just like the hv_fetch.  */
803         }
804     }
805
806     /* Welcome to hv_store...  */
807
808     if (!HvARRAY(hv)) {
809         /* Not sure if we can get here.  I think the only case of oentry being
810            NULL is for %ENV with dynamic env fetch.  But that should disappear
811            with magic in the previous code.  */
812         char *array;
813         Newxz(array,
814              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
815              char);
816         HvARRAY(hv) = (HE**)array;
817     }
818
819     oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
820
821     entry = new_HE();
822     /* share_hek_flags will do the free for us.  This might be considered
823        bad API design.  */
824     if (HvSHAREKEYS(hv))
825         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
826     else if (hv == PL_strtab) {
827         /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
828            this test here is cheap  */
829         if (flags & HVhek_FREEKEY)
830             Safefree(key);
831         Perl_croak(aTHX_ S_strtab_error,
832                    action & HV_FETCH_LVALUE ? "fetch" : "store");
833     }
834     else                                       /* gotta do the real thing */
835         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
836     HeVAL(entry) = val;
837
838 #ifdef PERL_HASH_RANDOMIZE_KEYS
839     /* This logic semi-randomizes the insert order in a bucket.
840      * Either we insert into the top, or the slot below the top,
841      * making it harder to see if there is a collision. We also
842      * reset the iterator randomizer if there is one.
843      */
844     in_collision = *oentry != NULL;
845     if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
846         PL_hash_rand_bits++;
847         PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
848         if ( PL_hash_rand_bits & 1 ) {
849             HeNEXT(entry) = HeNEXT(*oentry);
850             HeNEXT(*oentry) = entry;
851         } else {
852             HeNEXT(entry) = *oentry;
853             *oentry = entry;
854         }
855     } else
856 #endif
857     {
858         HeNEXT(entry) = *oentry;
859         *oentry = entry;
860     }
861 #ifdef PERL_HASH_RANDOMIZE_KEYS
862     if (SvOOK(hv)) {
863         /* Currently this makes various tests warn in annoying ways.
864          * So Silenced for now. - Yves | bogus end of comment =>* /
865         if (HvAUX(hv)->xhv_riter != -1) {
866             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
867                              "[TESTING] Inserting into a hash during each() traversal results in undefined behavior"
868                              pTHX__FORMAT
869                              pTHX__VALUE);
870         }
871         */
872         if (PL_HASH_RAND_BITS_ENABLED) {
873             if (PL_HASH_RAND_BITS_ENABLED == 1)
874                 PL_hash_rand_bits += (PTRV)entry + 1;  /* we don't bother to use ptr_hash here */
875             PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
876         }
877         HvAUX(hv)->xhv_rand= (U32)PL_hash_rand_bits;
878     }
879 #endif
880
881     if (val == &PL_sv_placeholder)
882         HvPLACEHOLDERS(hv)++;
883     if (masked_flags & HVhek_ENABLEHVKFLAGS)
884         HvHASKFLAGS_on(hv);
885
886     xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
887     if ( in_collision && DO_HSPLIT(xhv) ) {
888         const STRLEN oldsize = xhv->xhv_max + 1;
889         const U32 items = (U32)HvPLACEHOLDERS_get(hv);
890
891         if (items /* hash has placeholders  */
892             && !SvREADONLY(hv) /* but is not a restricted hash */) {
893             /* If this hash previously was a "restricted hash" and had
894                placeholders, but the "restricted" flag has been turned off,
895                then the placeholders no longer serve any useful purpose.
896                However, they have the downsides of taking up RAM, and adding
897                extra steps when finding used values. It's safe to clear them
898                at this point, even though Storable rebuilds restricted hashes by
899                putting in all the placeholders (first) before turning on the
900                readonly flag, because Storable always pre-splits the hash.
901                If we're lucky, then we may clear sufficient placeholders to
902                avoid needing to split the hash at all.  */
903             clear_placeholders(hv, items);
904             if (DO_HSPLIT(xhv))
905                 hsplit(hv, oldsize, oldsize * 2);
906         } else
907             hsplit(hv, oldsize, oldsize * 2);
908     }
909
910     if (return_svp) {
911         return entry ? (void *) &HeVAL(entry) : NULL;
912     }
913     return (void *) entry;
914 }
915
916 STATIC void
917 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
918 {
919     const MAGIC *mg = SvMAGIC(hv);
920
921     PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
922
923     *needs_copy = FALSE;
924     *needs_store = TRUE;
925     while (mg) {
926         if (isUPPER(mg->mg_type)) {
927             *needs_copy = TRUE;
928             if (mg->mg_type == PERL_MAGIC_tied) {
929                 *needs_store = FALSE;
930                 return; /* We've set all there is to set. */
931             }
932         }
933         mg = mg->mg_moremagic;
934     }
935 }
936
937 /*
938 =for apidoc hv_scalar
939
940 Evaluates the hash in scalar context and returns the result.
941
942 When the hash is tied dispatches through to the SCALAR method,
943 otherwise returns a mortal SV containing the number of keys
944 in the hash.
945
946 Note, prior to 5.25 this function returned what is now
947 returned by the hv_bucket_ratio() function.
948
949 =cut
950 */
951
952 SV *
953 Perl_hv_scalar(pTHX_ HV *hv)
954 {
955     SV *sv;
956
957     PERL_ARGS_ASSERT_HV_SCALAR;
958
959     if (SvRMAGICAL(hv)) {
960         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
961         if (mg)
962             return magic_scalarpack(hv, mg);
963     }
964
965     sv = sv_newmortal();
966     sv_setuv(sv, HvUSEDKEYS(hv));
967
968     return sv;
969 }
970
971
972 /*
973 hv_pushkv(): push all the keys and/or values of a hash onto the stack.
974 The rough Perl equivalents:
975     () = %hash;
976     () = keys %hash;
977     () = values %hash;
978
979 Resets the hash's iterator.
980
981 flags : 1   = push keys
982         2   = push values
983         1|2 = push keys and values
984         XXX use symbolic flag constants at some point?
985 I might unroll the non-tied hv_iternext() in here at some point - DAPM
986 */
987
988 void
989 Perl_hv_pushkv(pTHX_ HV *hv, U32 flags)
990 {
991     HE *entry;
992     bool tied = SvRMAGICAL(hv) && (mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied)
993 #ifdef DYNAMIC_ENV_FETCH  /* might not know number of keys yet */
994                                    || mg_find(MUTABLE_SV(hv), PERL_MAGIC_env)
995 #endif
996                                   );
997     dSP;
998
999     PERL_ARGS_ASSERT_HV_PUSHKV;
1000     assert(flags); /* must be pushing at least one of keys and values */
1001
1002     (void)hv_iterinit(hv);
1003
1004     if (tied) {
1005         SSize_t ext = (flags == 3) ? 2 : 1;
1006         while ((entry = hv_iternext(hv))) {
1007             EXTEND(SP, ext);
1008             if (flags & 1)
1009                 PUSHs(hv_iterkeysv(entry));
1010             if (flags & 2)
1011                 PUSHs(hv_iterval(hv, entry));
1012         }
1013     }
1014     else {
1015         Size_t nkeys = HvUSEDKEYS(hv);
1016         SSize_t ext;
1017
1018         if (!nkeys)
1019             return;
1020
1021         /* 2*nkeys() should never be big enough to truncate or wrap */
1022         assert(nkeys <= (SSize_t_MAX >> 1));
1023         ext = nkeys * ((flags == 3) ? 2 : 1);
1024
1025         EXTEND_MORTAL(nkeys);
1026         EXTEND(SP, ext);
1027
1028         while ((entry = hv_iternext(hv))) {
1029             if (flags & 1) {
1030                 SV *keysv = newSVhek(HeKEY_hek(entry));
1031                 SvTEMP_on(keysv);
1032                 PL_tmps_stack[++PL_tmps_ix] = keysv;
1033                 PUSHs(keysv);
1034             }
1035             if (flags & 2)
1036                 PUSHs(HeVAL(entry));
1037         }
1038     }
1039
1040     PUTBACK;
1041 }
1042
1043
1044 /*
1045 =for apidoc hv_bucket_ratio
1046
1047 If the hash is tied dispatches through to the SCALAR tied method,
1048 otherwise if the hash contains no keys returns 0, otherwise returns
1049 a mortal sv containing a string specifying the number of used buckets,
1050 followed by a slash, followed by the number of available buckets.
1051
1052 This function is expensive, it must scan all of the buckets
1053 to determine which are used, and the count is NOT cached.
1054 In a large hash this could be a lot of buckets.
1055
1056 =cut
1057 */
1058
1059 SV *
1060 Perl_hv_bucket_ratio(pTHX_ HV *hv)
1061 {
1062     SV *sv;
1063
1064     PERL_ARGS_ASSERT_HV_BUCKET_RATIO;
1065
1066     if (SvRMAGICAL(hv)) {
1067         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
1068         if (mg)
1069             return magic_scalarpack(hv, mg);
1070     }
1071
1072     if (HvUSEDKEYS((HV *)hv)) {
1073         sv = sv_newmortal();
1074         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
1075                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
1076     }
1077     else
1078         sv = &PL_sv_zero;
1079     
1080     return sv;
1081 }
1082
1083 /*
1084 =for apidoc hv_delete
1085
1086 Deletes a key/value pair in the hash.  The value's SV is removed from
1087 the hash, made mortal, and returned to the caller.  The absolute
1088 value of C<klen> is the length of the key.  If C<klen> is negative the
1089 key is assumed to be in UTF-8-encoded Unicode.  The C<flags> value
1090 will normally be zero; if set to C<G_DISCARD> then C<NULL> will be returned.
1091 C<NULL> will also be returned if the key is not found.
1092
1093 =for apidoc hv_delete_ent
1094
1095 Deletes a key/value pair in the hash.  The value SV is removed from the hash,
1096 made mortal, and returned to the caller.  The C<flags> value will normally be
1097 zero; if set to C<G_DISCARD> then C<NULL> will be returned.  C<NULL> will also
1098 be returned if the key is not found.  C<hash> can be a valid precomputed hash
1099 value, or 0 to ask for it to be computed.
1100
1101 =cut
1102 */
1103
1104 STATIC SV *
1105 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
1106                    int k_flags, I32 d_flags, U32 hash)
1107 {
1108     XPVHV* xhv;
1109     HE *entry;
1110     HE **oentry;
1111     HE **first_entry;
1112     bool is_utf8 = cBOOL(k_flags & HVhek_UTF8);
1113     int masked_flags;
1114     HEK *keysv_hek = NULL;
1115     U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
1116     SV *sv;
1117     GV *gv = NULL;
1118     HV *stash = NULL;
1119
1120     if (SvRMAGICAL(hv)) {
1121         bool needs_copy;
1122         bool needs_store;
1123         hv_magic_check (hv, &needs_copy, &needs_store);
1124
1125         if (needs_copy) {
1126             SV *sv;
1127             entry = (HE *) hv_common(hv, keysv, key, klen,
1128                                      k_flags & ~HVhek_FREEKEY,
1129                                      HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
1130                                      NULL, hash);
1131             sv = entry ? HeVAL(entry) : NULL;
1132             if (sv) {
1133                 if (SvMAGICAL(sv)) {
1134                     mg_clear(sv);
1135                 }
1136                 if (!needs_store) {
1137                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1138                         /* No longer an element */
1139                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
1140                         return sv;
1141                     }           
1142                     return NULL;                /* element cannot be deleted */
1143                 }
1144 #ifdef ENV_IS_CASELESS
1145                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
1146                     /* XXX This code isn't UTF8 clean.  */
1147                     keysv = newSVpvn_flags(key, klen, SVs_TEMP);
1148                     if (k_flags & HVhek_FREEKEY) {
1149                         Safefree(key);
1150                     }
1151                     key = strupr(SvPVX(keysv));
1152                     is_utf8 = 0;
1153                     k_flags = 0;
1154                     hash = 0;
1155                 }
1156 #endif
1157             }
1158         }
1159     }
1160     xhv = (XPVHV*)SvANY(hv);
1161     if (!HvARRAY(hv))
1162         return NULL;
1163
1164     if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
1165         const char * const keysave = key;
1166         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1167
1168         if (is_utf8)
1169             k_flags |= HVhek_UTF8;
1170         else
1171             k_flags &= ~HVhek_UTF8;
1172         if (key != keysave) {
1173             if (k_flags & HVhek_FREEKEY) {
1174                 /* This shouldn't happen if our caller does what we expect,
1175                    but strictly the API allows it.  */
1176                 Safefree(keysave);
1177             }
1178             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1179         }
1180         HvHASKFLAGS_on(MUTABLE_SV(hv));
1181     }
1182
1183     if (keysv && (SvIsCOW_shared_hash(keysv))) {
1184         if (HvSHAREKEYS(hv))
1185             keysv_hek  = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
1186         hash = SvSHARED_HASH(keysv);
1187     }
1188     else if (!hash)
1189         PERL_HASH(hash, key, klen);
1190
1191     masked_flags = (k_flags & HVhek_MASK);
1192
1193     first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1194     entry = *oentry;
1195
1196     if (!entry)
1197         goto not_found;
1198
1199     if (keysv_hek) {
1200         /* keysv is actually a HEK in disguise, so we can match just by
1201          * comparing the HEK pointers in the HE chain. There is a slight
1202          * caveat: on something like "\x80", which has both plain and utf8
1203          * representations, perl's hashes do encoding-insensitive lookups,
1204          * but preserve the encoding of the stored key. Thus a particular
1205          * key could map to two different HEKs in PL_strtab. We only
1206          * conclude 'not found' if all the flags are the same; otherwise
1207          * we fall back to a full search (this should only happen in rare
1208          * cases).
1209          */
1210         int keysv_flags = HEK_FLAGS(keysv_hek);
1211
1212         for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1213             HEK *hek = HeKEY_hek(entry);
1214             if (hek == keysv_hek)
1215                 goto found;
1216             if (HEK_FLAGS(hek) != keysv_flags)
1217                 break; /* need to do full match */
1218         }
1219         if (!entry)
1220             goto not_found;
1221         /* failed on shortcut - do full search loop */
1222         oentry = first_entry;
1223         entry = *oentry;
1224     }
1225
1226     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1227         if (HeHASH(entry) != hash)              /* strings can't be equal */
1228             continue;
1229         if (HeKLEN(entry) != (I32)klen)
1230             continue;
1231         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
1232             continue;
1233         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1234             continue;
1235
1236       found:
1237         if (hv == PL_strtab) {
1238             if (k_flags & HVhek_FREEKEY)
1239                 Safefree(key);
1240             Perl_croak(aTHX_ S_strtab_error, "delete");
1241         }
1242
1243         /* if placeholder is here, it's already been deleted.... */
1244         if (HeVAL(entry) == &PL_sv_placeholder) {
1245             if (k_flags & HVhek_FREEKEY)
1246                 Safefree(key);
1247             return NULL;
1248         }
1249         if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1250             hv_notallowed(k_flags, key, klen,
1251                             "Attempt to delete readonly key '%" SVf "' from"
1252                             " a restricted hash");
1253         }
1254         if (k_flags & HVhek_FREEKEY)
1255             Safefree(key);
1256
1257         /* If this is a stash and the key ends with ::, then someone is 
1258          * deleting a package.
1259          */
1260         if (HeVAL(entry) && HvENAME_get(hv)) {
1261                 gv = (GV *)HeVAL(entry);
1262                 if (keysv) key = SvPV(keysv, klen);
1263                 if ((
1264                      (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1265                       ||
1266                      (klen == 1 && key[0] == ':')
1267                     )
1268                  && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1269                  && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
1270                  && HvENAME_get(stash)) {
1271                         /* A previous version of this code checked that the
1272                          * GV was still in the symbol table by fetching the
1273                          * GV with its name. That is not necessary (and
1274                          * sometimes incorrect), as HvENAME cannot be set
1275                          * on hv if it is not in the symtab. */
1276                         mro_changes = 2;
1277                         /* Hang on to it for a bit. */
1278                         SvREFCNT_inc_simple_void_NN(
1279                          sv_2mortal((SV *)gv)
1280                         );
1281                 }
1282                 else if (memEQs(key, klen, "ISA") && GvAV(gv)) {
1283                     AV *isa = GvAV(gv);
1284                     MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa);
1285
1286                     mro_changes = 1;
1287                     if (mg) {
1288                         if (mg->mg_obj == (SV*)gv) {
1289                             /* This is the only stash this ISA was used for.
1290                              * The isaelem magic asserts if there's no
1291                              * isa magic on the array, so explicitly
1292                              * remove the magic on both the array and its
1293                              * elements.  @ISA shouldn't be /too/ large.
1294                              */
1295                             SV **svp, **end;
1296                         strip_magic:
1297                             svp = AvARRAY(isa);
1298                             end = svp + (AvFILLp(isa)+1);
1299                             while (svp < end) {
1300                                 if (*svp)
1301                                     mg_free_type(*svp, PERL_MAGIC_isaelem);
1302                                 ++svp;
1303                             }
1304                             mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
1305                         }
1306                         else {
1307                             /* mg_obj is an array of stashes
1308                                Note that the array doesn't keep a reference
1309                                count on the stashes.
1310                              */
1311                             AV *av = (AV*)mg->mg_obj;
1312                             SV **svp, **arrayp;
1313                             SSize_t index;
1314                             SSize_t items;
1315
1316                             assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
1317
1318                             /* remove the stash from the magic array */
1319                             arrayp = svp = AvARRAY(av);
1320                             items = AvFILLp(av) + 1;
1321                             if (items == 1) {
1322                                 assert(*arrayp == (SV *)gv);
1323                                 mg->mg_obj = NULL;
1324                                 /* avoid a double free on the last stash */
1325                                 AvFILLp(av) = -1;
1326                                 /* The magic isn't MGf_REFCOUNTED, so release
1327                                  * the array manually.
1328                                  */
1329                                 SvREFCNT_dec_NN(av);
1330                                 goto strip_magic;
1331                             }
1332                             else {
1333                                 while (items--) {
1334                                     if (*svp == (SV*)gv)
1335                                         break;
1336                                     ++svp;
1337                                 }
1338                                 index = svp - arrayp;
1339                                 assert(index >= 0 && index <= AvFILLp(av));
1340                                 if (index < AvFILLp(av)) {
1341                                     arrayp[index] = arrayp[AvFILLp(av)];
1342                                 }
1343                                 arrayp[AvFILLp(av)] = NULL;
1344                                 --AvFILLp(av);
1345                             }
1346                         }
1347                     }
1348                 }
1349         }
1350
1351         sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
1352         HeVAL(entry) = &PL_sv_placeholder;
1353         if (sv) {
1354             /* deletion of method from stash */
1355             if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1356              && HvENAME_get(hv))
1357                 mro_method_changed_in(hv);
1358         }
1359
1360         /*
1361          * If a restricted hash, rather than really deleting the entry, put
1362          * a placeholder there. This marks the key as being "approved", so
1363          * we can still access via not-really-existing key without raising
1364          * an error.
1365          */
1366         if (SvREADONLY(hv))
1367             /* We'll be saving this slot, so the number of allocated keys
1368              * doesn't go down, but the number placeholders goes up */
1369             HvPLACEHOLDERS(hv)++;
1370         else {
1371             *oentry = HeNEXT(entry);
1372             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1373                 HvLAZYDEL_on(hv);
1374             else {
1375                 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1376                     entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1377                     HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1378                 hv_free_ent(hv, entry);
1379             }
1380             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1381             if (xhv->xhv_keys == 0)
1382                 HvHASKFLAGS_off(hv);
1383         }
1384
1385         if (d_flags & G_DISCARD) {
1386             SvREFCNT_dec(sv);
1387             sv = NULL;
1388         }
1389
1390         if (mro_changes == 1) mro_isa_changed_in(hv);
1391         else if (mro_changes == 2)
1392             mro_package_moved(NULL, stash, gv, 1);
1393
1394         return sv;
1395     }
1396
1397   not_found:
1398     if (SvREADONLY(hv)) {
1399         hv_notallowed(k_flags, key, klen,
1400                         "Attempt to delete disallowed key '%" SVf "' from"
1401                         " a restricted hash");
1402     }
1403
1404     if (k_flags & HVhek_FREEKEY)
1405         Safefree(key);
1406     return NULL;
1407 }
1408
1409
1410 STATIC void
1411 S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1412 {
1413     STRLEN i = 0;
1414     char *a = (char*) HvARRAY(hv);
1415     HE **aep;
1416
1417     bool do_aux= (
1418         /* already have an HvAUX(hv) so we have to move it */
1419         SvOOK(hv) ||
1420         /* no HvAUX() but array we are going to allocate is large enough
1421          * there is no point in saving the space for the iterator, and
1422          * speeds up later traversals. */
1423         ( ( hv != PL_strtab ) && ( newsize >= PERL_HV_ALLOC_AUX_SIZE ) )
1424     );
1425
1426     PERL_ARGS_ASSERT_HSPLIT;
1427
1428     PL_nomemok = TRUE;
1429     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1430           + (do_aux ? sizeof(struct xpvhv_aux) : 0), char);
1431     PL_nomemok = FALSE;
1432     if (!a) {
1433       return;
1434     }
1435
1436 #ifdef PERL_HASH_RANDOMIZE_KEYS
1437     /* the idea of this is that we create a "random" value by hashing the address of
1438      * the array, we then use the low bit to decide if we insert at the top, or insert
1439      * second from top. After each such insert we rotate the hashed value. So we can
1440      * use the same hashed value over and over, and in normal build environments use
1441      * very few ops to do so. ROTL32() should produce a single machine operation. */
1442     if (PL_HASH_RAND_BITS_ENABLED) {
1443         if (PL_HASH_RAND_BITS_ENABLED == 1)
1444             PL_hash_rand_bits += ptr_hash((PTRV)a);
1445         PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1446     }
1447 #endif
1448     HvARRAY(hv) = (HE**) a;
1449     HvMAX(hv) = newsize - 1;
1450     /* before we zero the newly added memory, we
1451      * need to deal with the aux struct that may be there
1452      * or have been allocated by us*/
1453     if (do_aux) {
1454         struct xpvhv_aux *const dest
1455             = (struct xpvhv_aux*) &a[newsize * sizeof(HE*)];
1456         if (SvOOK(hv)) {
1457             /* alread have an aux, copy the old one in place. */
1458             Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
1459             /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
1460 #ifdef PERL_HASH_RANDOMIZE_KEYS
1461             dest->xhv_rand = (U32)PL_hash_rand_bits;
1462 #endif
1463         } else {
1464             /* no existing aux structure, but we allocated space for one
1465              * so initialize it properly. This unrolls hv_auxinit() a bit,
1466              * since we have to do the realloc anyway. */
1467             /* first we set the iterator's xhv_rand so it can be copied into lastrand below */
1468 #ifdef PERL_HASH_RANDOMIZE_KEYS
1469             dest->xhv_rand = (U32)PL_hash_rand_bits;
1470 #endif
1471             /* this is the "non realloc" part of the hv_auxinit() */
1472             (void)hv_auxinit_internal(dest);
1473             /* Turn on the OOK flag */
1474             SvOOK_on(hv);
1475         }
1476     }
1477     /* now we can safely clear the second half */
1478     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1479
1480     if (!HvTOTALKEYS(hv))       /* skip rest if no entries */
1481         return;
1482
1483     newsize--;
1484     aep = (HE**)a;
1485     do {
1486         HE **oentry = aep + i;
1487         HE *entry = aep[i];
1488
1489         if (!entry)                             /* non-existent */
1490             continue;
1491         do {
1492             U32 j = (HeHASH(entry) & newsize);
1493             if (j != (U32)i) {
1494                 *oentry = HeNEXT(entry);
1495 #ifdef PERL_HASH_RANDOMIZE_KEYS
1496                 /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
1497                  * insert to top, otherwise rotate the bucket rand 1 bit,
1498                  * and use the new low bit to decide if we insert at top,
1499                  * or next from top. IOW, we only rotate on a collision.*/
1500                 if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
1501                     PL_hash_rand_bits+= ROTL32(HeHASH(entry), 17);
1502                     PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
1503                     if (PL_hash_rand_bits & 1) {
1504                         HeNEXT(entry)= HeNEXT(aep[j]);
1505                         HeNEXT(aep[j])= entry;
1506                     } else {
1507                         /* Note, this is structured in such a way as the optimizer
1508                         * should eliminate the duplicated code here and below without
1509                         * us needing to explicitly use a goto. */
1510                         HeNEXT(entry) = aep[j];
1511                         aep[j] = entry;
1512                     }
1513                 } else
1514 #endif
1515                 {
1516                     /* see comment above about duplicated code */
1517                     HeNEXT(entry) = aep[j];
1518                     aep[j] = entry;
1519                 }
1520             }
1521             else {
1522                 oentry = &HeNEXT(entry);
1523             }
1524             entry = *oentry;
1525         } while (entry);
1526     } while (i++ < oldsize);
1527 }
1528
1529 void
1530 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1531 {
1532     XPVHV* xhv = (XPVHV*)SvANY(hv);
1533     const I32 oldsize = (I32) xhv->xhv_max+1;       /* HvMAX(hv)+1 */
1534     I32 newsize;
1535     I32 wantsize;
1536     I32 trysize;
1537     char *a;
1538
1539     PERL_ARGS_ASSERT_HV_KSPLIT;
1540
1541     wantsize = (I32) newmax;                            /* possible truncation here */
1542     if (wantsize != newmax)
1543         return;
1544
1545     wantsize= wantsize + (wantsize >> 1);           /* wantsize *= 1.5 */
1546     if (wantsize < newmax)                          /* overflow detection */
1547         return;
1548
1549     newsize = oldsize;
1550     while (wantsize > newsize) {
1551         trysize = newsize << 1;
1552         if (trysize > newsize) {
1553             newsize = trysize;
1554         } else {
1555             /* we overflowed */
1556             return;
1557         }
1558     }
1559
1560     if (newsize <= oldsize)
1561         return;                                            /* overflow detection */
1562
1563     a = (char *) HvARRAY(hv);
1564     if (a) {
1565         hsplit(hv, oldsize, newsize);
1566     } else {
1567         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1568         xhv->xhv_max = newsize - 1;
1569         HvARRAY(hv) = (HE **) a;
1570     }
1571 }
1572
1573 /* IMO this should also handle cases where hv_max is smaller than hv_keys
1574  * as tied hashes could play silly buggers and mess us around. We will
1575  * do the right thing during hv_store() afterwards, but still - Yves */
1576 #define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
1577     /* Can we use fewer buckets? (hv_max is always 2^n-1) */        \
1578     if (hv_max < PERL_HASH_DEFAULT_HvMAX) {                         \
1579         hv_max = PERL_HASH_DEFAULT_HvMAX;                           \
1580     } else {                                                        \
1581         while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
1582             hv_max = hv_max / 2;                                    \
1583     }                                                               \
1584     HvMAX(hv) = hv_max;                                             \
1585 } STMT_END
1586
1587
1588 HV *
1589 Perl_newHVhv(pTHX_ HV *ohv)
1590 {
1591     HV * const hv = newHV();
1592     STRLEN hv_max;
1593
1594     if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
1595         return hv;
1596     hv_max = HvMAX(ohv);
1597
1598     if (!SvMAGICAL((const SV *)ohv)) {
1599         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1600         STRLEN i;
1601         const bool shared = !!HvSHAREKEYS(ohv);
1602         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1603         char *a;
1604         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1605         ents = (HE**)a;
1606
1607         /* In each bucket... */
1608         for (i = 0; i <= hv_max; i++) {
1609             HE *prev = NULL;
1610             HE *oent = oents[i];
1611
1612             if (!oent) {
1613                 ents[i] = NULL;
1614                 continue;
1615             }
1616
1617             /* Copy the linked list of entries. */
1618             for (; oent; oent = HeNEXT(oent)) {
1619                 const U32 hash   = HeHASH(oent);
1620                 const char * const key = HeKEY(oent);
1621                 const STRLEN len = HeKLEN(oent);
1622                 const int flags  = HeKFLAGS(oent);
1623                 HE * const ent   = new_HE();
1624                 SV *const val    = HeVAL(oent);
1625
1626                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1627                 HeKEY_hek(ent)
1628                     = shared ? share_hek_flags(key, len, hash, flags)
1629                              :  save_hek_flags(key, len, hash, flags);
1630                 if (prev)
1631                     HeNEXT(prev) = ent;
1632                 else
1633                     ents[i] = ent;
1634                 prev = ent;
1635                 HeNEXT(ent) = NULL;
1636             }
1637         }
1638
1639         HvMAX(hv)   = hv_max;
1640         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1641         HvARRAY(hv) = ents;
1642     } /* not magical */
1643     else {
1644         /* Iterate over ohv, copying keys and values one at a time. */
1645         HE *entry;
1646         const I32 riter = HvRITER_get(ohv);
1647         HE * const eiter = HvEITER_get(ohv);
1648         STRLEN hv_keys = HvTOTALKEYS(ohv);
1649
1650         HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1651
1652         hv_iterinit(ohv);
1653         while ((entry = hv_iternext_flags(ohv, 0))) {
1654             SV *val = hv_iterval(ohv,entry);
1655             SV * const keysv = HeSVKEY(entry);
1656             val = SvIMMORTAL(val) ? val : newSVsv(val);
1657             if (keysv)
1658                 (void)hv_store_ent(hv, keysv, val, 0);
1659             else
1660                 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1661                                  HeHASH(entry), HeKFLAGS(entry));
1662         }
1663         HvRITER_set(ohv, riter);
1664         HvEITER_set(ohv, eiter);
1665     }
1666
1667     return hv;
1668 }
1669
1670 /*
1671 =for apidoc hv_copy_hints_hv
1672
1673 A specialised version of L</newHVhv> for copying C<%^H>.  C<ohv> must be
1674 a pointer to a hash (which may have C<%^H> magic, but should be generally
1675 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1676 of C<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1677 added to it.  A pointer to the new hash is returned.
1678
1679 =cut
1680 */
1681
1682 HV *
1683 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1684 {
1685     HV * const hv = newHV();
1686
1687     if (ohv) {
1688         STRLEN hv_max = HvMAX(ohv);
1689         STRLEN hv_keys = HvTOTALKEYS(ohv);
1690         HE *entry;
1691         const I32 riter = HvRITER_get(ohv);
1692         HE * const eiter = HvEITER_get(ohv);
1693
1694         ENTER;
1695         SAVEFREESV(hv);
1696
1697         HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1698
1699         hv_iterinit(ohv);
1700         while ((entry = hv_iternext_flags(ohv, 0))) {
1701             SV *const sv = newSVsv(hv_iterval(ohv,entry));
1702             SV *heksv = HeSVKEY(entry);
1703             if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1704             if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1705                      (char *)heksv, HEf_SVKEY);
1706             if (heksv == HeSVKEY(entry))
1707                 (void)hv_store_ent(hv, heksv, sv, 0);
1708             else {
1709                 (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1710                                  HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1711                 SvREFCNT_dec_NN(heksv);
1712             }
1713         }
1714         HvRITER_set(ohv, riter);
1715         HvEITER_set(ohv, eiter);
1716
1717         SvREFCNT_inc_simple_void_NN(hv);
1718         LEAVE;
1719     }
1720     hv_magic(hv, NULL, PERL_MAGIC_hints);
1721     return hv;
1722 }
1723 #undef HV_SET_MAX_ADJUSTED_FOR_KEYS
1724
1725 /* like hv_free_ent, but returns the SV rather than freeing it */
1726 STATIC SV*
1727 S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
1728 {
1729     SV *val;
1730
1731     PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1732
1733     val = HeVAL(entry);
1734     if (HeKLEN(entry) == HEf_SVKEY) {
1735         SvREFCNT_dec(HeKEY_sv(entry));
1736         Safefree(HeKEY_hek(entry));
1737     }
1738     else if (HvSHAREKEYS(hv))
1739         unshare_hek(HeKEY_hek(entry));
1740     else
1741         Safefree(HeKEY_hek(entry));
1742     del_HE(entry);
1743     return val;
1744 }
1745
1746
1747 void
1748 Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
1749 {
1750     SV *val;
1751
1752     PERL_ARGS_ASSERT_HV_FREE_ENT;
1753
1754     if (!entry)
1755         return;
1756     val = hv_free_ent_ret(hv, entry);
1757     SvREFCNT_dec(val);
1758 }
1759
1760
1761 void
1762 Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
1763 {
1764     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1765
1766     if (!entry)
1767         return;
1768     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1769     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1770     if (HeKLEN(entry) == HEf_SVKEY) {
1771         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1772     }
1773     hv_free_ent(hv, entry);
1774 }
1775
1776 /*
1777 =for apidoc hv_clear
1778
1779 Frees all the elements of a hash, leaving it empty.
1780 The XS equivalent of C<%hash = ()>.  See also L</hv_undef>.
1781
1782 See L</av_clear> for a note about the hash possibly being invalid on
1783 return.
1784
1785 =cut
1786 */
1787
1788 void
1789 Perl_hv_clear(pTHX_ HV *hv)
1790 {
1791     SSize_t orig_ix;
1792
1793     XPVHV* xhv;
1794     if (!hv)
1795         return;
1796
1797     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1798
1799     xhv = (XPVHV*)SvANY(hv);
1800
1801     /* avoid hv being freed when calling destructors below */
1802     EXTEND_MORTAL(1);
1803     PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
1804     orig_ix = PL_tmps_ix;
1805     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1806         /* restricted hash: convert all keys to placeholders */
1807         STRLEN i;
1808         for (i = 0; i <= xhv->xhv_max; i++) {
1809             HE *entry = (HvARRAY(hv))[i];
1810             for (; entry; entry = HeNEXT(entry)) {
1811                 /* not already placeholder */
1812                 if (HeVAL(entry) != &PL_sv_placeholder) {
1813                     if (HeVAL(entry)) {
1814                         if (SvREADONLY(HeVAL(entry))) {
1815                             SV* const keysv = hv_iterkeysv(entry);
1816                             Perl_croak_nocontext(
1817                                 "Attempt to delete readonly key '%" SVf "' from a restricted hash",
1818                                 (void*)keysv);
1819                         }
1820                         SvREFCNT_dec_NN(HeVAL(entry));
1821                     }
1822                     HeVAL(entry) = &PL_sv_placeholder;
1823                     HvPLACEHOLDERS(hv)++;
1824                 }
1825             }
1826         }
1827     }
1828     else {
1829         hv_free_entries(hv);
1830         HvPLACEHOLDERS_set(hv, 0);
1831
1832         if (SvRMAGICAL(hv))
1833             mg_clear(MUTABLE_SV(hv));
1834
1835         HvHASKFLAGS_off(hv);
1836     }
1837     if (SvOOK(hv)) {
1838         if(HvENAME_get(hv))
1839             mro_isa_changed_in(hv);
1840         HvEITER_set(hv, NULL);
1841     }
1842     /* disarm hv's premature free guard */
1843     if (LIKELY(PL_tmps_ix == orig_ix))
1844         PL_tmps_ix--;
1845     else
1846         PL_tmps_stack[orig_ix] = &PL_sv_undef;
1847     SvREFCNT_dec_NN(hv);
1848 }
1849
1850 /*
1851 =for apidoc hv_clear_placeholders
1852
1853 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1854 marked as readonly and the key is subsequently deleted, the key is not actually
1855 deleted but is marked by assigning it a value of C<&PL_sv_placeholder>.  This tags
1856 it so it will be ignored by future operations such as iterating over the hash,
1857 but will still allow the hash to have a value reassigned to the key at some
1858 future point.  This function clears any such placeholder keys from the hash.
1859 See C<L<Hash::Util::lock_keys()|Hash::Util/lock_keys>> for an example of its
1860 use.
1861
1862 =cut
1863 */
1864
1865 void
1866 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1867 {
1868     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1869
1870     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1871
1872     if (items)
1873         clear_placeholders(hv, items);
1874 }
1875
1876 static void
1877 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1878 {
1879     I32 i;
1880
1881     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1882
1883     if (items == 0)
1884         return;
1885
1886     i = HvMAX(hv);
1887     do {
1888         /* Loop down the linked list heads  */
1889         HE **oentry = &(HvARRAY(hv))[i];
1890         HE *entry;
1891
1892         while ((entry = *oentry)) {
1893             if (HeVAL(entry) == &PL_sv_placeholder) {
1894                 *oentry = HeNEXT(entry);
1895                 if (entry == HvEITER_get(hv))
1896                     HvLAZYDEL_on(hv);
1897                 else {
1898                     if (SvOOK(hv) && HvLAZYDEL(hv) &&
1899                         entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1900                         HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1901                     hv_free_ent(hv, entry);
1902                 }
1903
1904                 if (--items == 0) {
1905                     /* Finished.  */
1906                     I32 placeholders = HvPLACEHOLDERS_get(hv);
1907                     HvTOTALKEYS(hv) -= (IV)placeholders;
1908                     /* HvUSEDKEYS expanded */
1909                     if ((HvTOTALKEYS(hv) - placeholders) == 0)
1910                         HvHASKFLAGS_off(hv);
1911                     HvPLACEHOLDERS_set(hv, 0);
1912                     return;
1913                 }
1914             } else {
1915                 oentry = &HeNEXT(entry);
1916             }
1917         }
1918     } while (--i >= 0);
1919     /* You can't get here, hence assertion should always fail.  */
1920     assert (items == 0);
1921     NOT_REACHED; /* NOTREACHED */
1922 }
1923
1924 STATIC void
1925 S_hv_free_entries(pTHX_ HV *hv)
1926 {
1927     STRLEN index = 0;
1928     XPVHV * const xhv = (XPVHV*)SvANY(hv);
1929     SV *sv;
1930
1931     PERL_ARGS_ASSERT_HV_FREE_ENTRIES;
1932
1933     while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
1934         SvREFCNT_dec(sv);
1935     }
1936 }
1937
1938
1939 /* hfree_next_entry()
1940  * For use only by S_hv_free_entries() and sv_clear().
1941  * Delete the next available HE from hv and return the associated SV.
1942  * Returns null on empty hash. Nevertheless null is not a reliable
1943  * indicator that the hash is empty, as the deleted entry may have a
1944  * null value.
1945  * indexp is a pointer to the current index into HvARRAY. The index should
1946  * initially be set to 0. hfree_next_entry() may update it.  */
1947
1948 SV*
1949 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1950 {
1951     struct xpvhv_aux *iter;
1952     HE *entry;
1953     HE ** array;
1954 #ifdef DEBUGGING
1955     STRLEN orig_index = *indexp;
1956 #endif
1957
1958     PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1959
1960     if (SvOOK(hv) && ((iter = HvAUX(hv)))) {
1961         if ((entry = iter->xhv_eiter)) {
1962             /* the iterator may get resurrected after each
1963              * destructor call, so check each time */
1964             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1965                 HvLAZYDEL_off(hv);
1966                 hv_free_ent(hv, entry);
1967                 /* warning: at this point HvARRAY may have been
1968                  * re-allocated, HvMAX changed etc */
1969             }
1970             iter = HvAUX(hv); /* may have been realloced */
1971             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1972             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1973 #ifdef PERL_HASH_RANDOMIZE_KEYS
1974             iter->xhv_last_rand = iter->xhv_rand;
1975 #endif
1976         }
1977     }
1978
1979     if (!((XPVHV*)SvANY(hv))->xhv_keys)
1980         return NULL;
1981
1982     array = HvARRAY(hv);
1983     assert(array);
1984     while ( ! ((entry = array[*indexp])) ) {
1985         if ((*indexp)++ >= HvMAX(hv))
1986             *indexp = 0;
1987         assert(*indexp != orig_index);
1988     }
1989     array[*indexp] = HeNEXT(entry);
1990     ((XPVHV*) SvANY(hv))->xhv_keys--;
1991
1992     if (   PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
1993         && HeVAL(entry) && isGV(HeVAL(entry))
1994         && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
1995     ) {
1996         STRLEN klen;
1997         const char * const key = HePV(entry,klen);
1998         if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
1999          || (klen == 1 && key[0] == ':')) {
2000             mro_package_moved(
2001              NULL, GvHV(HeVAL(entry)),
2002              (GV *)HeVAL(entry), 0
2003             );
2004         }
2005     }
2006     return hv_free_ent_ret(hv, entry);
2007 }
2008
2009
2010 /*
2011 =for apidoc hv_undef
2012
2013 Undefines the hash.  The XS equivalent of C<undef(%hash)>.
2014
2015 As well as freeing all the elements of the hash (like C<hv_clear()>), this
2016 also frees any auxiliary data and storage associated with the hash.
2017
2018 See L</av_clear> for a note about the hash possibly being invalid on
2019 return.
2020
2021 =cut
2022 */
2023
2024 void
2025 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
2026 {
2027     XPVHV* xhv;
2028     bool save;
2029     SSize_t orig_ix = PL_tmps_ix; /* silence compiler warning about unitialized vars */
2030
2031     if (!hv)
2032         return;
2033     save = cBOOL(SvREFCNT(hv));
2034     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2035     xhv = (XPVHV*)SvANY(hv);
2036
2037     /* The name must be deleted before the call to hv_free_entries so that
2038        CVs are anonymised properly. But the effective name must be pre-
2039        served until after that call (and only deleted afterwards if the
2040        call originated from sv_clear). For stashes with one name that is
2041        both the canonical name and the effective name, hv_name_set has to
2042        allocate an array for storing the effective name. We can skip that
2043        during global destruction, as it does not matter where the CVs point
2044        if they will be freed anyway. */
2045     /* note that the code following prior to hv_free_entries is duplicated
2046      * in sv_clear(), and changes here should be done there too */
2047     if (PL_phase != PERL_PHASE_DESTRUCT && HvNAME(hv)) {
2048         if (PL_stashcache) {
2049             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
2050                              HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
2051             (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
2052         }
2053         hv_name_set(hv, NULL, 0, 0);
2054     }
2055     if (save) {
2056         /* avoid hv being freed when calling destructors below */
2057         EXTEND_MORTAL(1);
2058         PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
2059         orig_ix = PL_tmps_ix;
2060     }
2061     hv_free_entries(hv);
2062     if (SvOOK(hv)) {
2063       struct mro_meta *meta;
2064       const char *name;
2065
2066       if (HvENAME_get(hv)) {
2067         if (PL_phase != PERL_PHASE_DESTRUCT)
2068             mro_isa_changed_in(hv);
2069         if (PL_stashcache) {
2070             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
2071                              HEKf "'\n", HEKfARG(HvENAME_HEK(hv))));
2072             (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD);
2073         }
2074       }
2075
2076       /* If this call originated from sv_clear, then we must check for
2077        * effective names that need freeing, as well as the usual name. */
2078       name = HvNAME(hv);
2079       if (flags & HV_NAME_SETALL ? !!HvAUX(hv)->xhv_name_u.xhvnameu_name : !!name) {
2080         if (name && PL_stashcache) {
2081             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
2082                              HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
2083             (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
2084         }
2085         hv_name_set(hv, NULL, 0, flags);
2086       }
2087       if((meta = HvAUX(hv)->xhv_mro_meta)) {
2088         if (meta->mro_linear_all) {
2089             SvREFCNT_dec_NN(meta->mro_linear_all);
2090             /* mro_linear_current is just acting as a shortcut pointer,
2091                hence the else.  */
2092         }
2093         else
2094             /* Only the current MRO is stored, so this owns the data.
2095              */
2096             SvREFCNT_dec(meta->mro_linear_current);
2097         SvREFCNT_dec(meta->mro_nextmethod);
2098         SvREFCNT_dec(meta->isa);
2099         SvREFCNT_dec(meta->super);
2100         Safefree(meta);
2101         HvAUX(hv)->xhv_mro_meta = NULL;
2102       }
2103       if (!HvAUX(hv)->xhv_name_u.xhvnameu_name && ! HvAUX(hv)->xhv_backreferences)
2104         SvFLAGS(hv) &= ~SVf_OOK;
2105     }
2106     if (!SvOOK(hv)) {
2107         Safefree(HvARRAY(hv));
2108         xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX;        /* HvMAX(hv) = 7 (it's a normal hash) */
2109         HvARRAY(hv) = 0;
2110     }
2111     /* if we're freeing the HV, the SvMAGIC field has been reused for
2112      * other purposes, and so there can't be any placeholder magic */
2113     if (SvREFCNT(hv))
2114         HvPLACEHOLDERS_set(hv, 0);
2115
2116     if (SvRMAGICAL(hv))
2117         mg_clear(MUTABLE_SV(hv));
2118
2119     if (save) {
2120         /* disarm hv's premature free guard */
2121         if (LIKELY(PL_tmps_ix == orig_ix))
2122             PL_tmps_ix--;
2123         else
2124             PL_tmps_stack[orig_ix] = &PL_sv_undef;
2125         SvREFCNT_dec_NN(hv);
2126     }
2127 }
2128
2129 /*
2130 =for apidoc hv_fill
2131
2132 Returns the number of hash buckets that happen to be in use.
2133
2134 This function is wrapped by the macro C<HvFILL>.
2135
2136 As of perl 5.25 this function is used only for debugging
2137 purposes, and the number of used hash buckets is not
2138 in any way cached, thus this function can be costly
2139 to execute as it must iterate over all the buckets in the
2140 hash.
2141
2142 =cut
2143 */
2144
2145 STRLEN
2146 Perl_hv_fill(pTHX_ HV *const hv)
2147 {
2148     STRLEN count = 0;
2149     HE **ents = HvARRAY(hv);
2150
2151     PERL_UNUSED_CONTEXT;
2152     PERL_ARGS_ASSERT_HV_FILL;
2153
2154     /* No keys implies no buckets used.
2155        One key can only possibly mean one bucket used.  */
2156     if (HvTOTALKEYS(hv) < 2)
2157         return HvTOTALKEYS(hv);
2158
2159     if (ents) {
2160         /* I wonder why we count down here...
2161          * Is it some micro-optimisation?
2162          * I would have thought counting up was better.
2163          * - Yves
2164          */
2165         HE *const *const last = ents + HvMAX(hv);
2166         count = last + 1 - ents;
2167
2168         do {
2169             if (!*ents)
2170                 --count;
2171         } while (++ents <= last);
2172     }
2173     return count;
2174 }
2175
2176 /* hash a pointer to a U32 - Used in the hash traversal randomization
2177  * and bucket order randomization code
2178  *
2179  * this code was derived from Sereal, which was derived from autobox.
2180  */
2181
2182 PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
2183 #if PTRSIZE == 8
2184     /*
2185      * This is one of Thomas Wang's hash functions for 64-bit integers from:
2186      * http://www.concentric.net/~Ttwang/tech/inthash.htm
2187      */
2188     u = (~u) + (u << 18);
2189     u = u ^ (u >> 31);
2190     u = u * 21;
2191     u = u ^ (u >> 11);
2192     u = u + (u << 6);
2193     u = u ^ (u >> 22);
2194 #else
2195     /*
2196      * This is one of Bob Jenkins' hash functions for 32-bit integers
2197      * from: http://burtleburtle.net/bob/hash/integer.html
2198      */
2199     u = (u + 0x7ed55d16) + (u << 12);
2200     u = (u ^ 0xc761c23c) ^ (u >> 19);
2201     u = (u + 0x165667b1) + (u << 5);
2202     u = (u + 0xd3a2646c) ^ (u << 9);
2203     u = (u + 0xfd7046c5) + (u << 3);
2204     u = (u ^ 0xb55a4f09) ^ (u >> 16);
2205 #endif
2206     return (U32)u;
2207 }
2208
2209 static struct xpvhv_aux*
2210 S_hv_auxinit_internal(struct xpvhv_aux *iter) {
2211     PERL_ARGS_ASSERT_HV_AUXINIT_INTERNAL;
2212     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
2213     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
2214 #ifdef PERL_HASH_RANDOMIZE_KEYS
2215     iter->xhv_last_rand = iter->xhv_rand;
2216 #endif
2217     iter->xhv_name_u.xhvnameu_name = 0;
2218     iter->xhv_name_count = 0;
2219     iter->xhv_backreferences = 0;
2220     iter->xhv_mro_meta = NULL;
2221     iter->xhv_aux_flags = 0;
2222     return iter;
2223 }
2224
2225
2226 static struct xpvhv_aux*
2227 S_hv_auxinit(pTHX_ HV *hv) {
2228     struct xpvhv_aux *iter;
2229     char *array;
2230
2231     PERL_ARGS_ASSERT_HV_AUXINIT;
2232
2233     if (!SvOOK(hv)) {
2234         if (!HvARRAY(hv)) {
2235             Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
2236                 + sizeof(struct xpvhv_aux), char);
2237         } else {
2238             array = (char *) HvARRAY(hv);
2239             Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
2240                   + sizeof(struct xpvhv_aux), char);
2241         }
2242         HvARRAY(hv) = (HE**)array;
2243         SvOOK_on(hv);
2244         iter = HvAUX(hv);
2245 #ifdef PERL_HASH_RANDOMIZE_KEYS
2246         if (PL_HASH_RAND_BITS_ENABLED) {
2247             /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
2248             if (PL_HASH_RAND_BITS_ENABLED == 1)
2249                 PL_hash_rand_bits += ptr_hash((PTRV)array);
2250             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
2251         }
2252         iter->xhv_rand = (U32)PL_hash_rand_bits;
2253 #endif
2254     } else {
2255         iter = HvAUX(hv);
2256     }
2257
2258     return hv_auxinit_internal(iter);
2259 }
2260
2261 /*
2262 =for apidoc hv_iterinit
2263
2264 Prepares a starting point to traverse a hash table.  Returns the number of
2265 keys in the hash, including placeholders (i.e. the same as C<HvTOTALKEYS(hv)>).
2266 The return value is currently only meaningful for hashes without tie magic.
2267
2268 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
2269 hash buckets that happen to be in use.  If you still need that esoteric
2270 value, you can get it through the macro C<HvFILL(hv)>.
2271
2272
2273 =cut
2274 */
2275
2276 I32
2277 Perl_hv_iterinit(pTHX_ HV *hv)
2278 {
2279     PERL_ARGS_ASSERT_HV_ITERINIT;
2280
2281     if (SvOOK(hv)) {
2282         struct xpvhv_aux * iter = HvAUX(hv);
2283         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2284         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
2285             HvLAZYDEL_off(hv);
2286             hv_free_ent(hv, entry);
2287         }
2288         iter = HvAUX(hv); /* may have been reallocated */
2289         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
2290         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2291 #ifdef PERL_HASH_RANDOMIZE_KEYS
2292         iter->xhv_last_rand = iter->xhv_rand;
2293 #endif
2294     } else {
2295         hv_auxinit(hv);
2296     }
2297
2298     /* note this includes placeholders! */
2299     return HvTOTALKEYS(hv);
2300 }
2301
2302 I32 *
2303 Perl_hv_riter_p(pTHX_ HV *hv) {
2304     struct xpvhv_aux *iter;
2305
2306     PERL_ARGS_ASSERT_HV_RITER_P;
2307
2308     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2309     return &(iter->xhv_riter);
2310 }
2311
2312 HE **
2313 Perl_hv_eiter_p(pTHX_ HV *hv) {
2314     struct xpvhv_aux *iter;
2315
2316     PERL_ARGS_ASSERT_HV_EITER_P;
2317
2318     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2319     return &(iter->xhv_eiter);
2320 }
2321
2322 void
2323 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2324     struct xpvhv_aux *iter;
2325
2326     PERL_ARGS_ASSERT_HV_RITER_SET;
2327
2328     if (SvOOK(hv)) {
2329         iter = HvAUX(hv);
2330     } else {
2331         if (riter == -1)
2332             return;
2333
2334         iter = hv_auxinit(hv);
2335     }
2336     iter->xhv_riter = riter;
2337 }
2338
2339 void
2340 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2341     struct xpvhv_aux *iter;
2342
2343     PERL_ARGS_ASSERT_HV_RAND_SET;
2344
2345 #ifdef PERL_HASH_RANDOMIZE_KEYS
2346     if (SvOOK(hv)) {
2347         iter = HvAUX(hv);
2348     } else {
2349         iter = hv_auxinit(hv);
2350     }
2351     iter->xhv_rand = new_xhv_rand;
2352 #else
2353     Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2354 #endif
2355 }
2356
2357 void
2358 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2359     struct xpvhv_aux *iter;
2360
2361     PERL_ARGS_ASSERT_HV_EITER_SET;
2362
2363     if (SvOOK(hv)) {
2364         iter = HvAUX(hv);
2365     } else {
2366         /* 0 is the default so don't go malloc()ing a new structure just to
2367            hold 0.  */
2368         if (!eiter)
2369             return;
2370
2371         iter = hv_auxinit(hv);
2372     }
2373     iter->xhv_eiter = eiter;
2374 }
2375
2376 void
2377 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2378 {
2379     struct xpvhv_aux *iter;
2380     U32 hash;
2381     HEK **spot;
2382
2383     PERL_ARGS_ASSERT_HV_NAME_SET;
2384
2385     if (len > I32_MAX)
2386         Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2387
2388     if (SvOOK(hv)) {
2389         iter = HvAUX(hv);
2390         if (iter->xhv_name_u.xhvnameu_name) {
2391             if(iter->xhv_name_count) {
2392               if(flags & HV_NAME_SETALL) {
2393                 HEK ** const this_name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2394                 HEK **hekp = this_name + (
2395                     iter->xhv_name_count < 0
2396                      ? -iter->xhv_name_count
2397                      :  iter->xhv_name_count
2398                    );
2399                 while(hekp-- > this_name+1)
2400                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2401                 /* The first elem may be null. */
2402                 if(*this_name) unshare_hek_or_pvn(*this_name, 0, 0, 0);
2403                 Safefree(this_name);
2404                 iter = HvAUX(hv); /* may been realloced */
2405                 spot = &iter->xhv_name_u.xhvnameu_name;
2406                 iter->xhv_name_count = 0;
2407               }
2408               else {
2409                 if(iter->xhv_name_count > 0) {
2410                     /* shift some things over */
2411                     Renew(
2412                      iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2413                     );
2414                     spot = iter->xhv_name_u.xhvnameu_names;
2415                     spot[iter->xhv_name_count] = spot[1];
2416                     spot[1] = spot[0];
2417                     iter->xhv_name_count = -(iter->xhv_name_count + 1);
2418                 }
2419                 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2420                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2421                 }
2422               }
2423             }
2424             else if (flags & HV_NAME_SETALL) {
2425                 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2426                 iter = HvAUX(hv); /* may been realloced */
2427                 spot = &iter->xhv_name_u.xhvnameu_name;
2428             }
2429             else {
2430                 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2431                 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2432                 iter->xhv_name_count = -2;
2433                 spot = iter->xhv_name_u.xhvnameu_names;
2434                 spot[1] = existing_name;
2435             }
2436         }
2437         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2438     } else {
2439         if (name == 0)
2440             return;
2441
2442         iter = hv_auxinit(hv);
2443         spot = &iter->xhv_name_u.xhvnameu_name;
2444     }
2445     PERL_HASH(hash, name, len);
2446     *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2447 }
2448
2449 /*
2450 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2451 and bytes checking.
2452 */
2453
2454 STATIC I32
2455 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2456     if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2457         if (flags & SVf_UTF8)
2458             return (bytes_cmp_utf8(
2459                         (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2460                         (const U8*)pv, pvlen) == 0);
2461         else
2462             return (bytes_cmp_utf8(
2463                         (const U8*)pv, pvlen,
2464                         (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2465     }
2466     else
2467         return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2468                     || memEQ(HEK_KEY(hek), pv, pvlen));
2469 }
2470
2471 /*
2472 =for apidoc hv_ename_add
2473
2474 Adds a name to a stash's internal list of effective names.  See
2475 C<L</hv_ename_delete>>.
2476
2477 This is called when a stash is assigned to a new location in the symbol
2478 table.
2479
2480 =cut
2481 */
2482
2483 void
2484 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2485 {
2486     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2487     U32 hash;
2488
2489     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2490
2491     if (len > I32_MAX)
2492         Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2493
2494     PERL_HASH(hash, name, len);
2495
2496     if (aux->xhv_name_count) {
2497         I32 count = aux->xhv_name_count;
2498         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0);
2499         HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count);
2500         while (hekp-- > xhv_name)
2501         {
2502             assert(*hekp);
2503             if (
2504                  (HEK_UTF8(*hekp) || (flags & SVf_UTF8)) 
2505                     ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2506                     : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2507                ) {
2508                 if (hekp == xhv_name && count < 0)
2509                     aux->xhv_name_count = -count;
2510                 return;
2511             }
2512         }
2513         if (count < 0) aux->xhv_name_count--, count = -count;
2514         else aux->xhv_name_count++;
2515         Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2516         (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2517     }
2518     else {
2519         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2520         if (
2521             existing_name && (
2522              (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2523                 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2524                 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2525             )
2526         ) return;
2527         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2528         aux->xhv_name_count = existing_name ? 2 : -2;
2529         *aux->xhv_name_u.xhvnameu_names = existing_name;
2530         (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2531     }
2532 }
2533
2534 /*
2535 =for apidoc hv_ename_delete
2536
2537 Removes a name from a stash's internal list of effective names.  If this is
2538 the name returned by C<HvENAME>, then another name in the list will take
2539 its place (C<HvENAME> will use it).
2540
2541 This is called when a stash is deleted from the symbol table.
2542
2543 =cut
2544 */
2545
2546 void
2547 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2548 {
2549     struct xpvhv_aux *aux;
2550
2551     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2552
2553     if (len > I32_MAX)
2554         Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
2555
2556     if (!SvOOK(hv)) return;
2557
2558     aux = HvAUX(hv);
2559     if (!aux->xhv_name_u.xhvnameu_name) return;
2560
2561     if (aux->xhv_name_count) {
2562         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2563         I32 const count = aux->xhv_name_count;
2564         HEK **victim = namep + (count < 0 ? -count : count);
2565         while (victim-- > namep + 1)
2566             if (
2567              (HEK_UTF8(*victim) || (flags & SVf_UTF8)) 
2568                 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2569                 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2570             ) {
2571                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2572                 aux = HvAUX(hv); /* may been realloced */
2573                 if (count < 0) ++aux->xhv_name_count;
2574                 else --aux->xhv_name_count;
2575                 if (
2576                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2577                  && !*namep
2578                 ) {  /* if there are none left */
2579                     Safefree(namep);
2580                     aux->xhv_name_u.xhvnameu_names = NULL;
2581                     aux->xhv_name_count = 0;
2582                 }
2583                 else {
2584                     /* Move the last one back to fill the empty slot. It
2585                        does not matter what order they are in. */
2586                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2587                 }
2588                 return;
2589             }
2590         if (
2591             count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8)) 
2592                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2593                 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2594             )
2595         ) {
2596             aux->xhv_name_count = -count;
2597         }
2598     }
2599     else if(
2600         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) 
2601                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2602                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2603                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2604     ) {
2605         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2606         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2607         *aux->xhv_name_u.xhvnameu_names = namehek;
2608         aux->xhv_name_count = -1;
2609     }
2610 }
2611
2612 AV **
2613 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2614     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2615     /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
2616     {
2617         struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2618         return &(iter->xhv_backreferences);
2619     }
2620 }
2621
2622 void
2623 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2624     AV *av;
2625
2626     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2627
2628     if (!SvOOK(hv))
2629         return;
2630
2631     av = HvAUX(hv)->xhv_backreferences;
2632
2633     if (av) {
2634         HvAUX(hv)->xhv_backreferences = 0;
2635         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2636         if (SvTYPE(av) == SVt_PVAV)
2637             SvREFCNT_dec_NN(av);
2638     }
2639 }
2640
2641 /*
2642 hv_iternext is implemented as a macro in hv.h
2643
2644 =for apidoc hv_iternext
2645
2646 Returns entries from a hash iterator.  See C<L</hv_iterinit>>.
2647
2648 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2649 iterator currently points to, without losing your place or invalidating your
2650 iterator.  Note that in this case the current entry is deleted from the hash
2651 with your iterator holding the last reference to it.  Your iterator is flagged
2652 to free the entry on the next call to C<hv_iternext>, so you must not discard
2653 your iterator immediately else the entry will leak - call C<hv_iternext> to
2654 trigger the resource deallocation.
2655
2656 =for apidoc hv_iternext_flags
2657
2658 Returns entries from a hash iterator.  See C<L</hv_iterinit>> and
2659 C<L</hv_iternext>>.
2660 The C<flags> value will normally be zero; if C<HV_ITERNEXT_WANTPLACEHOLDERS> is
2661 set the placeholders keys (for restricted hashes) will be returned in addition
2662 to normal keys.  By default placeholders are automatically skipped over.
2663 Currently a placeholder is implemented with a value that is
2664 C<&PL_sv_placeholder>.  Note that the implementation of placeholders and
2665 restricted hashes may change, and the implementation currently is
2666 insufficiently abstracted for any change to be tidy.
2667
2668 =for apidoc Amnh||HV_ITERNEXT_WANTPLACEHOLDERS
2669
2670 =cut
2671 */
2672
2673 HE *
2674 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2675 {
2676     XPVHV* xhv;
2677     HE *entry;
2678     HE *oldentry;
2679     MAGIC* mg;
2680     struct xpvhv_aux *iter;
2681
2682     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2683
2684     xhv = (XPVHV*)SvANY(hv);
2685
2686     if (!SvOOK(hv)) {
2687         /* Too many things (well, pp_each at least) merrily assume that you can
2688            call hv_iternext without calling hv_iterinit, so we'll have to deal
2689            with it.  */
2690         hv_iterinit(hv);
2691     }
2692     iter = HvAUX(hv);
2693
2694     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2695     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2696         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2697             SV * const key = sv_newmortal();
2698             if (entry) {
2699                 sv_setsv(key, HeSVKEY_force(entry));
2700                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2701                 HeSVKEY_set(entry, NULL);
2702             }
2703             else {
2704                 char *k;
2705                 HEK *hek;
2706
2707                 /* one HE per MAGICAL hash */
2708                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2709                 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2710                 Zero(entry, 1, HE);
2711                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2712                 hek = (HEK*)k;
2713                 HeKEY_hek(entry) = hek;
2714                 HeKLEN(entry) = HEf_SVKEY;
2715             }
2716             magic_nextpack(MUTABLE_SV(hv),mg,key);
2717             if (SvOK(key)) {
2718                 /* force key to stay around until next time */
2719                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2720                 return entry;               /* beware, hent_val is not set */
2721             }
2722             SvREFCNT_dec(HeVAL(entry));
2723             Safefree(HeKEY_hek(entry));
2724             del_HE(entry);
2725             iter = HvAUX(hv); /* may been realloced */
2726             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2727             HvLAZYDEL_off(hv);
2728             return NULL;
2729         }
2730     }
2731 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2732     if (!entry && SvRMAGICAL((const SV *)hv)
2733         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2734         prime_env_iter();
2735 #ifdef VMS
2736         /* The prime_env_iter() on VMS just loaded up new hash values
2737          * so the iteration count needs to be reset back to the beginning
2738          */
2739         hv_iterinit(hv);
2740         iter = HvAUX(hv);
2741         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2742 #endif
2743     }
2744 #endif
2745
2746     /* hv_iterinit now ensures this.  */
2747     assert (HvARRAY(hv));
2748
2749     /* At start of hash, entry is NULL.  */
2750     if (entry)
2751     {
2752         entry = HeNEXT(entry);
2753         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2754             /*
2755              * Skip past any placeholders -- don't want to include them in
2756              * any iteration.
2757              */
2758             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2759                 entry = HeNEXT(entry);
2760             }
2761         }
2762     }
2763
2764 #ifdef PERL_HASH_RANDOMIZE_KEYS
2765     if (iter->xhv_last_rand != iter->xhv_rand) {
2766         if (iter->xhv_riter != -1) {
2767             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2768                              "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2769                              pTHX__FORMAT
2770                              pTHX__VALUE);
2771         }
2772         iter = HvAUX(hv); /* may been realloced */
2773         iter->xhv_last_rand = iter->xhv_rand;
2774     }
2775 #endif
2776
2777     /* Skip the entire loop if the hash is empty.   */
2778     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2779         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2780         while (!entry) {
2781             /* OK. Come to the end of the current list.  Grab the next one.  */
2782
2783             iter->xhv_riter++; /* HvRITER(hv)++ */
2784             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2785                 /* There is no next one.  End of the hash.  */
2786                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2787 #ifdef PERL_HASH_RANDOMIZE_KEYS
2788                 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2789 #endif
2790                 break;
2791             }
2792             entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2793
2794             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2795                 /* If we have an entry, but it's a placeholder, don't count it.
2796                    Try the next.  */
2797                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2798                     entry = HeNEXT(entry);
2799             }
2800             /* Will loop again if this linked list starts NULL
2801                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2802                or if we run through it and find only placeholders.  */
2803         }
2804     }
2805     else {
2806         iter->xhv_riter = -1;
2807 #ifdef PERL_HASH_RANDOMIZE_KEYS
2808         iter->xhv_last_rand = iter->xhv_rand;
2809 #endif
2810     }
2811
2812     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2813         HvLAZYDEL_off(hv);
2814         hv_free_ent(hv, oldentry);
2815     }
2816
2817     iter = HvAUX(hv); /* may been realloced */
2818     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2819     return entry;
2820 }
2821
2822 /*
2823 =for apidoc hv_iterkey
2824
2825 Returns the key from the current position of the hash iterator.  See
2826 C<L</hv_iterinit>>.
2827
2828 =cut
2829 */
2830
2831 char *
2832 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2833 {
2834     PERL_ARGS_ASSERT_HV_ITERKEY;
2835
2836     if (HeKLEN(entry) == HEf_SVKEY) {
2837         STRLEN len;
2838         char * const p = SvPV(HeKEY_sv(entry), len);
2839         *retlen = len;
2840         return p;
2841     }
2842     else {
2843         *retlen = HeKLEN(entry);
2844         return HeKEY(entry);
2845     }
2846 }
2847
2848 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2849 /*
2850 =for apidoc hv_iterkeysv
2851
2852 Returns the key as an C<SV*> from the current position of the hash
2853 iterator.  The return value will always be a mortal copy of the key.  Also
2854 see C<L</hv_iterinit>>.
2855
2856 =cut
2857 */
2858
2859 SV *
2860 Perl_hv_iterkeysv(pTHX_ HE *entry)
2861 {
2862     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2863
2864     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2865 }
2866
2867 /*
2868 =for apidoc hv_iterval
2869
2870 Returns the value from the current position of the hash iterator.  See
2871 C<L</hv_iterkey>>.
2872
2873 =cut
2874 */
2875
2876 SV *
2877 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2878 {
2879     PERL_ARGS_ASSERT_HV_ITERVAL;
2880
2881     if (SvRMAGICAL(hv)) {
2882         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2883             SV* const sv = sv_newmortal();
2884             if (HeKLEN(entry) == HEf_SVKEY)
2885                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2886             else
2887                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2888             return sv;
2889         }
2890     }
2891     return HeVAL(entry);
2892 }
2893
2894 /*
2895 =for apidoc hv_iternextsv
2896
2897 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2898 operation.
2899
2900 =cut
2901 */
2902
2903 SV *
2904 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2905 {
2906     HE * const he = hv_iternext_flags(hv, 0);
2907
2908     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2909
2910     if (!he)
2911         return NULL;
2912     *key = hv_iterkey(he, retlen);
2913     return hv_iterval(hv, he);
2914 }
2915
2916 /*
2917
2918 Now a macro in hv.h
2919
2920 =for apidoc hv_magic
2921
2922 Adds magic to a hash.  See C<L</sv_magic>>.
2923
2924 =cut
2925 */
2926
2927 /* possibly free a shared string if no one has access to it
2928  * len and hash must both be valid for str.
2929  */
2930 void
2931 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2932 {
2933     unshare_hek_or_pvn (NULL, str, len, hash);
2934 }
2935
2936
2937 void
2938 Perl_unshare_hek(pTHX_ HEK *hek)
2939 {
2940     assert(hek);
2941     unshare_hek_or_pvn(hek, NULL, 0, 0);
2942 }
2943
2944 /* possibly free a shared string if no one has access to it
2945    hek if non-NULL takes priority over the other 3, else str, len and hash
2946    are used.  If so, len and hash must both be valid for str.
2947  */
2948 STATIC void
2949 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2950 {
2951     XPVHV* xhv;
2952     HE *entry;
2953     HE **oentry;
2954     bool is_utf8 = FALSE;
2955     int k_flags = 0;
2956     const char * const save = str;
2957     struct shared_he *he = NULL;
2958
2959     if (hek) {
2960         /* Find the shared he which is just before us in memory.  */
2961         he = (struct shared_he *)(((char *)hek)
2962                                   - STRUCT_OFFSET(struct shared_he,
2963                                                   shared_he_hek));
2964
2965         /* Assert that the caller passed us a genuine (or at least consistent)
2966            shared hek  */
2967         assert (he->shared_he_he.hent_hek == hek);
2968
2969         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2970             --he->shared_he_he.he_valu.hent_refcount;
2971             return;
2972         }
2973
2974         hash = HEK_HASH(hek);
2975     } else if (len < 0) {
2976         STRLEN tmplen = -len;
2977         is_utf8 = TRUE;
2978         /* See the note in hv_fetch(). --jhi */
2979         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2980         len = tmplen;
2981         if (is_utf8)
2982             k_flags = HVhek_UTF8;
2983         if (str != save)
2984             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2985     }
2986
2987     /* what follows was the moral equivalent of:
2988     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2989         if (--*Svp == NULL)
2990             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2991     } */
2992     xhv = (XPVHV*)SvANY(PL_strtab);
2993     /* assert(xhv_array != 0) */
2994     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2995     if (he) {
2996         const HE *const he_he = &(he->shared_he_he);
2997         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2998             if (entry == he_he)
2999                 break;
3000         }
3001     } else {
3002         const int flags_masked = k_flags & HVhek_MASK;
3003         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
3004             if (HeHASH(entry) != hash)          /* strings can't be equal */
3005                 continue;
3006             if (HeKLEN(entry) != len)
3007                 continue;
3008             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
3009                 continue;
3010             if (HeKFLAGS(entry) != flags_masked)
3011                 continue;
3012             break;
3013         }
3014     }
3015
3016     if (entry) {
3017         if (--entry->he_valu.hent_refcount == 0) {
3018             *oentry = HeNEXT(entry);
3019             Safefree(entry);
3020             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
3021         }
3022     }
3023
3024     if (!entry)
3025         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
3026                          "Attempt to free nonexistent shared string '%s'%s"
3027                          pTHX__FORMAT,
3028                          hek ? HEK_KEY(hek) : str,
3029                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
3030     if (k_flags & HVhek_FREEKEY)
3031         Safefree(str);
3032 }
3033
3034 /* get a (constant) string ptr from the global string table
3035  * string will get added if it is not already there.
3036  * len and hash must both be valid for str.
3037  */
3038 HEK *
3039 Perl_share_hek(pTHX_ const char *str, SSize_t len, U32 hash)
3040 {
3041     bool is_utf8 = FALSE;
3042     int flags = 0;
3043     const char * const save = str;
3044
3045     PERL_ARGS_ASSERT_SHARE_HEK;
3046
3047     if (len < 0) {
3048       STRLEN tmplen = -len;
3049       is_utf8 = TRUE;
3050       /* See the note in hv_fetch(). --jhi */
3051       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
3052       len = tmplen;
3053       /* If we were able to downgrade here, then than means that we were passed
3054          in a key which only had chars 0-255, but was utf8 encoded.  */
3055       if (is_utf8)
3056           flags = HVhek_UTF8;
3057       /* If we found we were able to downgrade the string to bytes, then
3058          we should flag that it needs upgrading on keys or each.  Also flag
3059          that we need share_hek_flags to free the string.  */
3060       if (str != save) {
3061           PERL_HASH(hash, str, len);
3062           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
3063       }
3064     }
3065
3066     return share_hek_flags (str, len, hash, flags);
3067 }
3068
3069 STATIC HEK *
3070 S_share_hek_flags(pTHX_ const char *str, STRLEN len, U32 hash, int flags)
3071 {
3072     HE *entry;
3073     const int flags_masked = flags & HVhek_MASK;
3074     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
3075     XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
3076
3077     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
3078
3079     if (UNLIKELY(len > (STRLEN) I32_MAX)) {
3080         Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes");
3081     }
3082
3083     /* what follows is the moral equivalent of:
3084
3085     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
3086         hv_store(PL_strtab, str, len, NULL, hash);
3087
3088         Can't rehash the shared string table, so not sure if it's worth
3089         counting the number of entries in the linked list
3090     */
3091
3092     /* assert(xhv_array != 0) */
3093     entry = (HvARRAY(PL_strtab))[hindex];
3094     for (;entry; entry = HeNEXT(entry)) {
3095         if (HeHASH(entry) != hash)              /* strings can't be equal */
3096             continue;
3097         if (HeKLEN(entry) != (SSize_t) len)
3098             continue;
3099         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
3100             continue;
3101         if (HeKFLAGS(entry) != flags_masked)
3102             continue;
3103         break;
3104     }
3105
3106     if (!entry) {
3107         /* What used to be head of the list.
3108            If this is NULL, then we're the first entry for this slot, which
3109            means we need to increate fill.  */
3110         struct shared_he *new_entry;
3111         HEK *hek;
3112         char *k;
3113         HE **const head = &HvARRAY(PL_strtab)[hindex];
3114         HE *const next = *head;
3115
3116         /* We don't actually store a HE from the arena and a regular HEK.
3117            Instead we allocate one chunk of memory big enough for both,
3118            and put the HEK straight after the HE. This way we can find the
3119            HE directly from the HEK.
3120         */
3121
3122         Newx(k, STRUCT_OFFSET(struct shared_he,
3123                                 shared_he_hek.hek_key[0]) + len + 2, char);
3124         new_entry = (struct shared_he *)k;
3125         entry = &(new_entry->shared_he_he);
3126         hek = &(new_entry->shared_he_hek);
3127
3128         Copy(str, HEK_KEY(hek), len, char);
3129         HEK_KEY(hek)[len] = 0;
3130         HEK_LEN(hek) = len;
3131         HEK_HASH(hek) = hash;
3132         HEK_FLAGS(hek) = (unsigned char)flags_masked;
3133
3134         /* Still "point" to the HEK, so that other code need not know what
3135            we're up to.  */
3136         HeKEY_hek(entry) = hek;
3137         entry->he_valu.hent_refcount = 0;
3138         HeNEXT(entry) = next;
3139         *head = entry;
3140
3141         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
3142         if (!next) {                    /* initial entry? */
3143         } else if ( DO_HSPLIT(xhv) ) {
3144             const STRLEN oldsize = xhv->xhv_max + 1;
3145             hsplit(PL_strtab, oldsize, oldsize * 2);
3146         }
3147     }
3148
3149     ++entry->he_valu.hent_refcount;
3150
3151     if (flags & HVhek_FREEKEY)
3152         Safefree(str);
3153
3154     return HeKEY_hek(entry);
3155 }
3156
3157 SSize_t *
3158 Perl_hv_placeholders_p(pTHX_ HV *hv)
3159 {
3160     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3161
3162     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
3163
3164     if (!mg) {
3165         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
3166
3167         if (!mg) {
3168             Perl_die(aTHX_ "panic: hv_placeholders_p");
3169         }
3170     }
3171     return &(mg->mg_len);
3172 }
3173
3174
3175 I32
3176 Perl_hv_placeholders_get(pTHX_ const HV *hv)
3177 {
3178     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3179
3180     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3181     PERL_UNUSED_CONTEXT;
3182
3183     return mg ? mg->mg_len : 0;
3184 }
3185
3186 void
3187 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3188 {
3189     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3190
3191     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3192
3193     if (mg) {
3194         mg->mg_len = ph;
3195     } else if (ph) {
3196         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3197             Perl_die(aTHX_ "panic: hv_placeholders_set");
3198     }
3199     /* else we don't need to add magic to record 0 placeholders.  */
3200 }
3201
3202 STATIC SV *
3203 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3204 {
3205     SV *value;
3206
3207     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3208
3209     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3210     case HVrhek_undef:
3211         value = newSV(0);
3212         break;
3213     case HVrhek_delete:
3214         value = &PL_sv_placeholder;
3215         break;
3216     case HVrhek_IV:
3217         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3218         break;
3219     case HVrhek_UV:
3220         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3221         break;
3222     case HVrhek_PV:
3223     case HVrhek_PV_UTF8:
3224         /* Create a string SV that directly points to the bytes in our
3225            structure.  */
3226         value = newSV_type(SVt_PV);
3227         SvPV_set(value, (char *) he->refcounted_he_data + 1);
3228         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3229         /* This stops anything trying to free it  */
3230         SvLEN_set(value, 0);
3231         SvPOK_on(value);
3232         SvREADONLY_on(value);
3233         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3234             SvUTF8_on(value);
3235         break;
3236     default:
3237         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf,
3238                    (UV)he->refcounted_he_data[0]);
3239     }
3240     return value;
3241 }
3242
3243 /*
3244 =for apidoc refcounted_he_chain_2hv
3245
3246 Generates and returns a C<HV *> representing the content of a
3247 C<refcounted_he> chain.
3248 C<flags> is currently unused and must be zero.
3249
3250 =cut
3251 */
3252 HV *
3253 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3254 {
3255     HV *hv;
3256     U32 placeholders, max;
3257
3258     if (flags)
3259         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf,
3260             (UV)flags);
3261
3262     /* We could chase the chain once to get an idea of the number of keys,
3263        and call ksplit.  But for now we'll make a potentially inefficient
3264        hash with only 8 entries in its array.  */
3265     hv = newHV();
3266     max = HvMAX(hv);
3267     if (!HvARRAY(hv)) {
3268         char *array;
3269         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3270         HvARRAY(hv) = (HE**)array;
3271     }
3272
3273     placeholders = 0;
3274     while (chain) {
3275 #ifdef USE_ITHREADS
3276         U32 hash = chain->refcounted_he_hash;
3277 #else
3278         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3279 #endif
3280         HE **oentry = &((HvARRAY(hv))[hash & max]);
3281         HE *entry = *oentry;
3282         SV *value;
3283
3284         for (; entry; entry = HeNEXT(entry)) {
3285             if (HeHASH(entry) == hash) {
3286                 /* We might have a duplicate key here.  If so, entry is older
3287                    than the key we've already put in the hash, so if they are
3288                    the same, skip adding entry.  */
3289 #ifdef USE_ITHREADS
3290                 const STRLEN klen = HeKLEN(entry);
3291                 const char *const key = HeKEY(entry);
3292                 if (klen == chain->refcounted_he_keylen
3293                     && (!!HeKUTF8(entry)
3294                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3295                     && memEQ(key, REF_HE_KEY(chain), klen))
3296                     goto next_please;
3297 #else
3298                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3299                     goto next_please;
3300                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3301                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3302                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3303                              HeKLEN(entry)))
3304                     goto next_please;
3305 #endif
3306             }
3307         }
3308         assert (!entry);
3309         entry = new_HE();
3310
3311 #ifdef USE_ITHREADS
3312         HeKEY_hek(entry)
3313             = share_hek_flags(REF_HE_KEY(chain),
3314                               chain->refcounted_he_keylen,
3315                               chain->refcounted_he_hash,
3316                               (chain->refcounted_he_data[0]
3317                                & (HVhek_UTF8|HVhek_WASUTF8)));
3318 #else
3319         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3320 #endif
3321         value = refcounted_he_value(chain);
3322         if (value == &PL_sv_placeholder)
3323             placeholders++;
3324         HeVAL(entry) = value;
3325
3326         /* Link it into the chain.  */
3327         HeNEXT(entry) = *oentry;
3328         *oentry = entry;
3329
3330         HvTOTALKEYS(hv)++;
3331
3332     next_please:
3333         chain = chain->refcounted_he_next;
3334     }
3335
3336     if (placeholders) {
3337         clear_placeholders(hv, placeholders);
3338         HvTOTALKEYS(hv) -= placeholders;
3339     }
3340
3341     /* We could check in the loop to see if we encounter any keys with key
3342        flags, but it's probably not worth it, as this per-hash flag is only
3343        really meant as an optimisation for things like Storable.  */
3344     HvHASKFLAGS_on(hv);
3345     DEBUG_A(Perl_hv_assert(aTHX_ hv));
3346
3347     return hv;
3348 }
3349
3350 /*
3351 =for apidoc refcounted_he_fetch_pvn
3352
3353 Search along a C<refcounted_he> chain for an entry with the key specified
3354 by C<keypv> and C<keylen>.  If C<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3355 bit set, the key octets are interpreted as UTF-8, otherwise they
3356 are interpreted as Latin-1.  C<hash> is a precomputed hash of the key
3357 string, or zero if it has not been precomputed.  Returns a mortal scalar
3358 representing the value associated with the key, or C<&PL_sv_placeholder>
3359 if there is no value associated with the key.
3360
3361 =cut
3362 */
3363
3364 SV *
3365 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3366                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3367 {
3368     U8 utf8_flag;
3369     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3370
3371     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3372         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf,
3373             (UV)flags);
3374     if (!chain)
3375         goto ret;
3376     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3377         /* For searching purposes, canonicalise to Latin-1 where possible. */
3378         const char *keyend = keypv + keylen, *p;
3379         STRLEN nonascii_count = 0;
3380         for (p = keypv; p != keyend; p++) {
3381             if (! UTF8_IS_INVARIANT(*p)) {
3382                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3383                     goto canonicalised_key;
3384                 }
3385                 nonascii_count++;
3386                 p++;
3387             }
3388         }
3389         if (nonascii_count) {
3390             char *q;
3391             const char *p = keypv, *keyend = keypv + keylen;
3392             keylen -= nonascii_count;
3393             Newx(q, keylen, char);
3394             SAVEFREEPV(q);
3395             keypv = q;
3396             for (; p != keyend; p++, q++) {
3397                 U8 c = (U8)*p;
3398                 if (UTF8_IS_INVARIANT(c)) {
3399                     *q = (char) c;
3400                 }
3401                 else {
3402                     p++;
3403                     *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3404                 }
3405             }
3406         }
3407         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3408         canonicalised_key: ;
3409     }
3410     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3411     if (!hash)
3412         PERL_HASH(hash, keypv, keylen);
3413
3414     for (; chain; chain = chain->refcounted_he_next) {
3415         if (
3416 #ifdef USE_ITHREADS
3417             hash == chain->refcounted_he_hash &&
3418             keylen == chain->refcounted_he_keylen &&
3419             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3420             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3421 #else
3422             hash == HEK_HASH(chain->refcounted_he_hek) &&
3423             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3424             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3425             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3426 #endif
3427         ) {
3428             if (flags & REFCOUNTED_HE_EXISTS)
3429                 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3430                     == HVrhek_delete
3431                     ? NULL : &PL_sv_yes;
3432             return sv_2mortal(refcounted_he_value(chain));
3433         }
3434     }
3435   ret:
3436     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3437 }
3438
3439 /*
3440 =for apidoc refcounted_he_fetch_pv
3441
3442 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3443 instead of a string/length pair.
3444
3445 =cut
3446 */
3447
3448 SV *
3449 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3450                          const char *key, U32 hash, U32 flags)
3451 {
3452     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3453     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3454 }
3455
3456 /*
3457 =for apidoc refcounted_he_fetch_sv
3458
3459 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3460 string/length pair.
3461
3462 =cut
3463 */
3464
3465 SV *
3466 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3467                          SV *key, U32 hash, U32 flags)
3468 {
3469     const char *keypv;
3470     STRLEN keylen;
3471     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3472     if (flags & REFCOUNTED_HE_KEY_UTF8)
3473         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf,
3474             (UV)flags);
3475     keypv = SvPV_const(key, keylen);
3476     if (SvUTF8(key))
3477         flags |= REFCOUNTED_HE_KEY_UTF8;
3478     if (!hash && SvIsCOW_shared_hash(key))
3479         hash = SvSHARED_HASH(key);
3480     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3481 }
3482
3483 /*
3484 =for apidoc refcounted_he_new_pvn
3485
3486 Creates a new C<refcounted_he>.  This consists of a single key/value
3487 pair and a reference to an existing C<refcounted_he> chain (which may
3488 be empty), and thus forms a longer chain.  When using the longer chain,
3489 the new key/value pair takes precedence over any entry for the same key
3490 further along the chain.
3491
3492 The new key is specified by C<keypv> and C<keylen>.  If C<flags> has
3493 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3494 as UTF-8, otherwise they are interpreted as Latin-1.  C<hash> is
3495 a precomputed hash of the key string, or zero if it has not been
3496 precomputed.
3497
3498 C<value> is the scalar value to store for this key.  C<value> is copied
3499 by this function, which thus does not take ownership of any reference
3500 to it, and later changes to the scalar will not be reflected in the
3501 value visible in the C<refcounted_he>.  Complex types of scalar will not
3502 be stored with referential integrity, but will be coerced to strings.
3503 C<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3504 value is to be associated with the key; this, as with any non-null value,
3505 takes precedence over the existence of a value for the key further along
3506 the chain.
3507
3508 C<parent> points to the rest of the C<refcounted_he> chain to be
3509 attached to the new C<refcounted_he>.  This function takes ownership
3510 of one reference to C<parent>, and returns one reference to the new
3511 C<refcounted_he>.
3512
3513 =cut
3514 */
3515
3516 struct refcounted_he *
3517 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3518         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3519 {
3520     STRLEN value_len = 0;
3521     const char *value_p = NULL;
3522     bool is_pv;
3523     char value_type;
3524     char hekflags;
3525     STRLEN key_offset = 1;
3526     struct refcounted_he *he;
3527     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3528
3529     if (!value || value == &PL_sv_placeholder) {
3530         value_type = HVrhek_delete;
3531     } else if (SvPOK(value)) {
3532         value_type = HVrhek_PV;
3533     } else if (SvIOK(value)) {
3534         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3535     } else if (!SvOK(value)) {
3536         value_type = HVrhek_undef;
3537     } else {
3538         value_type = HVrhek_PV;
3539     }
3540     is_pv = value_type == HVrhek_PV;
3541     if (is_pv) {
3542         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3543            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3544         value_p = SvPV_const(value, value_len);
3545         if (SvUTF8(value))
3546             value_type = HVrhek_PV_UTF8;
3547         key_offset = value_len + 2;
3548     }
3549     hekflags = value_type;
3550
3551     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3552         /* Canonicalise to Latin-1 where possible. */
3553         const char *keyend = keypv + keylen, *p;
3554         STRLEN nonascii_count = 0;
3555         for (p = keypv; p != keyend; p++) {
3556             if (! UTF8_IS_INVARIANT(*p)) {
3557                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3558                     goto canonicalised_key;
3559                 }
3560                 nonascii_count++;
3561                 p++;
3562             }
3563         }
3564         if (nonascii_count) {
3565             char *q;
3566             const char *p = keypv, *keyend = keypv + keylen;
3567             keylen -= nonascii_count;
3568             Newx(q, keylen, char);
3569             SAVEFREEPV(q);
3570             keypv = q;
3571             for (; p != keyend; p++, q++) {
3572                 U8 c = (U8)*p;
3573                 if (UTF8_IS_INVARIANT(c)) {
3574                     *q = (char) c;
3575                 }
3576                 else {
3577                     p++;
3578                     *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3579                 }
3580             }
3581         }
3582         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3583         canonicalised_key: ;
3584     }
3585     if (flags & REFCOUNTED_HE_KEY_UTF8)
3586         hekflags |= HVhek_UTF8;
3587     if (!hash)
3588         PERL_HASH(hash, keypv, keylen);
3589
3590 #ifdef USE_ITHREADS
3591     he = (struct refcounted_he*)
3592         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3593                              + keylen
3594                              + key_offset);
3595 #else
3596     he = (struct refcounted_he*)
3597         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3598                              + key_offset);
3599 #endif
3600
3601     he->refcounted_he_next = parent;
3602
3603     if (is_pv) {
3604         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3605         he->refcounted_he_val.refcounted_he_u_len = value_len;
3606     } else if (value_type == HVrhek_IV) {
3607         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3608     } else if (value_type == HVrhek_UV) {
3609         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3610     }
3611
3612 #ifdef USE_ITHREADS
3613     he->refcounted_he_hash = hash;
3614     he->refcounted_he_keylen = keylen;
3615     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3616 #else
3617     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3618 #endif
3619
3620     he->refcounted_he_data[0] = hekflags;
3621     he->refcounted_he_refcnt = 1;
3622
3623     return he;
3624 }
3625
3626 /*
3627 =for apidoc refcounted_he_new_pv
3628
3629 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3630 of a string/length pair.
3631
3632 =cut
3633 */
3634
3635 struct refcounted_he *
3636 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3637         const char *key, U32 hash, SV *value, U32 flags)
3638 {
3639     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3640     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3641 }
3642
3643 /*
3644 =for apidoc refcounted_he_new_sv
3645
3646 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3647 string/length pair.
3648
3649 =cut
3650 */
3651
3652 struct refcounted_he *
3653 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3654         SV *key, U32 hash, SV *value, U32 flags)
3655 {
3656     const char *keypv;
3657     STRLEN keylen;
3658     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3659     if (flags & REFCOUNTED_HE_KEY_UTF8)
3660         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf,
3661             (UV)flags);
3662     keypv = SvPV_const(key, keylen);
3663     if (SvUTF8(key))
3664         flags |= REFCOUNTED_HE_KEY_UTF8;
3665     if (!hash && SvIsCOW_shared_hash(key))
3666         hash = SvSHARED_HASH(key);
3667     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3668 }
3669
3670 /*
3671 =for apidoc refcounted_he_free
3672
3673 Decrements the reference count of a C<refcounted_he> by one.  If the
3674 reference count reaches zero the structure's memory is freed, which
3675 (recursively) causes a reduction of its parent C<refcounted_he>'s
3676 reference count.  It is safe to pass a null pointer to this function:
3677 no action occurs in this case.
3678
3679 =cut
3680 */
3681
3682 void
3683 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3684 #ifdef USE_ITHREADS
3685 #endif
3686     PERL_UNUSED_CONTEXT;
3687
3688     while (he) {
3689         struct refcounted_he *copy;
3690         U32 new_count;
3691
3692         HINTS_REFCNT_LOCK;
3693         new_count = --he->refcounted_he_refcnt;
3694         HINTS_REFCNT_UNLOCK;
3695         
3696         if (new_count) {
3697             return;
3698         }
3699
3700 #ifndef USE_ITHREADS
3701         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3702 #endif
3703         copy = he;
3704         he = he->refcounted_he_next;
3705         PerlMemShared_free(copy);
3706     }
3707 }
3708
3709 /*
3710 =for apidoc refcounted_he_inc
3711
3712 Increment the reference count of a C<refcounted_he>.  The pointer to the
3713 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3714 to this function: no action occurs and a null pointer is returned.
3715
3716 =cut
3717 */
3718
3719 struct refcounted_he *
3720 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3721 {
3722 #ifdef USE_ITHREADS
3723 #endif
3724     PERL_UNUSED_CONTEXT;
3725     if (he) {
3726         HINTS_REFCNT_LOCK;
3727         he->refcounted_he_refcnt++;
3728         HINTS_REFCNT_UNLOCK;
3729     }
3730     return he;
3731 }
3732
3733 /*
3734 =for apidoc_section $COP
3735 =for apidoc cop_fetch_label
3736
3737 Returns the label attached to a cop, and stores its length in bytes into
3738 C<*len>.
3739 Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0.
3740
3741 Alternatively, use the macro C<L</CopLABEL_len_flags>>;
3742 or if you don't need to know if the label is UTF-8 or not, the macro
3743 C<L</CopLABEL_len>>;
3744 or if you additionally dont need to know the length, C<L</CopLABEL>>.
3745
3746 =cut
3747 */
3748
3749 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3750    the linked list.  */
3751 const char *
3752 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3753     struct refcounted_he *const chain = cop->cop_hints_hash;
3754
3755     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3756     PERL_UNUSED_CONTEXT;
3757
3758     if (!chain)
3759         return NULL;
3760 #ifdef USE_ITHREADS
3761     if (chain->refcounted_he_keylen != 1)
3762         return NULL;
3763     if (*REF_HE_KEY(chain) != ':')
3764         return NULL;
3765 #else
3766     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3767         return NULL;
3768     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3769         return NULL;
3770 #endif
3771     /* Stop anyone trying to really mess us up by adding their own value for
3772        ':' into %^H  */
3773     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3774         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3775         return NULL;
3776
3777     if (len)
3778         *len = chain->refcounted_he_val.refcounted_he_u_len;
3779     if (flags) {
3780         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3781                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3782     }
3783     return chain->refcounted_he_data + 1;
3784 }
3785
3786 /*
3787 =for apidoc cop_store_label
3788
3789 Save a label into a C<cop_hints_hash>.
3790 You need to set flags to C<SVf_UTF8>
3791 for a UTF-8 label.  Any other flag is ignored.
3792
3793 =cut
3794 */
3795
3796 void
3797 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3798                      U32 flags)
3799 {
3800     SV *labelsv;
3801     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3802
3803     if (flags & ~(SVf_UTF8))
3804         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3805                    (UV)flags);
3806     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3807     if (flags & SVf_UTF8)
3808         SvUTF8_on(labelsv);
3809     cop->cop_hints_hash
3810         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3811 }
3812
3813 /*
3814 =for apidoc_section $HV
3815 =for apidoc hv_assert
3816
3817 Check that a hash is in an internally consistent state.
3818
3819 =cut
3820 */
3821
3822 #ifdef DEBUGGING
3823
3824 void
3825 Perl_hv_assert(pTHX_ HV *hv)
3826 {
3827     HE* entry;
3828     int withflags = 0;
3829     int placeholders = 0;
3830     int real = 0;
3831     int bad = 0;
3832     const I32 riter = HvRITER_get(hv);
3833     HE *eiter = HvEITER_get(hv);
3834
3835     PERL_ARGS_ASSERT_HV_ASSERT;
3836
3837     (void)hv_iterinit(hv);
3838
3839     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3840         /* sanity check the values */
3841         if (HeVAL(entry) == &PL_sv_placeholder)
3842             placeholders++;
3843         else
3844             real++;
3845         /* sanity check the keys */
3846         if (HeSVKEY(entry)) {
3847             NOOP;   /* Don't know what to check on SV keys.  */
3848         } else if (HeKUTF8(entry)) {
3849             withflags++;
3850             if (HeKWASUTF8(entry)) {
3851                 PerlIO_printf(Perl_debug_log,
3852                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3853                             (int) HeKLEN(entry),  HeKEY(entry));
3854                 bad = 1;
3855             }
3856         } else if (HeKWASUTF8(entry))
3857             withflags++;
3858     }
3859     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3860         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3861         const int nhashkeys = HvUSEDKEYS(hv);
3862         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3863
3864         if (nhashkeys != real) {
3865             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3866             bad = 1;
3867         }
3868         if (nhashplaceholders != placeholders) {
3869             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3870             bad = 1;
3871         }
3872     }
3873     if (withflags && ! HvHASKFLAGS(hv)) {
3874         PerlIO_printf(Perl_debug_log,
3875                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3876                     withflags);
3877         bad = 1;
3878     }
3879     if (bad) {
3880         sv_dump(MUTABLE_SV(hv));
3881     }
3882     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3883     HvEITER_set(hv, eiter);
3884 }
3885
3886 #endif
3887
3888 /*
3889  * ex: set ts=8 sts=4 sw=4 et:
3890  */