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