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