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