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