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