This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Note that certain flags are documented
[perl5.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 hv_copy_hints_hv
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 this_name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2400                 HEK **hekp = this_name + (
2401                     iter->xhv_name_count < 0
2402                      ? -iter->xhv_name_count
2403                      :  iter->xhv_name_count
2404                    );
2405                 while(hekp-- > this_name+1)
2406                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2407                 /* The first elem may be null. */
2408                 if(*this_name) unshare_hek_or_pvn(*this_name, 0, 0, 0);
2409                 Safefree(this_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 =for apidoc Amnh||HV_ITERNEXT_WANTPLACEHOLDERS
2676
2677 =cut
2678 */
2679
2680 HE *
2681 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2682 {
2683     dVAR;
2684     XPVHV* xhv;
2685     HE *entry;
2686     HE *oldentry;
2687     MAGIC* mg;
2688     struct xpvhv_aux *iter;
2689
2690     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2691
2692     xhv = (XPVHV*)SvANY(hv);
2693
2694     if (!SvOOK(hv)) {
2695         /* Too many things (well, pp_each at least) merrily assume that you can
2696            call hv_iternext without calling hv_iterinit, so we'll have to deal
2697            with it.  */
2698         hv_iterinit(hv);
2699     }
2700     iter = HvAUX(hv);
2701
2702     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2703     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2704         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2705             SV * const key = sv_newmortal();
2706             if (entry) {
2707                 sv_setsv(key, HeSVKEY_force(entry));
2708                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2709                 HeSVKEY_set(entry, NULL);
2710             }
2711             else {
2712                 char *k;
2713                 HEK *hek;
2714
2715                 /* one HE per MAGICAL hash */
2716                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2717                 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2718                 Zero(entry, 1, HE);
2719                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2720                 hek = (HEK*)k;
2721                 HeKEY_hek(entry) = hek;
2722                 HeKLEN(entry) = HEf_SVKEY;
2723             }
2724             magic_nextpack(MUTABLE_SV(hv),mg,key);
2725             if (SvOK(key)) {
2726                 /* force key to stay around until next time */
2727                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2728                 return entry;               /* beware, hent_val is not set */
2729             }
2730             SvREFCNT_dec(HeVAL(entry));
2731             Safefree(HeKEY_hek(entry));
2732             del_HE(entry);
2733             iter = HvAUX(hv); /* may been realloced */
2734             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2735             HvLAZYDEL_off(hv);
2736             return NULL;
2737         }
2738     }
2739 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2740     if (!entry && SvRMAGICAL((const SV *)hv)
2741         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2742         prime_env_iter();
2743 #ifdef VMS
2744         /* The prime_env_iter() on VMS just loaded up new hash values
2745          * so the iteration count needs to be reset back to the beginning
2746          */
2747         hv_iterinit(hv);
2748         iter = HvAUX(hv);
2749         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2750 #endif
2751     }
2752 #endif
2753
2754     /* hv_iterinit now ensures this.  */
2755     assert (HvARRAY(hv));
2756
2757     /* At start of hash, entry is NULL.  */
2758     if (entry)
2759     {
2760         entry = HeNEXT(entry);
2761         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2762             /*
2763              * Skip past any placeholders -- don't want to include them in
2764              * any iteration.
2765              */
2766             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2767                 entry = HeNEXT(entry);
2768             }
2769         }
2770     }
2771
2772 #ifdef PERL_HASH_RANDOMIZE_KEYS
2773     if (iter->xhv_last_rand != iter->xhv_rand) {
2774         if (iter->xhv_riter != -1) {
2775             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2776                              "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2777                              pTHX__FORMAT
2778                              pTHX__VALUE);
2779         }
2780         iter = HvAUX(hv); /* may been realloced */
2781         iter->xhv_last_rand = iter->xhv_rand;
2782     }
2783 #endif
2784
2785     /* Skip the entire loop if the hash is empty.   */
2786     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2787         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2788         while (!entry) {
2789             /* OK. Come to the end of the current list.  Grab the next one.  */
2790
2791             iter->xhv_riter++; /* HvRITER(hv)++ */
2792             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2793                 /* There is no next one.  End of the hash.  */
2794                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2795 #ifdef PERL_HASH_RANDOMIZE_KEYS
2796                 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2797 #endif
2798                 break;
2799             }
2800             entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2801
2802             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2803                 /* If we have an entry, but it's a placeholder, don't count it.
2804                    Try the next.  */
2805                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2806                     entry = HeNEXT(entry);
2807             }
2808             /* Will loop again if this linked list starts NULL
2809                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2810                or if we run through it and find only placeholders.  */
2811         }
2812     }
2813     else {
2814         iter->xhv_riter = -1;
2815 #ifdef PERL_HASH_RANDOMIZE_KEYS
2816         iter->xhv_last_rand = iter->xhv_rand;
2817 #endif
2818     }
2819
2820     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2821         HvLAZYDEL_off(hv);
2822         hv_free_ent(hv, oldentry);
2823     }
2824
2825     iter = HvAUX(hv); /* may been realloced */
2826     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2827     return entry;
2828 }
2829
2830 /*
2831 =for apidoc hv_iterkey
2832
2833 Returns the key from the current position of the hash iterator.  See
2834 C<L</hv_iterinit>>.
2835
2836 =cut
2837 */
2838
2839 char *
2840 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2841 {
2842     PERL_ARGS_ASSERT_HV_ITERKEY;
2843
2844     if (HeKLEN(entry) == HEf_SVKEY) {
2845         STRLEN len;
2846         char * const p = SvPV(HeKEY_sv(entry), len);
2847         *retlen = len;
2848         return p;
2849     }
2850     else {
2851         *retlen = HeKLEN(entry);
2852         return HeKEY(entry);
2853     }
2854 }
2855
2856 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2857 /*
2858 =for apidoc hv_iterkeysv
2859
2860 Returns the key as an C<SV*> from the current position of the hash
2861 iterator.  The return value will always be a mortal copy of the key.  Also
2862 see C<L</hv_iterinit>>.
2863
2864 =cut
2865 */
2866
2867 SV *
2868 Perl_hv_iterkeysv(pTHX_ HE *entry)
2869 {
2870     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2871
2872     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2873 }
2874
2875 /*
2876 =for apidoc hv_iterval
2877
2878 Returns the value from the current position of the hash iterator.  See
2879 C<L</hv_iterkey>>.
2880
2881 =cut
2882 */
2883
2884 SV *
2885 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2886 {
2887     PERL_ARGS_ASSERT_HV_ITERVAL;
2888
2889     if (SvRMAGICAL(hv)) {
2890         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2891             SV* const sv = sv_newmortal();
2892             if (HeKLEN(entry) == HEf_SVKEY)
2893                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2894             else
2895                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2896             return sv;
2897         }
2898     }
2899     return HeVAL(entry);
2900 }
2901
2902 /*
2903 =for apidoc hv_iternextsv
2904
2905 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2906 operation.
2907
2908 =cut
2909 */
2910
2911 SV *
2912 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2913 {
2914     HE * const he = hv_iternext_flags(hv, 0);
2915
2916     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2917
2918     if (!he)
2919         return NULL;
2920     *key = hv_iterkey(he, retlen);
2921     return hv_iterval(hv, he);
2922 }
2923
2924 /*
2925
2926 Now a macro in hv.h
2927
2928 =for apidoc hv_magic
2929
2930 Adds magic to a hash.  See C<L</sv_magic>>.
2931
2932 =cut
2933 */
2934
2935 /* possibly free a shared string if no one has access to it
2936  * len and hash must both be valid for str.
2937  */
2938 void
2939 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2940 {
2941     unshare_hek_or_pvn (NULL, str, len, hash);
2942 }
2943
2944
2945 void
2946 Perl_unshare_hek(pTHX_ HEK *hek)
2947 {
2948     assert(hek);
2949     unshare_hek_or_pvn(hek, NULL, 0, 0);
2950 }
2951
2952 /* possibly free a shared string if no one has access to it
2953    hek if non-NULL takes priority over the other 3, else str, len and hash
2954    are used.  If so, len and hash must both be valid for str.
2955  */
2956 STATIC void
2957 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2958 {
2959     XPVHV* xhv;
2960     HE *entry;
2961     HE **oentry;
2962     bool is_utf8 = FALSE;
2963     int k_flags = 0;
2964     const char * const save = str;
2965     struct shared_he *he = NULL;
2966
2967     if (hek) {
2968         /* Find the shared he which is just before us in memory.  */
2969         he = (struct shared_he *)(((char *)hek)
2970                                   - STRUCT_OFFSET(struct shared_he,
2971                                                   shared_he_hek));
2972
2973         /* Assert that the caller passed us a genuine (or at least consistent)
2974            shared hek  */
2975         assert (he->shared_he_he.hent_hek == hek);
2976
2977         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2978             --he->shared_he_he.he_valu.hent_refcount;
2979             return;
2980         }
2981
2982         hash = HEK_HASH(hek);
2983     } else if (len < 0) {
2984         STRLEN tmplen = -len;
2985         is_utf8 = TRUE;
2986         /* See the note in hv_fetch(). --jhi */
2987         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2988         len = tmplen;
2989         if (is_utf8)
2990             k_flags = HVhek_UTF8;
2991         if (str != save)
2992             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2993     }
2994
2995     /* what follows was the moral equivalent of:
2996     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2997         if (--*Svp == NULL)
2998             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2999     } */
3000     xhv = (XPVHV*)SvANY(PL_strtab);
3001     /* assert(xhv_array != 0) */
3002     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
3003     if (he) {
3004         const HE *const he_he = &(he->shared_he_he);
3005         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
3006             if (entry == he_he)
3007                 break;
3008         }
3009     } else {
3010         const int flags_masked = k_flags & HVhek_MASK;
3011         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
3012             if (HeHASH(entry) != hash)          /* strings can't be equal */
3013                 continue;
3014             if (HeKLEN(entry) != len)
3015                 continue;
3016             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
3017                 continue;
3018             if (HeKFLAGS(entry) != flags_masked)
3019                 continue;
3020             break;
3021         }
3022     }
3023
3024     if (entry) {
3025         if (--entry->he_valu.hent_refcount == 0) {
3026             *oentry = HeNEXT(entry);
3027             Safefree(entry);
3028             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
3029         }
3030     }
3031
3032     if (!entry)
3033         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
3034                          "Attempt to free nonexistent shared string '%s'%s"
3035                          pTHX__FORMAT,
3036                          hek ? HEK_KEY(hek) : str,
3037                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
3038     if (k_flags & HVhek_FREEKEY)
3039         Safefree(str);
3040 }
3041
3042 /* get a (constant) string ptr from the global string table
3043  * string will get added if it is not already there.
3044  * len and hash must both be valid for str.
3045  */
3046 HEK *
3047 Perl_share_hek(pTHX_ const char *str, SSize_t len, U32 hash)
3048 {
3049     bool is_utf8 = FALSE;
3050     int flags = 0;
3051     const char * const save = str;
3052
3053     PERL_ARGS_ASSERT_SHARE_HEK;
3054
3055     if (len < 0) {
3056       STRLEN tmplen = -len;
3057       is_utf8 = TRUE;
3058       /* See the note in hv_fetch(). --jhi */
3059       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
3060       len = tmplen;
3061       /* If we were able to downgrade here, then than means that we were passed
3062          in a key which only had chars 0-255, but was utf8 encoded.  */
3063       if (is_utf8)
3064           flags = HVhek_UTF8;
3065       /* If we found we were able to downgrade the string to bytes, then
3066          we should flag that it needs upgrading on keys or each.  Also flag
3067          that we need share_hek_flags to free the string.  */
3068       if (str != save) {
3069           dVAR;
3070           PERL_HASH(hash, str, len);
3071           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
3072       }
3073     }
3074
3075     return share_hek_flags (str, len, hash, flags);
3076 }
3077
3078 STATIC HEK *
3079 S_share_hek_flags(pTHX_ const char *str, STRLEN len, U32 hash, int flags)
3080 {
3081     HE *entry;
3082     const int flags_masked = flags & HVhek_MASK;
3083     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
3084     XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
3085
3086     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
3087
3088     if (UNLIKELY(len > (STRLEN) I32_MAX)) {
3089         Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes");
3090     }
3091
3092     /* what follows is the moral equivalent of:
3093
3094     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
3095         hv_store(PL_strtab, str, len, NULL, hash);
3096
3097         Can't rehash the shared string table, so not sure if it's worth
3098         counting the number of entries in the linked list
3099     */
3100
3101     /* assert(xhv_array != 0) */
3102     entry = (HvARRAY(PL_strtab))[hindex];
3103     for (;entry; entry = HeNEXT(entry)) {
3104         if (HeHASH(entry) != hash)              /* strings can't be equal */
3105             continue;
3106         if (HeKLEN(entry) != (SSize_t) len)
3107             continue;
3108         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
3109             continue;
3110         if (HeKFLAGS(entry) != flags_masked)
3111             continue;
3112         break;
3113     }
3114
3115     if (!entry) {
3116         /* What used to be head of the list.
3117            If this is NULL, then we're the first entry for this slot, which
3118            means we need to increate fill.  */
3119         struct shared_he *new_entry;
3120         HEK *hek;
3121         char *k;
3122         HE **const head = &HvARRAY(PL_strtab)[hindex];
3123         HE *const next = *head;
3124
3125         /* We don't actually store a HE from the arena and a regular HEK.
3126            Instead we allocate one chunk of memory big enough for both,
3127            and put the HEK straight after the HE. This way we can find the
3128            HE directly from the HEK.
3129         */
3130
3131         Newx(k, STRUCT_OFFSET(struct shared_he,
3132                                 shared_he_hek.hek_key[0]) + len + 2, char);
3133         new_entry = (struct shared_he *)k;
3134         entry = &(new_entry->shared_he_he);
3135         hek = &(new_entry->shared_he_hek);
3136
3137         Copy(str, HEK_KEY(hek), len, char);
3138         HEK_KEY(hek)[len] = 0;
3139         HEK_LEN(hek) = len;
3140         HEK_HASH(hek) = hash;
3141         HEK_FLAGS(hek) = (unsigned char)flags_masked;
3142
3143         /* Still "point" to the HEK, so that other code need not know what
3144            we're up to.  */
3145         HeKEY_hek(entry) = hek;
3146         entry->he_valu.hent_refcount = 0;
3147         HeNEXT(entry) = next;
3148         *head = entry;
3149
3150         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
3151         if (!next) {                    /* initial entry? */
3152         } else if ( DO_HSPLIT(xhv) ) {
3153             const STRLEN oldsize = xhv->xhv_max + 1;
3154             hsplit(PL_strtab, oldsize, oldsize * 2);
3155         }
3156     }
3157
3158     ++entry->he_valu.hent_refcount;
3159
3160     if (flags & HVhek_FREEKEY)
3161         Safefree(str);
3162
3163     return HeKEY_hek(entry);
3164 }
3165
3166 SSize_t *
3167 Perl_hv_placeholders_p(pTHX_ HV *hv)
3168 {
3169     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3170
3171     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
3172
3173     if (!mg) {
3174         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
3175
3176         if (!mg) {
3177             Perl_die(aTHX_ "panic: hv_placeholders_p");
3178         }
3179     }
3180     return &(mg->mg_len);
3181 }
3182
3183
3184 I32
3185 Perl_hv_placeholders_get(pTHX_ const HV *hv)
3186 {
3187     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3188
3189     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3190     PERL_UNUSED_CONTEXT;
3191
3192     return mg ? mg->mg_len : 0;
3193 }
3194
3195 void
3196 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3197 {
3198     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3199
3200     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3201
3202     if (mg) {
3203         mg->mg_len = ph;
3204     } else if (ph) {
3205         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3206             Perl_die(aTHX_ "panic: hv_placeholders_set");
3207     }
3208     /* else we don't need to add magic to record 0 placeholders.  */
3209 }
3210
3211 STATIC SV *
3212 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3213 {
3214     dVAR;
3215     SV *value;
3216
3217     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3218
3219     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3220     case HVrhek_undef:
3221         value = newSV(0);
3222         break;
3223     case HVrhek_delete:
3224         value = &PL_sv_placeholder;
3225         break;
3226     case HVrhek_IV:
3227         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3228         break;
3229     case HVrhek_UV:
3230         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3231         break;
3232     case HVrhek_PV:
3233     case HVrhek_PV_UTF8:
3234         /* Create a string SV that directly points to the bytes in our
3235            structure.  */
3236         value = newSV_type(SVt_PV);
3237         SvPV_set(value, (char *) he->refcounted_he_data + 1);
3238         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3239         /* This stops anything trying to free it  */
3240         SvLEN_set(value, 0);
3241         SvPOK_on(value);
3242         SvREADONLY_on(value);
3243         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3244             SvUTF8_on(value);
3245         break;
3246     default:
3247         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf,
3248                    (UV)he->refcounted_he_data[0]);
3249     }
3250     return value;
3251 }
3252
3253 /*
3254 =for apidoc refcounted_he_chain_2hv
3255
3256 Generates and returns a C<HV *> representing the content of a
3257 C<refcounted_he> chain.
3258 C<flags> is currently unused and must be zero.
3259
3260 =cut
3261 */
3262 HV *
3263 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3264 {
3265     dVAR;
3266     HV *hv;
3267     U32 placeholders, max;
3268
3269     if (flags)
3270         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf,
3271             (UV)flags);
3272
3273     /* We could chase the chain once to get an idea of the number of keys,
3274        and call ksplit.  But for now we'll make a potentially inefficient
3275        hash with only 8 entries in its array.  */
3276     hv = newHV();
3277     max = HvMAX(hv);
3278     if (!HvARRAY(hv)) {
3279         char *array;
3280         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3281         HvARRAY(hv) = (HE**)array;
3282     }
3283
3284     placeholders = 0;
3285     while (chain) {
3286 #ifdef USE_ITHREADS
3287         U32 hash = chain->refcounted_he_hash;
3288 #else
3289         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3290 #endif
3291         HE **oentry = &((HvARRAY(hv))[hash & max]);
3292         HE *entry = *oentry;
3293         SV *value;
3294
3295         for (; entry; entry = HeNEXT(entry)) {
3296             if (HeHASH(entry) == hash) {
3297                 /* We might have a duplicate key here.  If so, entry is older
3298                    than the key we've already put in the hash, so if they are
3299                    the same, skip adding entry.  */
3300 #ifdef USE_ITHREADS
3301                 const STRLEN klen = HeKLEN(entry);
3302                 const char *const key = HeKEY(entry);
3303                 if (klen == chain->refcounted_he_keylen
3304                     && (!!HeKUTF8(entry)
3305                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3306                     && memEQ(key, REF_HE_KEY(chain), klen))
3307                     goto next_please;
3308 #else
3309                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3310                     goto next_please;
3311                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3312                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3313                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3314                              HeKLEN(entry)))
3315                     goto next_please;
3316 #endif
3317             }
3318         }
3319         assert (!entry);
3320         entry = new_HE();
3321
3322 #ifdef USE_ITHREADS
3323         HeKEY_hek(entry)
3324             = share_hek_flags(REF_HE_KEY(chain),
3325                               chain->refcounted_he_keylen,
3326                               chain->refcounted_he_hash,
3327                               (chain->refcounted_he_data[0]
3328                                & (HVhek_UTF8|HVhek_WASUTF8)));
3329 #else
3330         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3331 #endif
3332         value = refcounted_he_value(chain);
3333         if (value == &PL_sv_placeholder)
3334             placeholders++;
3335         HeVAL(entry) = value;
3336
3337         /* Link it into the chain.  */
3338         HeNEXT(entry) = *oentry;
3339         *oentry = entry;
3340
3341         HvTOTALKEYS(hv)++;
3342
3343     next_please:
3344         chain = chain->refcounted_he_next;
3345     }
3346
3347     if (placeholders) {
3348         clear_placeholders(hv, placeholders);
3349         HvTOTALKEYS(hv) -= placeholders;
3350     }
3351
3352     /* We could check in the loop to see if we encounter any keys with key
3353        flags, but it's probably not worth it, as this per-hash flag is only
3354        really meant as an optimisation for things like Storable.  */
3355     HvHASKFLAGS_on(hv);
3356     DEBUG_A(Perl_hv_assert(aTHX_ hv));
3357
3358     return hv;
3359 }
3360
3361 /*
3362 =for apidoc refcounted_he_fetch_pvn
3363
3364 Search along a C<refcounted_he> chain for an entry with the key specified
3365 by C<keypv> and C<keylen>.  If C<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3366 bit set, the key octets are interpreted as UTF-8, otherwise they
3367 are interpreted as Latin-1.  C<hash> is a precomputed hash of the key
3368 string, or zero if it has not been precomputed.  Returns a mortal scalar
3369 representing the value associated with the key, or C<&PL_sv_placeholder>
3370 if there is no value associated with the key.
3371
3372 =cut
3373 */
3374
3375 SV *
3376 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3377                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3378 {
3379     dVAR;
3380     U8 utf8_flag;
3381     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3382
3383     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3384         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf,
3385             (UV)flags);
3386     if (!chain)
3387         goto ret;
3388     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3389         /* For searching purposes, canonicalise to Latin-1 where possible. */
3390         const char *keyend = keypv + keylen, *p;
3391         STRLEN nonascii_count = 0;
3392         for (p = keypv; p != keyend; p++) {
3393             if (! UTF8_IS_INVARIANT(*p)) {
3394                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3395                     goto canonicalised_key;
3396                 }
3397                 nonascii_count++;
3398                 p++;
3399             }
3400         }
3401         if (nonascii_count) {
3402             char *q;
3403             const char *p = keypv, *keyend = keypv + keylen;
3404             keylen -= nonascii_count;
3405             Newx(q, keylen, char);
3406             SAVEFREEPV(q);
3407             keypv = q;
3408             for (; p != keyend; p++, q++) {
3409                 U8 c = (U8)*p;
3410                 if (UTF8_IS_INVARIANT(c)) {
3411                     *q = (char) c;
3412                 }
3413                 else {
3414                     p++;
3415                     *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3416                 }
3417             }
3418         }
3419         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3420         canonicalised_key: ;
3421     }
3422     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3423     if (!hash)
3424         PERL_HASH(hash, keypv, keylen);
3425
3426     for (; chain; chain = chain->refcounted_he_next) {
3427         if (
3428 #ifdef USE_ITHREADS
3429             hash == chain->refcounted_he_hash &&
3430             keylen == chain->refcounted_he_keylen &&
3431             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3432             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3433 #else
3434             hash == HEK_HASH(chain->refcounted_he_hek) &&
3435             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3436             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3437             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3438 #endif
3439         ) {
3440             if (flags & REFCOUNTED_HE_EXISTS)
3441                 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3442                     == HVrhek_delete
3443                     ? NULL : &PL_sv_yes;
3444             return sv_2mortal(refcounted_he_value(chain));
3445         }
3446     }
3447   ret:
3448     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3449 }
3450
3451 /*
3452 =for apidoc refcounted_he_fetch_pv
3453
3454 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3455 instead of a string/length pair.
3456
3457 =cut
3458 */
3459
3460 SV *
3461 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3462                          const char *key, U32 hash, U32 flags)
3463 {
3464     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3465     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3466 }
3467
3468 /*
3469 =for apidoc refcounted_he_fetch_sv
3470
3471 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3472 string/length pair.
3473
3474 =cut
3475 */
3476
3477 SV *
3478 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3479                          SV *key, U32 hash, U32 flags)
3480 {
3481     const char *keypv;
3482     STRLEN keylen;
3483     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3484     if (flags & REFCOUNTED_HE_KEY_UTF8)
3485         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf,
3486             (UV)flags);
3487     keypv = SvPV_const(key, keylen);
3488     if (SvUTF8(key))
3489         flags |= REFCOUNTED_HE_KEY_UTF8;
3490     if (!hash && SvIsCOW_shared_hash(key))
3491         hash = SvSHARED_HASH(key);
3492     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3493 }
3494
3495 /*
3496 =for apidoc refcounted_he_new_pvn
3497
3498 Creates a new C<refcounted_he>.  This consists of a single key/value
3499 pair and a reference to an existing C<refcounted_he> chain (which may
3500 be empty), and thus forms a longer chain.  When using the longer chain,
3501 the new key/value pair takes precedence over any entry for the same key
3502 further along the chain.
3503
3504 The new key is specified by C<keypv> and C<keylen>.  If C<flags> has
3505 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3506 as UTF-8, otherwise they are interpreted as Latin-1.  C<hash> is
3507 a precomputed hash of the key string, or zero if it has not been
3508 precomputed.
3509
3510 C<value> is the scalar value to store for this key.  C<value> is copied
3511 by this function, which thus does not take ownership of any reference
3512 to it, and later changes to the scalar will not be reflected in the
3513 value visible in the C<refcounted_he>.  Complex types of scalar will not
3514 be stored with referential integrity, but will be coerced to strings.
3515 C<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3516 value is to be associated with the key; this, as with any non-null value,
3517 takes precedence over the existence of a value for the key further along
3518 the chain.
3519
3520 C<parent> points to the rest of the C<refcounted_he> chain to be
3521 attached to the new C<refcounted_he>.  This function takes ownership
3522 of one reference to C<parent>, and returns one reference to the new
3523 C<refcounted_he>.
3524
3525 =cut
3526 */
3527
3528 struct refcounted_he *
3529 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3530         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3531 {
3532     dVAR;
3533     STRLEN value_len = 0;
3534     const char *value_p = NULL;
3535     bool is_pv;
3536     char value_type;
3537     char hekflags;
3538     STRLEN key_offset = 1;
3539     struct refcounted_he *he;
3540     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3541
3542     if (!value || value == &PL_sv_placeholder) {
3543         value_type = HVrhek_delete;
3544     } else if (SvPOK(value)) {
3545         value_type = HVrhek_PV;
3546     } else if (SvIOK(value)) {
3547         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3548     } else if (!SvOK(value)) {
3549         value_type = HVrhek_undef;
3550     } else {
3551         value_type = HVrhek_PV;
3552     }
3553     is_pv = value_type == HVrhek_PV;
3554     if (is_pv) {
3555         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3556            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3557         value_p = SvPV_const(value, value_len);
3558         if (SvUTF8(value))
3559             value_type = HVrhek_PV_UTF8;
3560         key_offset = value_len + 2;
3561     }
3562     hekflags = value_type;
3563
3564     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3565         /* Canonicalise to Latin-1 where possible. */
3566         const char *keyend = keypv + keylen, *p;
3567         STRLEN nonascii_count = 0;
3568         for (p = keypv; p != keyend; p++) {
3569             if (! UTF8_IS_INVARIANT(*p)) {
3570                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3571                     goto canonicalised_key;
3572                 }
3573                 nonascii_count++;
3574                 p++;
3575             }
3576         }
3577         if (nonascii_count) {
3578             char *q;
3579             const char *p = keypv, *keyend = keypv + keylen;
3580             keylen -= nonascii_count;
3581             Newx(q, keylen, char);
3582             SAVEFREEPV(q);
3583             keypv = q;
3584             for (; p != keyend; p++, q++) {
3585                 U8 c = (U8)*p;
3586                 if (UTF8_IS_INVARIANT(c)) {
3587                     *q = (char) c;
3588                 }
3589                 else {
3590                     p++;
3591                     *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3592                 }
3593             }
3594         }
3595         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3596         canonicalised_key: ;
3597     }
3598     if (flags & REFCOUNTED_HE_KEY_UTF8)
3599         hekflags |= HVhek_UTF8;
3600     if (!hash)
3601         PERL_HASH(hash, keypv, keylen);
3602
3603 #ifdef USE_ITHREADS
3604     he = (struct refcounted_he*)
3605         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3606                              + keylen
3607                              + key_offset);
3608 #else
3609     he = (struct refcounted_he*)
3610         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3611                              + key_offset);
3612 #endif
3613
3614     he->refcounted_he_next = parent;
3615
3616     if (is_pv) {
3617         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3618         he->refcounted_he_val.refcounted_he_u_len = value_len;
3619     } else if (value_type == HVrhek_IV) {
3620         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3621     } else if (value_type == HVrhek_UV) {
3622         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3623     }
3624
3625 #ifdef USE_ITHREADS
3626     he->refcounted_he_hash = hash;
3627     he->refcounted_he_keylen = keylen;
3628     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3629 #else
3630     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3631 #endif
3632
3633     he->refcounted_he_data[0] = hekflags;
3634     he->refcounted_he_refcnt = 1;
3635
3636     return he;
3637 }
3638
3639 /*
3640 =for apidoc refcounted_he_new_pv
3641
3642 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3643 of a string/length pair.
3644
3645 =cut
3646 */
3647
3648 struct refcounted_he *
3649 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3650         const char *key, U32 hash, SV *value, U32 flags)
3651 {
3652     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3653     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3654 }
3655
3656 /*
3657 =for apidoc refcounted_he_new_sv
3658
3659 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3660 string/length pair.
3661
3662 =cut
3663 */
3664
3665 struct refcounted_he *
3666 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3667         SV *key, U32 hash, SV *value, U32 flags)
3668 {
3669     const char *keypv;
3670     STRLEN keylen;
3671     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3672     if (flags & REFCOUNTED_HE_KEY_UTF8)
3673         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf,
3674             (UV)flags);
3675     keypv = SvPV_const(key, keylen);
3676     if (SvUTF8(key))
3677         flags |= REFCOUNTED_HE_KEY_UTF8;
3678     if (!hash && SvIsCOW_shared_hash(key))
3679         hash = SvSHARED_HASH(key);
3680     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3681 }
3682
3683 /*
3684 =for apidoc refcounted_he_free
3685
3686 Decrements the reference count of a C<refcounted_he> by one.  If the
3687 reference count reaches zero the structure's memory is freed, which
3688 (recursively) causes a reduction of its parent C<refcounted_he>'s
3689 reference count.  It is safe to pass a null pointer to this function:
3690 no action occurs in this case.
3691
3692 =cut
3693 */
3694
3695 void
3696 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3697 #ifdef USE_ITHREADS
3698     dVAR;
3699 #endif
3700     PERL_UNUSED_CONTEXT;
3701
3702     while (he) {
3703         struct refcounted_he *copy;
3704         U32 new_count;
3705
3706         HINTS_REFCNT_LOCK;
3707         new_count = --he->refcounted_he_refcnt;
3708         HINTS_REFCNT_UNLOCK;
3709         
3710         if (new_count) {
3711             return;
3712         }
3713
3714 #ifndef USE_ITHREADS
3715         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3716 #endif
3717         copy = he;
3718         he = he->refcounted_he_next;
3719         PerlMemShared_free(copy);
3720     }
3721 }
3722
3723 /*
3724 =for apidoc refcounted_he_inc
3725
3726 Increment the reference count of a C<refcounted_he>.  The pointer to the
3727 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3728 to this function: no action occurs and a null pointer is returned.
3729
3730 =cut
3731 */
3732
3733 struct refcounted_he *
3734 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3735 {
3736 #ifdef USE_ITHREADS
3737     dVAR;
3738 #endif
3739     PERL_UNUSED_CONTEXT;
3740     if (he) {
3741         HINTS_REFCNT_LOCK;
3742         he->refcounted_he_refcnt++;
3743         HINTS_REFCNT_UNLOCK;
3744     }
3745     return he;
3746 }
3747
3748 /*
3749 =for apidoc cop_fetch_label
3750
3751 Returns the label attached to a cop, and stores its length in bytes into
3752 C<*len>.
3753 Upon return, C<*flags> will be set to either C<SVf_UTF8> or 0.
3754
3755 Alternatively, use the macro L</C<CopLABEL_len_flags>>;
3756 or if you don't need to know if the label is UTF-8 or not, the macro
3757 L</C<CopLABEL_len>>;
3758 or if you additionally dont need to know the length, L</C<CopLABEL>>.
3759
3760 =cut
3761 */
3762
3763 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3764    the linked list.  */
3765 const char *
3766 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3767     struct refcounted_he *const chain = cop->cop_hints_hash;
3768
3769     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3770     PERL_UNUSED_CONTEXT;
3771
3772     if (!chain)
3773         return NULL;
3774 #ifdef USE_ITHREADS
3775     if (chain->refcounted_he_keylen != 1)
3776         return NULL;
3777     if (*REF_HE_KEY(chain) != ':')
3778         return NULL;
3779 #else
3780     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3781         return NULL;
3782     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3783         return NULL;
3784 #endif
3785     /* Stop anyone trying to really mess us up by adding their own value for
3786        ':' into %^H  */
3787     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3788         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3789         return NULL;
3790
3791     if (len)
3792         *len = chain->refcounted_he_val.refcounted_he_u_len;
3793     if (flags) {
3794         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3795                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3796     }
3797     return chain->refcounted_he_data + 1;
3798 }
3799
3800 /*
3801 =for apidoc cop_store_label
3802
3803 Save a label into a C<cop_hints_hash>.
3804 You need to set flags to C<SVf_UTF8>
3805 for a UTF-8 label.  Any other flag is ignored.
3806
3807 =cut
3808 */
3809
3810 void
3811 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3812                      U32 flags)
3813 {
3814     SV *labelsv;
3815     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3816
3817     if (flags & ~(SVf_UTF8))
3818         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3819                    (UV)flags);
3820     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3821     if (flags & SVf_UTF8)
3822         SvUTF8_on(labelsv);
3823     cop->cop_hints_hash
3824         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3825 }
3826
3827 /*
3828 =for apidoc hv_assert
3829
3830 Check that a hash is in an internally consistent state.
3831
3832 =cut
3833 */
3834
3835 #ifdef DEBUGGING
3836
3837 void
3838 Perl_hv_assert(pTHX_ HV *hv)
3839 {
3840     dVAR;
3841     HE* entry;
3842     int withflags = 0;
3843     int placeholders = 0;
3844     int real = 0;
3845     int bad = 0;
3846     const I32 riter = HvRITER_get(hv);
3847     HE *eiter = HvEITER_get(hv);
3848
3849     PERL_ARGS_ASSERT_HV_ASSERT;
3850
3851     (void)hv_iterinit(hv);
3852
3853     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3854         /* sanity check the values */
3855         if (HeVAL(entry) == &PL_sv_placeholder)
3856             placeholders++;
3857         else
3858             real++;
3859         /* sanity check the keys */
3860         if (HeSVKEY(entry)) {
3861             NOOP;   /* Don't know what to check on SV keys.  */
3862         } else if (HeKUTF8(entry)) {
3863             withflags++;
3864             if (HeKWASUTF8(entry)) {
3865                 PerlIO_printf(Perl_debug_log,
3866                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3867                             (int) HeKLEN(entry),  HeKEY(entry));
3868                 bad = 1;
3869             }
3870         } else if (HeKWASUTF8(entry))
3871             withflags++;
3872     }
3873     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3874         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3875         const int nhashkeys = HvUSEDKEYS(hv);
3876         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3877
3878         if (nhashkeys != real) {
3879             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3880             bad = 1;
3881         }
3882         if (nhashplaceholders != placeholders) {
3883             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3884             bad = 1;
3885         }
3886     }
3887     if (withflags && ! HvHASKFLAGS(hv)) {
3888         PerlIO_printf(Perl_debug_log,
3889                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3890                     withflags);
3891         bad = 1;
3892     }
3893     if (bad) {
3894         sv_dump(MUTABLE_SV(hv));
3895     }
3896     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3897     HvEITER_set(hv, eiter);
3898 }
3899
3900 #endif
3901
3902 /*
3903  * ex: set ts=8 sts=4 sw=4 et:
3904  */