Add tests for overriding <> versus rcatline
[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 intialize 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;
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     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
2100
2101     if (!hv)
2102         Perl_croak(aTHX_ "Bad hash");
2103
2104     if (SvOOK(hv)) {
2105         struct xpvhv_aux * iter = HvAUX(hv);
2106         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2107         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
2108             HvLAZYDEL_off(hv);
2109             hv_free_ent(hv, entry);
2110         }
2111         iter = HvAUX(hv); /* may have been reallocated */
2112         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
2113         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2114 #ifdef PERL_HASH_RANDOMIZE_KEYS
2115         iter->xhv_last_rand = iter->xhv_rand;
2116 #endif
2117     } else {
2118         hv_auxinit(hv);
2119     }
2120
2121     /* used to be xhv->xhv_fill before 5.004_65 */
2122     return HvTOTALKEYS(hv);
2123 }
2124
2125 I32 *
2126 Perl_hv_riter_p(pTHX_ HV *hv) {
2127     struct xpvhv_aux *iter;
2128
2129     PERL_ARGS_ASSERT_HV_RITER_P;
2130
2131     if (!hv)
2132         Perl_croak(aTHX_ "Bad hash");
2133
2134     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2135     return &(iter->xhv_riter);
2136 }
2137
2138 HE **
2139 Perl_hv_eiter_p(pTHX_ HV *hv) {
2140     struct xpvhv_aux *iter;
2141
2142     PERL_ARGS_ASSERT_HV_EITER_P;
2143
2144     if (!hv)
2145         Perl_croak(aTHX_ "Bad hash");
2146
2147     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2148     return &(iter->xhv_eiter);
2149 }
2150
2151 void
2152 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2153     struct xpvhv_aux *iter;
2154
2155     PERL_ARGS_ASSERT_HV_RITER_SET;
2156
2157     if (!hv)
2158         Perl_croak(aTHX_ "Bad hash");
2159
2160     if (SvOOK(hv)) {
2161         iter = HvAUX(hv);
2162     } else {
2163         if (riter == -1)
2164             return;
2165
2166         iter = hv_auxinit(hv);
2167     }
2168     iter->xhv_riter = riter;
2169 }
2170
2171 void
2172 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2173     struct xpvhv_aux *iter;
2174
2175     PERL_ARGS_ASSERT_HV_RAND_SET;
2176
2177 #ifdef PERL_HASH_RANDOMIZE_KEYS
2178     if (!hv)
2179         Perl_croak(aTHX_ "Bad hash");
2180
2181     if (SvOOK(hv)) {
2182         iter = HvAUX(hv);
2183     } else {
2184         iter = hv_auxinit(hv);
2185     }
2186     iter->xhv_rand = new_xhv_rand;
2187 #else
2188     Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2189 #endif
2190 }
2191
2192 void
2193 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2194     struct xpvhv_aux *iter;
2195
2196     PERL_ARGS_ASSERT_HV_EITER_SET;
2197
2198     if (!hv)
2199         Perl_croak(aTHX_ "Bad hash");
2200
2201     if (SvOOK(hv)) {
2202         iter = HvAUX(hv);
2203     } else {
2204         /* 0 is the default so don't go malloc()ing a new structure just to
2205            hold 0.  */
2206         if (!eiter)
2207             return;
2208
2209         iter = hv_auxinit(hv);
2210     }
2211     iter->xhv_eiter = eiter;
2212 }
2213
2214 void
2215 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2216 {
2217     dVAR;
2218     struct xpvhv_aux *iter;
2219     U32 hash;
2220     HEK **spot;
2221
2222     PERL_ARGS_ASSERT_HV_NAME_SET;
2223
2224     if (len > I32_MAX)
2225         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2226
2227     if (SvOOK(hv)) {
2228         iter = HvAUX(hv);
2229         if (iter->xhv_name_u.xhvnameu_name) {
2230             if(iter->xhv_name_count) {
2231               if(flags & HV_NAME_SETALL) {
2232                 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2233                 HEK **hekp = name + (
2234                     iter->xhv_name_count < 0
2235                      ? -iter->xhv_name_count
2236                      :  iter->xhv_name_count
2237                    );
2238                 while(hekp-- > name+1) 
2239                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2240                 /* The first elem may be null. */
2241                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2242                 Safefree(name);
2243                 iter = HvAUX(hv); /* may been realloced */
2244                 spot = &iter->xhv_name_u.xhvnameu_name;
2245                 iter->xhv_name_count = 0;
2246               }
2247               else {
2248                 if(iter->xhv_name_count > 0) {
2249                     /* shift some things over */
2250                     Renew(
2251                      iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2252                     );
2253                     spot = iter->xhv_name_u.xhvnameu_names;
2254                     spot[iter->xhv_name_count] = spot[1];
2255                     spot[1] = spot[0];
2256                     iter->xhv_name_count = -(iter->xhv_name_count + 1);
2257                 }
2258                 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2259                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2260                 }
2261               }
2262             }
2263             else if (flags & HV_NAME_SETALL) {
2264                 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2265                 iter = HvAUX(hv); /* may been realloced */
2266                 spot = &iter->xhv_name_u.xhvnameu_name;
2267             }
2268             else {
2269                 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2270                 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2271                 iter->xhv_name_count = -2;
2272                 spot = iter->xhv_name_u.xhvnameu_names;
2273                 spot[1] = existing_name;
2274             }
2275         }
2276         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2277     } else {
2278         if (name == 0)
2279             return;
2280
2281         iter = hv_auxinit(hv);
2282         spot = &iter->xhv_name_u.xhvnameu_name;
2283     }
2284     PERL_HASH(hash, name, len);
2285     *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2286 }
2287
2288 /*
2289 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2290 and bytes checking.
2291 */
2292
2293 STATIC I32
2294 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2295     if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2296         if (flags & SVf_UTF8)
2297             return (bytes_cmp_utf8(
2298                         (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2299                         (const U8*)pv, pvlen) == 0);
2300         else
2301             return (bytes_cmp_utf8(
2302                         (const U8*)pv, pvlen,
2303                         (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2304     }
2305     else
2306         return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2307                     || memEQ(HEK_KEY(hek), pv, pvlen));
2308 }
2309
2310 /*
2311 =for apidoc hv_ename_add
2312
2313 Adds a name to a stash's internal list of effective names.  See
2314 C<hv_ename_delete>.
2315
2316 This is called when a stash is assigned to a new location in the symbol
2317 table.
2318
2319 =cut
2320 */
2321
2322 void
2323 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2324 {
2325     dVAR;
2326     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2327     U32 hash;
2328
2329     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2330
2331     if (len > I32_MAX)
2332         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2333
2334     PERL_HASH(hash, name, len);
2335
2336     if (aux->xhv_name_count) {
2337         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
2338         I32 count = aux->xhv_name_count;
2339         HEK **hekp = xhv_name + (count < 0 ? -count : count);
2340         while (hekp-- > xhv_name)
2341             if (
2342                  (HEK_UTF8(*hekp) || (flags & SVf_UTF8)) 
2343                     ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2344                     : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2345                ) {
2346                 if (hekp == xhv_name && count < 0)
2347                     aux->xhv_name_count = -count;
2348                 return;
2349             }
2350         if (count < 0) aux->xhv_name_count--, count = -count;
2351         else aux->xhv_name_count++;
2352         Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2353         (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2354     }
2355     else {
2356         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2357         if (
2358             existing_name && (
2359              (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2360                 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2361                 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2362             )
2363         ) return;
2364         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2365         aux->xhv_name_count = existing_name ? 2 : -2;
2366         *aux->xhv_name_u.xhvnameu_names = existing_name;
2367         (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2368     }
2369 }
2370
2371 /*
2372 =for apidoc hv_ename_delete
2373
2374 Removes a name from a stash's internal list of effective names.  If this is
2375 the name returned by C<HvENAME>, then another name in the list will take
2376 its place (C<HvENAME> will use it).
2377
2378 This is called when a stash is deleted from the symbol table.
2379
2380 =cut
2381 */
2382
2383 void
2384 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2385 {
2386     struct xpvhv_aux *aux;
2387
2388     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2389
2390     if (len > I32_MAX)
2391         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2392
2393     if (!SvOOK(hv)) return;
2394
2395     aux = HvAUX(hv);
2396     if (!aux->xhv_name_u.xhvnameu_name) return;
2397
2398     if (aux->xhv_name_count) {
2399         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2400         I32 const count = aux->xhv_name_count;
2401         HEK **victim = namep + (count < 0 ? -count : count);
2402         while (victim-- > namep + 1)
2403             if (
2404              (HEK_UTF8(*victim) || (flags & SVf_UTF8)) 
2405                 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2406                 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2407             ) {
2408                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2409                 aux = HvAUX(hv); /* may been realloced */
2410                 if (count < 0) ++aux->xhv_name_count;
2411                 else --aux->xhv_name_count;
2412                 if (
2413                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2414                  && !*namep
2415                 ) {  /* if there are none left */
2416                     Safefree(namep);
2417                     aux->xhv_name_u.xhvnameu_names = NULL;
2418                     aux->xhv_name_count = 0;
2419                 }
2420                 else {
2421                     /* Move the last one back to fill the empty slot. It
2422                        does not matter what order they are in. */
2423                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2424                 }
2425                 return;
2426             }
2427         if (
2428             count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8)) 
2429                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2430                 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2431         ) {
2432             aux->xhv_name_count = -count;
2433         }
2434     }
2435     else if(
2436         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) 
2437                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2438                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2439                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2440     ) {
2441         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2442         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2443         *aux->xhv_name_u.xhvnameu_names = namehek;
2444         aux->xhv_name_count = -1;
2445     }
2446 }
2447
2448 AV **
2449 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2450     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2451
2452     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2453
2454     return &(iter->xhv_backreferences);
2455 }
2456
2457 void
2458 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2459     AV *av;
2460
2461     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2462
2463     if (!SvOOK(hv))
2464         return;
2465
2466     av = HvAUX(hv)->xhv_backreferences;
2467
2468     if (av) {
2469         HvAUX(hv)->xhv_backreferences = 0;
2470         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2471         if (SvTYPE(av) == SVt_PVAV)
2472             SvREFCNT_dec_NN(av);
2473     }
2474 }
2475
2476 /*
2477 hv_iternext is implemented as a macro in hv.h
2478
2479 =for apidoc hv_iternext
2480
2481 Returns entries from a hash iterator.  See C<hv_iterinit>.
2482
2483 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2484 iterator currently points to, without losing your place or invalidating your
2485 iterator.  Note that in this case the current entry is deleted from the hash
2486 with your iterator holding the last reference to it.  Your iterator is flagged
2487 to free the entry on the next call to C<hv_iternext>, so you must not discard
2488 your iterator immediately else the entry will leak - call C<hv_iternext> to
2489 trigger the resource deallocation.
2490
2491 =for apidoc hv_iternext_flags
2492
2493 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2494 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2495 set the placeholders keys (for restricted hashes) will be returned in addition
2496 to normal keys.  By default placeholders are automatically skipped over.
2497 Currently a placeholder is implemented with a value that is
2498 C<&PL_sv_placeholder>.  Note that the implementation of placeholders and
2499 restricted hashes may change, and the implementation currently is
2500 insufficiently abstracted for any change to be tidy.
2501
2502 =cut
2503 */
2504
2505 HE *
2506 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2507 {
2508     dVAR;
2509     XPVHV* xhv;
2510     HE *entry;
2511     HE *oldentry;
2512     MAGIC* mg;
2513     struct xpvhv_aux *iter;
2514
2515     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2516
2517     if (!hv)
2518         Perl_croak(aTHX_ "Bad hash");
2519
2520     xhv = (XPVHV*)SvANY(hv);
2521
2522     if (!SvOOK(hv)) {
2523         /* Too many things (well, pp_each at least) merrily assume that you can
2524            call hv_iternext without calling hv_iterinit, so we'll have to deal
2525            with it.  */
2526         hv_iterinit(hv);
2527     }
2528     iter = HvAUX(hv);
2529
2530     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2531     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2532         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2533             SV * const key = sv_newmortal();
2534             if (entry) {
2535                 sv_setsv(key, HeSVKEY_force(entry));
2536                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2537                 HeSVKEY_set(entry, NULL);
2538             }
2539             else {
2540                 char *k;
2541                 HEK *hek;
2542
2543                 /* one HE per MAGICAL hash */
2544                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2545                 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2546                 Zero(entry, 1, HE);
2547                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2548                 hek = (HEK*)k;
2549                 HeKEY_hek(entry) = hek;
2550                 HeKLEN(entry) = HEf_SVKEY;
2551             }
2552             magic_nextpack(MUTABLE_SV(hv),mg,key);
2553             if (SvOK(key)) {
2554                 /* force key to stay around until next time */
2555                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2556                 return entry;               /* beware, hent_val is not set */
2557             }
2558             SvREFCNT_dec(HeVAL(entry));
2559             Safefree(HeKEY_hek(entry));
2560             del_HE(entry);
2561             iter = HvAUX(hv); /* may been realloced */
2562             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2563             HvLAZYDEL_off(hv);
2564             return NULL;
2565         }
2566     }
2567 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2568     if (!entry && SvRMAGICAL((const SV *)hv)
2569         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2570         prime_env_iter();
2571 #ifdef VMS
2572         /* The prime_env_iter() on VMS just loaded up new hash values
2573          * so the iteration count needs to be reset back to the beginning
2574          */
2575         hv_iterinit(hv);
2576         iter = HvAUX(hv);
2577         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2578 #endif
2579     }
2580 #endif
2581
2582     /* hv_iterinit now ensures this.  */
2583     assert (HvARRAY(hv));
2584
2585     /* At start of hash, entry is NULL.  */
2586     if (entry)
2587     {
2588         entry = HeNEXT(entry);
2589         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2590             /*
2591              * Skip past any placeholders -- don't want to include them in
2592              * any iteration.
2593              */
2594             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2595                 entry = HeNEXT(entry);
2596             }
2597         }
2598     }
2599
2600 #ifdef PERL_HASH_RANDOMIZE_KEYS
2601     if (iter->xhv_last_rand != iter->xhv_rand) {
2602         if (iter->xhv_riter != -1) {
2603             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2604                              "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2605                              pTHX__FORMAT
2606                              pTHX__VALUE);
2607         }
2608         iter = HvAUX(hv); /* may been realloced */
2609         iter->xhv_last_rand = iter->xhv_rand;
2610     }
2611 #endif
2612
2613     /* Skip the entire loop if the hash is empty.   */
2614     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2615         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2616         while (!entry) {
2617             /* OK. Come to the end of the current list.  Grab the next one.  */
2618
2619             iter->xhv_riter++; /* HvRITER(hv)++ */
2620             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2621                 /* There is no next one.  End of the hash.  */
2622                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2623 #ifdef PERL_HASH_RANDOMIZE_KEYS
2624                 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2625 #endif
2626                 break;
2627             }
2628             entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2629
2630             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2631                 /* If we have an entry, but it's a placeholder, don't count it.
2632                    Try the next.  */
2633                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2634                     entry = HeNEXT(entry);
2635             }
2636             /* Will loop again if this linked list starts NULL
2637                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2638                or if we run through it and find only placeholders.  */
2639         }
2640     }
2641     else {
2642         iter->xhv_riter = -1;
2643 #ifdef PERL_HASH_RANDOMIZE_KEYS
2644         iter->xhv_last_rand = iter->xhv_rand;
2645 #endif
2646     }
2647
2648     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2649         HvLAZYDEL_off(hv);
2650         hv_free_ent(hv, oldentry);
2651     }
2652
2653     iter = HvAUX(hv); /* may been realloced */
2654     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2655     return entry;
2656 }
2657
2658 /*
2659 =for apidoc hv_iterkey
2660
2661 Returns the key from the current position of the hash iterator.  See
2662 C<hv_iterinit>.
2663
2664 =cut
2665 */
2666
2667 char *
2668 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2669 {
2670     PERL_ARGS_ASSERT_HV_ITERKEY;
2671
2672     if (HeKLEN(entry) == HEf_SVKEY) {
2673         STRLEN len;
2674         char * const p = SvPV(HeKEY_sv(entry), len);
2675         *retlen = len;
2676         return p;
2677     }
2678     else {
2679         *retlen = HeKLEN(entry);
2680         return HeKEY(entry);
2681     }
2682 }
2683
2684 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2685 /*
2686 =for apidoc hv_iterkeysv
2687
2688 Returns the key as an C<SV*> from the current position of the hash
2689 iterator.  The return value will always be a mortal copy of the key.  Also
2690 see C<hv_iterinit>.
2691
2692 =cut
2693 */
2694
2695 SV *
2696 Perl_hv_iterkeysv(pTHX_ HE *entry)
2697 {
2698     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2699
2700     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2701 }
2702
2703 /*
2704 =for apidoc hv_iterval
2705
2706 Returns the value from the current position of the hash iterator.  See
2707 C<hv_iterkey>.
2708
2709 =cut
2710 */
2711
2712 SV *
2713 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2714 {
2715     PERL_ARGS_ASSERT_HV_ITERVAL;
2716
2717     if (SvRMAGICAL(hv)) {
2718         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2719             SV* const sv = sv_newmortal();
2720             if (HeKLEN(entry) == HEf_SVKEY)
2721                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2722             else
2723                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2724             return sv;
2725         }
2726     }
2727     return HeVAL(entry);
2728 }
2729
2730 /*
2731 =for apidoc hv_iternextsv
2732
2733 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2734 operation.
2735
2736 =cut
2737 */
2738
2739 SV *
2740 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2741 {
2742     HE * const he = hv_iternext_flags(hv, 0);
2743
2744     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2745
2746     if (!he)
2747         return NULL;
2748     *key = hv_iterkey(he, retlen);
2749     return hv_iterval(hv, he);
2750 }
2751
2752 /*
2753
2754 Now a macro in hv.h
2755
2756 =for apidoc hv_magic
2757
2758 Adds magic to a hash.  See C<sv_magic>.
2759
2760 =cut
2761 */
2762
2763 /* possibly free a shared string if no one has access to it
2764  * len and hash must both be valid for str.
2765  */
2766 void
2767 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2768 {
2769     unshare_hek_or_pvn (NULL, str, len, hash);
2770 }
2771
2772
2773 void
2774 Perl_unshare_hek(pTHX_ HEK *hek)
2775 {
2776     assert(hek);
2777     unshare_hek_or_pvn(hek, NULL, 0, 0);
2778 }
2779
2780 /* possibly free a shared string if no one has access to it
2781    hek if non-NULL takes priority over the other 3, else str, len and hash
2782    are used.  If so, len and hash must both be valid for str.
2783  */
2784 STATIC void
2785 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2786 {
2787     XPVHV* xhv;
2788     HE *entry;
2789     HE **oentry;
2790     bool is_utf8 = FALSE;
2791     int k_flags = 0;
2792     const char * const save = str;
2793     struct shared_he *he = NULL;
2794
2795     if (hek) {
2796         /* Find the shared he which is just before us in memory.  */
2797         he = (struct shared_he *)(((char *)hek)
2798                                   - STRUCT_OFFSET(struct shared_he,
2799                                                   shared_he_hek));
2800
2801         /* Assert that the caller passed us a genuine (or at least consistent)
2802            shared hek  */
2803         assert (he->shared_he_he.hent_hek == hek);
2804
2805         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2806             --he->shared_he_he.he_valu.hent_refcount;
2807             return;
2808         }
2809
2810         hash = HEK_HASH(hek);
2811     } else if (len < 0) {
2812         STRLEN tmplen = -len;
2813         is_utf8 = TRUE;
2814         /* See the note in hv_fetch(). --jhi */
2815         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2816         len = tmplen;
2817         if (is_utf8)
2818             k_flags = HVhek_UTF8;
2819         if (str != save)
2820             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2821     }
2822
2823     /* what follows was the moral equivalent of:
2824     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2825         if (--*Svp == NULL)
2826             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2827     } */
2828     xhv = (XPVHV*)SvANY(PL_strtab);
2829     /* assert(xhv_array != 0) */
2830     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2831     if (he) {
2832         const HE *const he_he = &(he->shared_he_he);
2833         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2834             if (entry == he_he)
2835                 break;
2836         }
2837     } else {
2838         const int flags_masked = k_flags & HVhek_MASK;
2839         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2840             if (HeHASH(entry) != hash)          /* strings can't be equal */
2841                 continue;
2842             if (HeKLEN(entry) != len)
2843                 continue;
2844             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2845                 continue;
2846             if (HeKFLAGS(entry) != flags_masked)
2847                 continue;
2848             break;
2849         }
2850     }
2851
2852     if (entry) {
2853         if (--entry->he_valu.hent_refcount == 0) {
2854             *oentry = HeNEXT(entry);
2855             Safefree(entry);
2856             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2857         }
2858     }
2859
2860     if (!entry)
2861         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2862                          "Attempt to free nonexistent shared string '%s'%s"
2863                          pTHX__FORMAT,
2864                          hek ? HEK_KEY(hek) : str,
2865                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2866     if (k_flags & HVhek_FREEKEY)
2867         Safefree(str);
2868 }
2869
2870 /* get a (constant) string ptr from the global string table
2871  * string will get added if it is not already there.
2872  * len and hash must both be valid for str.
2873  */
2874 HEK *
2875 Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
2876 {
2877     bool is_utf8 = FALSE;
2878     int flags = 0;
2879     const char * const save = str;
2880
2881     PERL_ARGS_ASSERT_SHARE_HEK;
2882
2883     if (len < 0) {
2884       STRLEN tmplen = -len;
2885       is_utf8 = TRUE;
2886       /* See the note in hv_fetch(). --jhi */
2887       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2888       len = tmplen;
2889       /* If we were able to downgrade here, then than means that we were passed
2890          in a key which only had chars 0-255, but was utf8 encoded.  */
2891       if (is_utf8)
2892           flags = HVhek_UTF8;
2893       /* If we found we were able to downgrade the string to bytes, then
2894          we should flag that it needs upgrading on keys or each.  Also flag
2895          that we need share_hek_flags to free the string.  */
2896       if (str != save) {
2897           dVAR;
2898           PERL_HASH(hash, str, len);
2899           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2900       }
2901     }
2902
2903     return share_hek_flags (str, len, hash, flags);
2904 }
2905
2906 STATIC HEK *
2907 S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
2908 {
2909     HE *entry;
2910     const int flags_masked = flags & HVhek_MASK;
2911     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2912     XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2913
2914     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2915
2916     /* what follows is the moral equivalent of:
2917
2918     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2919         hv_store(PL_strtab, str, len, NULL, hash);
2920
2921         Can't rehash the shared string table, so not sure if it's worth
2922         counting the number of entries in the linked list
2923     */
2924
2925     /* assert(xhv_array != 0) */
2926     entry = (HvARRAY(PL_strtab))[hindex];
2927     for (;entry; entry = HeNEXT(entry)) {
2928         if (HeHASH(entry) != hash)              /* strings can't be equal */
2929             continue;
2930         if (HeKLEN(entry) != len)
2931             continue;
2932         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2933             continue;
2934         if (HeKFLAGS(entry) != flags_masked)
2935             continue;
2936         break;
2937     }
2938
2939     if (!entry) {
2940         /* What used to be head of the list.
2941            If this is NULL, then we're the first entry for this slot, which
2942            means we need to increate fill.  */
2943         struct shared_he *new_entry;
2944         HEK *hek;
2945         char *k;
2946         HE **const head = &HvARRAY(PL_strtab)[hindex];
2947         HE *const next = *head;
2948
2949         /* We don't actually store a HE from the arena and a regular HEK.
2950            Instead we allocate one chunk of memory big enough for both,
2951            and put the HEK straight after the HE. This way we can find the
2952            HE directly from the HEK.
2953         */
2954
2955         Newx(k, STRUCT_OFFSET(struct shared_he,
2956                                 shared_he_hek.hek_key[0]) + len + 2, char);
2957         new_entry = (struct shared_he *)k;
2958         entry = &(new_entry->shared_he_he);
2959         hek = &(new_entry->shared_he_hek);
2960
2961         Copy(str, HEK_KEY(hek), len, char);
2962         HEK_KEY(hek)[len] = 0;
2963         HEK_LEN(hek) = len;
2964         HEK_HASH(hek) = hash;
2965         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2966
2967         /* Still "point" to the HEK, so that other code need not know what
2968            we're up to.  */
2969         HeKEY_hek(entry) = hek;
2970         entry->he_valu.hent_refcount = 0;
2971         HeNEXT(entry) = next;
2972         *head = entry;
2973
2974         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2975         if (!next) {                    /* initial entry? */
2976         } else if ( DO_HSPLIT(xhv) ) {
2977             const STRLEN oldsize = xhv->xhv_max + 1;
2978             hsplit(PL_strtab, oldsize, oldsize * 2);
2979         }
2980     }
2981
2982     ++entry->he_valu.hent_refcount;
2983
2984     if (flags & HVhek_FREEKEY)
2985         Safefree(str);
2986
2987     return HeKEY_hek(entry);
2988 }
2989
2990 SSize_t *
2991 Perl_hv_placeholders_p(pTHX_ HV *hv)
2992 {
2993     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2994
2995     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2996
2997     if (!mg) {
2998         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2999
3000         if (!mg) {
3001             Perl_die(aTHX_ "panic: hv_placeholders_p");
3002         }
3003     }
3004     return &(mg->mg_len);
3005 }
3006
3007
3008 I32
3009 Perl_hv_placeholders_get(pTHX_ const HV *hv)
3010 {
3011     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3012
3013     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3014     PERL_UNUSED_CONTEXT;
3015
3016     return mg ? mg->mg_len : 0;
3017 }
3018
3019 void
3020 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3021 {
3022     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3023
3024     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3025
3026     if (mg) {
3027         mg->mg_len = ph;
3028     } else if (ph) {
3029         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3030             Perl_die(aTHX_ "panic: hv_placeholders_set");
3031     }
3032     /* else we don't need to add magic to record 0 placeholders.  */
3033 }
3034
3035 STATIC SV *
3036 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3037 {
3038     dVAR;
3039     SV *value;
3040
3041     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3042
3043     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3044     case HVrhek_undef:
3045         value = newSV(0);
3046         break;
3047     case HVrhek_delete:
3048         value = &PL_sv_placeholder;
3049         break;
3050     case HVrhek_IV:
3051         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3052         break;
3053     case HVrhek_UV:
3054         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3055         break;
3056     case HVrhek_PV:
3057     case HVrhek_PV_UTF8:
3058         /* Create a string SV that directly points to the bytes in our
3059            structure.  */
3060         value = newSV_type(SVt_PV);
3061         SvPV_set(value, (char *) he->refcounted_he_data + 1);
3062         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3063         /* This stops anything trying to free it  */
3064         SvLEN_set(value, 0);
3065         SvPOK_on(value);
3066         SvREADONLY_on(value);
3067         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3068             SvUTF8_on(value);
3069         break;
3070     default:
3071         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
3072                    (UV)he->refcounted_he_data[0]);
3073     }
3074     return value;
3075 }
3076
3077 /*
3078 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
3079
3080 Generates and returns a C<HV *> representing the content of a
3081 C<refcounted_he> chain.
3082 I<flags> is currently unused and must be zero.
3083
3084 =cut
3085 */
3086 HV *
3087 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3088 {
3089     dVAR;
3090     HV *hv;
3091     U32 placeholders, max;
3092
3093     if (flags)
3094         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
3095             (UV)flags);
3096
3097     /* We could chase the chain once to get an idea of the number of keys,
3098        and call ksplit.  But for now we'll make a potentially inefficient
3099        hash with only 8 entries in its array.  */
3100     hv = newHV();
3101     max = HvMAX(hv);
3102     if (!HvARRAY(hv)) {
3103         char *array;
3104         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3105         HvARRAY(hv) = (HE**)array;
3106     }
3107
3108     placeholders = 0;
3109     while (chain) {
3110 #ifdef USE_ITHREADS
3111         U32 hash = chain->refcounted_he_hash;
3112 #else
3113         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3114 #endif
3115         HE **oentry = &((HvARRAY(hv))[hash & max]);
3116         HE *entry = *oentry;
3117         SV *value;
3118
3119         for (; entry; entry = HeNEXT(entry)) {
3120             if (HeHASH(entry) == hash) {
3121                 /* We might have a duplicate key here.  If so, entry is older
3122                    than the key we've already put in the hash, so if they are
3123                    the same, skip adding entry.  */
3124 #ifdef USE_ITHREADS
3125                 const STRLEN klen = HeKLEN(entry);
3126                 const char *const key = HeKEY(entry);
3127                 if (klen == chain->refcounted_he_keylen
3128                     && (!!HeKUTF8(entry)
3129                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3130                     && memEQ(key, REF_HE_KEY(chain), klen))
3131                     goto next_please;
3132 #else
3133                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3134                     goto next_please;
3135                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3136                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3137                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3138                              HeKLEN(entry)))
3139                     goto next_please;
3140 #endif
3141             }
3142         }
3143         assert (!entry);
3144         entry = new_HE();
3145
3146 #ifdef USE_ITHREADS
3147         HeKEY_hek(entry)
3148             = share_hek_flags(REF_HE_KEY(chain),
3149                               chain->refcounted_he_keylen,
3150                               chain->refcounted_he_hash,
3151                               (chain->refcounted_he_data[0]
3152                                & (HVhek_UTF8|HVhek_WASUTF8)));
3153 #else
3154         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3155 #endif
3156         value = refcounted_he_value(chain);
3157         if (value == &PL_sv_placeholder)
3158             placeholders++;
3159         HeVAL(entry) = value;
3160
3161         /* Link it into the chain.  */
3162         HeNEXT(entry) = *oentry;
3163         *oentry = entry;
3164
3165         HvTOTALKEYS(hv)++;
3166
3167     next_please:
3168         chain = chain->refcounted_he_next;
3169     }
3170
3171     if (placeholders) {
3172         clear_placeholders(hv, placeholders);
3173         HvTOTALKEYS(hv) -= placeholders;
3174     }
3175
3176     /* We could check in the loop to see if we encounter any keys with key
3177        flags, but it's probably not worth it, as this per-hash flag is only
3178        really meant as an optimisation for things like Storable.  */
3179     HvHASKFLAGS_on(hv);
3180     DEBUG_A(Perl_hv_assert(aTHX_ hv));
3181
3182     return hv;
3183 }
3184
3185 /*
3186 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
3187
3188 Search along a C<refcounted_he> chain for an entry with the key specified
3189 by I<keypv> and I<keylen>.  If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3190 bit set, the key octets are interpreted as UTF-8, otherwise they
3191 are interpreted as Latin-1.  I<hash> is a precomputed hash of the key
3192 string, or zero if it has not been precomputed.  Returns a mortal scalar
3193 representing the value associated with the key, or C<&PL_sv_placeholder>
3194 if there is no value associated with the key.
3195
3196 =cut
3197 */
3198
3199 SV *
3200 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3201                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3202 {
3203     dVAR;
3204     U8 utf8_flag;
3205     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3206
3207     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3208         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
3209             (UV)flags);
3210     if (!chain)
3211         return &PL_sv_placeholder;
3212     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3213         /* For searching purposes, canonicalise to Latin-1 where possible. */
3214         const char *keyend = keypv + keylen, *p;
3215         STRLEN nonascii_count = 0;
3216         for (p = keypv; p != keyend; p++) {
3217             if (! UTF8_IS_INVARIANT(*p)) {
3218                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3219                     goto canonicalised_key;
3220                 }
3221                 nonascii_count++;
3222                 p++;
3223             }
3224         }
3225         if (nonascii_count) {
3226             char *q;
3227             const char *p = keypv, *keyend = keypv + keylen;
3228             keylen -= nonascii_count;
3229             Newx(q, keylen, char);
3230             SAVEFREEPV(q);
3231             keypv = q;
3232             for (; p != keyend; p++, q++) {
3233                 U8 c = (U8)*p;
3234                 if (UTF8_IS_INVARIANT(c)) {
3235                     *q = (char) c;
3236                 }
3237                 else {
3238                     p++;
3239                     *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
3240                 }
3241             }
3242         }
3243         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3244         canonicalised_key: ;
3245     }
3246     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3247     if (!hash)
3248         PERL_HASH(hash, keypv, keylen);
3249
3250     for (; chain; chain = chain->refcounted_he_next) {
3251         if (
3252 #ifdef USE_ITHREADS
3253             hash == chain->refcounted_he_hash &&
3254             keylen == chain->refcounted_he_keylen &&
3255             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3256             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3257 #else
3258             hash == HEK_HASH(chain->refcounted_he_hek) &&
3259             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3260             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3261             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3262 #endif
3263         ) {
3264             if (flags & REFCOUNTED_HE_EXISTS)
3265                 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3266                     == HVrhek_delete
3267                     ? NULL : &PL_sv_yes;
3268             return sv_2mortal(refcounted_he_value(chain));
3269         }
3270     }
3271     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3272 }
3273
3274 /*
3275 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3276
3277 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3278 instead of a string/length pair.
3279
3280 =cut
3281 */
3282
3283 SV *
3284 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3285                          const char *key, U32 hash, U32 flags)
3286 {
3287     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3288     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3289 }
3290
3291 /*
3292 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3293
3294 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3295 string/length pair.
3296
3297 =cut
3298 */
3299
3300 SV *
3301 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3302                          SV *key, U32 hash, U32 flags)
3303 {
3304     const char *keypv;
3305     STRLEN keylen;
3306     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3307     if (flags & REFCOUNTED_HE_KEY_UTF8)
3308         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3309             (UV)flags);
3310     keypv = SvPV_const(key, keylen);
3311     if (SvUTF8(key))
3312         flags |= REFCOUNTED_HE_KEY_UTF8;
3313     if (!hash && SvIsCOW_shared_hash(key))
3314         hash = SvSHARED_HASH(key);
3315     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3316 }
3317
3318 /*
3319 =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
3320
3321 Creates a new C<refcounted_he>.  This consists of a single key/value
3322 pair and a reference to an existing C<refcounted_he> chain (which may
3323 be empty), and thus forms a longer chain.  When using the longer chain,
3324 the new key/value pair takes precedence over any entry for the same key
3325 further along the chain.
3326
3327 The new key is specified by I<keypv> and I<keylen>.  If I<flags> has
3328 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3329 as UTF-8, otherwise they are interpreted as Latin-1.  I<hash> is
3330 a precomputed hash of the key string, or zero if it has not been
3331 precomputed.
3332
3333 I<value> is the scalar value to store for this key.  I<value> is copied
3334 by this function, which thus does not take ownership of any reference
3335 to it, and later changes to the scalar will not be reflected in the
3336 value visible in the C<refcounted_he>.  Complex types of scalar will not
3337 be stored with referential integrity, but will be coerced to strings.
3338 I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3339 value is to be associated with the key; this, as with any non-null value,
3340 takes precedence over the existence of a value for the key further along
3341 the chain.
3342
3343 I<parent> points to the rest of the C<refcounted_he> chain to be
3344 attached to the new C<refcounted_he>.  This function takes ownership
3345 of one reference to I<parent>, and returns one reference to the new
3346 C<refcounted_he>.
3347
3348 =cut
3349 */
3350
3351 struct refcounted_he *
3352 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3353         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3354 {
3355     dVAR;
3356     STRLEN value_len = 0;
3357     const char *value_p = NULL;
3358     bool is_pv;
3359     char value_type;
3360     char hekflags;
3361     STRLEN key_offset = 1;
3362     struct refcounted_he *he;
3363     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3364
3365     if (!value || value == &PL_sv_placeholder) {
3366         value_type = HVrhek_delete;
3367     } else if (SvPOK(value)) {
3368         value_type = HVrhek_PV;
3369     } else if (SvIOK(value)) {
3370         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3371     } else if (!SvOK(value)) {
3372         value_type = HVrhek_undef;
3373     } else {
3374         value_type = HVrhek_PV;
3375     }
3376     is_pv = value_type == HVrhek_PV;
3377     if (is_pv) {
3378         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3379            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3380         value_p = SvPV_const(value, value_len);
3381         if (SvUTF8(value))
3382             value_type = HVrhek_PV_UTF8;
3383         key_offset = value_len + 2;
3384     }
3385     hekflags = value_type;
3386
3387     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3388         /* Canonicalise to Latin-1 where possible. */
3389         const char *keyend = keypv + keylen, *p;
3390         STRLEN nonascii_count = 0;
3391         for (p = keypv; p != keyend; p++) {
3392             if (! UTF8_IS_INVARIANT(*p)) {
3393                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3394                     goto canonicalised_key;
3395                 }
3396                 nonascii_count++;
3397                 p++;
3398             }
3399         }
3400         if (nonascii_count) {
3401             char *q;
3402             const char *p = keypv, *keyend = keypv + keylen;
3403             keylen -= nonascii_count;
3404             Newx(q, keylen, char);
3405             SAVEFREEPV(q);
3406             keypv = q;
3407             for (; p != keyend; p++, q++) {
3408                 U8 c = (U8)*p;
3409                 if (UTF8_IS_INVARIANT(c)) {
3410                     *q = (char) c;
3411                 }
3412                 else {
3413                     p++;
3414                     *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
3415                 }
3416             }
3417         }
3418         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3419         canonicalised_key: ;
3420     }
3421     if (flags & REFCOUNTED_HE_KEY_UTF8)
3422         hekflags |= HVhek_UTF8;
3423     if (!hash)
3424         PERL_HASH(hash, keypv, keylen);
3425
3426 #ifdef USE_ITHREADS
3427     he = (struct refcounted_he*)
3428         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3429                              + keylen
3430                              + key_offset);
3431 #else
3432     he = (struct refcounted_he*)
3433         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3434                              + key_offset);
3435 #endif
3436
3437     he->refcounted_he_next = parent;
3438
3439     if (is_pv) {
3440         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3441         he->refcounted_he_val.refcounted_he_u_len = value_len;
3442     } else if (value_type == HVrhek_IV) {
3443         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3444     } else if (value_type == HVrhek_UV) {
3445         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3446     }
3447
3448 #ifdef USE_ITHREADS
3449     he->refcounted_he_hash = hash;
3450     he->refcounted_he_keylen = keylen;
3451     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3452 #else
3453     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3454 #endif
3455
3456     he->refcounted_he_data[0] = hekflags;
3457     he->refcounted_he_refcnt = 1;
3458
3459     return he;
3460 }
3461
3462 /*
3463 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3464
3465 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3466 of a string/length pair.
3467
3468 =cut
3469 */
3470
3471 struct refcounted_he *
3472 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3473         const char *key, U32 hash, SV *value, U32 flags)
3474 {
3475     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3476     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3477 }
3478
3479 /*
3480 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3481
3482 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3483 string/length pair.
3484
3485 =cut
3486 */
3487
3488 struct refcounted_he *
3489 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3490         SV *key, U32 hash, SV *value, U32 flags)
3491 {
3492     const char *keypv;
3493     STRLEN keylen;
3494     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3495     if (flags & REFCOUNTED_HE_KEY_UTF8)
3496         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3497             (UV)flags);
3498     keypv = SvPV_const(key, keylen);
3499     if (SvUTF8(key))
3500         flags |= REFCOUNTED_HE_KEY_UTF8;
3501     if (!hash && SvIsCOW_shared_hash(key))
3502         hash = SvSHARED_HASH(key);
3503     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3504 }
3505
3506 /*
3507 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3508
3509 Decrements the reference count of a C<refcounted_he> by one.  If the
3510 reference count reaches zero the structure's memory is freed, which
3511 (recursively) causes a reduction of its parent C<refcounted_he>'s
3512 reference count.  It is safe to pass a null pointer to this function:
3513 no action occurs in this case.
3514
3515 =cut
3516 */
3517
3518 void
3519 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3520 #ifdef USE_ITHREADS
3521     dVAR;
3522 #endif
3523     PERL_UNUSED_CONTEXT;
3524
3525     while (he) {
3526         struct refcounted_he *copy;
3527         U32 new_count;
3528
3529         HINTS_REFCNT_LOCK;
3530         new_count = --he->refcounted_he_refcnt;
3531         HINTS_REFCNT_UNLOCK;
3532         
3533         if (new_count) {
3534             return;
3535         }
3536
3537 #ifndef USE_ITHREADS
3538         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3539 #endif
3540         copy = he;
3541         he = he->refcounted_he_next;
3542         PerlMemShared_free(copy);
3543     }
3544 }
3545
3546 /*
3547 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3548
3549 Increment the reference count of a C<refcounted_he>.  The pointer to the
3550 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3551 to this function: no action occurs and a null pointer is returned.
3552
3553 =cut
3554 */
3555
3556 struct refcounted_he *
3557 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3558 {
3559 #ifdef USE_ITHREADS
3560     dVAR;
3561 #endif
3562     PERL_UNUSED_CONTEXT;
3563     if (he) {
3564         HINTS_REFCNT_LOCK;
3565         he->refcounted_he_refcnt++;
3566         HINTS_REFCNT_UNLOCK;
3567     }
3568     return he;
3569 }
3570
3571 /*
3572 =for apidoc cop_fetch_label
3573
3574 Returns the label attached to a cop.
3575 The flags pointer may be set to C<SVf_UTF8> or 0.
3576
3577 =cut
3578 */
3579
3580 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3581    the linked list.  */
3582 const char *
3583 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3584     struct refcounted_he *const chain = cop->cop_hints_hash;
3585
3586     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3587     PERL_UNUSED_CONTEXT;
3588
3589     if (!chain)
3590         return NULL;
3591 #ifdef USE_ITHREADS
3592     if (chain->refcounted_he_keylen != 1)
3593         return NULL;
3594     if (*REF_HE_KEY(chain) != ':')
3595         return NULL;
3596 #else
3597     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3598         return NULL;
3599     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3600         return NULL;
3601 #endif
3602     /* Stop anyone trying to really mess us up by adding their own value for
3603        ':' into %^H  */
3604     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3605         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3606         return NULL;
3607
3608     if (len)
3609         *len = chain->refcounted_he_val.refcounted_he_u_len;
3610     if (flags) {
3611         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3612                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3613     }
3614     return chain->refcounted_he_data + 1;
3615 }
3616
3617 /*
3618 =for apidoc cop_store_label
3619
3620 Save a label into a C<cop_hints_hash>.
3621 You need to set flags to C<SVf_UTF8>
3622 for a utf-8 label.
3623
3624 =cut
3625 */
3626
3627 void
3628 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3629                      U32 flags)
3630 {
3631     SV *labelsv;
3632     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3633
3634     if (flags & ~(SVf_UTF8))
3635         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3636                    (UV)flags);
3637     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3638     if (flags & SVf_UTF8)
3639         SvUTF8_on(labelsv);
3640     cop->cop_hints_hash
3641         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3642 }
3643
3644 /*
3645 =for apidoc hv_assert
3646
3647 Check that a hash is in an internally consistent state.
3648
3649 =cut
3650 */
3651
3652 #ifdef DEBUGGING
3653
3654 void
3655 Perl_hv_assert(pTHX_ HV *hv)
3656 {
3657     dVAR;
3658     HE* entry;
3659     int withflags = 0;
3660     int placeholders = 0;
3661     int real = 0;
3662     int bad = 0;
3663     const I32 riter = HvRITER_get(hv);
3664     HE *eiter = HvEITER_get(hv);
3665
3666     PERL_ARGS_ASSERT_HV_ASSERT;
3667
3668     (void)hv_iterinit(hv);
3669
3670     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3671         /* sanity check the values */
3672         if (HeVAL(entry) == &PL_sv_placeholder)
3673             placeholders++;
3674         else
3675             real++;
3676         /* sanity check the keys */
3677         if (HeSVKEY(entry)) {
3678             NOOP;   /* Don't know what to check on SV keys.  */
3679         } else if (HeKUTF8(entry)) {
3680             withflags++;
3681             if (HeKWASUTF8(entry)) {
3682                 PerlIO_printf(Perl_debug_log,
3683                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3684                             (int) HeKLEN(entry),  HeKEY(entry));
3685                 bad = 1;
3686             }
3687         } else if (HeKWASUTF8(entry))
3688             withflags++;
3689     }
3690     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3691         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3692         const int nhashkeys = HvUSEDKEYS(hv);
3693         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3694
3695         if (nhashkeys != real) {
3696             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3697             bad = 1;
3698         }
3699         if (nhashplaceholders != placeholders) {
3700             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3701             bad = 1;
3702         }
3703     }
3704     if (withflags && ! HvHASKFLAGS(hv)) {
3705         PerlIO_printf(Perl_debug_log,
3706                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3707                     withflags);
3708         bad = 1;
3709     }
3710     if (bad) {
3711         sv_dump(MUTABLE_SV(hv));
3712     }
3713     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3714     HvEITER_set(hv, eiter);
3715 }
3716
3717 #endif
3718
3719 /*
3720  * Local variables:
3721  * c-indentation-style: bsd
3722  * c-basic-offset: 4
3723  * indent-tabs-mode: nil
3724  * End:
3725  *
3726  * ex: set ts=8 sts=4 sw=4 et:
3727  */