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