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