This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c7e1eb1edd7443b007cd486f97d769fd11d7c778
[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 If any destructors are triggered as a result, the hv itself may
1603 be freed.
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 If any destructors are triggered as a result, the hv itself may
1838 be freed.
1839
1840 See also L</hv_clear>.
1841
1842 =cut
1843 */
1844
1845 void
1846 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1847 {
1848     XPVHV* xhv;
1849     bool save;
1850
1851     if (!hv)
1852         return;
1853     save = !!SvREFCNT(hv);
1854     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1855     xhv = (XPVHV*)SvANY(hv);
1856
1857     /* The name must be deleted before the call to hfreeeeentries so that
1858        CVs are anonymised properly. But the effective name must be pre-
1859        served until after that call (and only deleted afterwards if the
1860        call originated from sv_clear). For stashes with one name that is
1861        both the canonical name and the effective name, hv_name_set has to
1862        allocate an array for storing the effective name. We can skip that
1863        during global destruction, as it does not matter where the CVs point
1864        if they will be freed anyway. */
1865     /* note that the code following prior to hfreeentries is duplicated
1866      * in sv_clear(), and changes here should be done there too */
1867     if (PL_phase != PERL_PHASE_DESTRUCT && HvNAME(hv)) {
1868         if (PL_stashcache) {
1869             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
1870                              HEKf"'\n", HEKfARG(HvNAME_HEK(hv))));
1871             (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
1872         }
1873         hv_name_set(hv, NULL, 0, 0);
1874     }
1875     if (save) {
1876         ENTER;
1877         SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1878     }
1879     hfreeentries(hv);
1880     if (SvOOK(hv)) {
1881       struct mro_meta *meta;
1882       const char *name;
1883
1884       if (HvENAME_get(hv)) {
1885         if (PL_phase != PERL_PHASE_DESTRUCT)
1886             mro_isa_changed_in(hv);
1887         if (PL_stashcache) {
1888             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
1889                              HEKf"'\n", HEKfARG(HvENAME_HEK(hv))));
1890             (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD);
1891         }
1892       }
1893
1894       /* If this call originated from sv_clear, then we must check for
1895        * effective names that need freeing, as well as the usual name. */
1896       name = HvNAME(hv);
1897       if (flags & HV_NAME_SETALL ? !!HvAUX(hv)->xhv_name_u.xhvnameu_name : !!name) {
1898         if (name && PL_stashcache) {
1899             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
1900                              HEKf"'\n", HEKfARG(HvNAME_HEK(hv))));
1901             (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
1902         }
1903         hv_name_set(hv, NULL, 0, flags);
1904       }
1905       if((meta = HvAUX(hv)->xhv_mro_meta)) {
1906         if (meta->mro_linear_all) {
1907             SvREFCNT_dec_NN(meta->mro_linear_all);
1908             /* mro_linear_current is just acting as a shortcut pointer,
1909                hence the else.  */
1910         }
1911         else
1912             /* Only the current MRO is stored, so this owns the data.
1913              */
1914             SvREFCNT_dec(meta->mro_linear_current);
1915         SvREFCNT_dec(meta->mro_nextmethod);
1916         SvREFCNT_dec(meta->isa);
1917         SvREFCNT_dec(meta->super);
1918         Safefree(meta);
1919         HvAUX(hv)->xhv_mro_meta = NULL;
1920       }
1921       if (!HvAUX(hv)->xhv_name_u.xhvnameu_name && ! HvAUX(hv)->xhv_backreferences)
1922         SvFLAGS(hv) &= ~SVf_OOK;
1923     }
1924     if (!SvOOK(hv)) {
1925         Safefree(HvARRAY(hv));
1926         xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX;        /* HvMAX(hv) = 7 (it's a normal hash) */
1927         HvARRAY(hv) = 0;
1928     }
1929     /* if we're freeing the HV, the SvMAGIC field has been reused for
1930      * other purposes, and so there can't be any placeholder magic */
1931     if (SvREFCNT(hv))
1932         HvPLACEHOLDERS_set(hv, 0);
1933
1934     if (SvRMAGICAL(hv))
1935         mg_clear(MUTABLE_SV(hv));
1936     if (save) LEAVE;
1937 }
1938
1939 /*
1940 =for apidoc hv_fill
1941
1942 Returns the number of hash buckets that
1943 happen to be in use.  This function is
1944 wrapped by the macro C<HvFILL>.
1945
1946 Previously this value was always stored in the HV structure, which created an
1947 overhead on every hash (and pretty much every object) for something that was
1948 rarely used.  Now we calculate it on demand the first
1949 time that it is needed, and cache it if that calculation
1950 is going to be costly to repeat.  The cached
1951 value is updated by insertions and deletions, but (currently) discarded if
1952 the hash is split.
1953
1954 =cut
1955 */
1956
1957 STRLEN
1958 Perl_hv_fill(pTHX_ HV *const hv)
1959 {
1960     STRLEN count = 0;
1961     HE **ents = HvARRAY(hv);
1962     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : NULL;
1963
1964     PERL_ARGS_ASSERT_HV_FILL;
1965
1966     /* No keys implies no buckets used.
1967        One key can only possibly mean one bucket used.  */
1968     if (HvTOTALKEYS(hv) < 2)
1969         return HvTOTALKEYS(hv);
1970
1971 #ifndef DEBUGGING
1972     if (aux && aux->xhv_fill_lazy)
1973         return aux->xhv_fill_lazy;
1974 #endif
1975
1976     if (ents) {
1977         HE *const *const last = ents + HvMAX(hv);
1978         count = last + 1 - ents;
1979
1980         do {
1981             if (!*ents)
1982                 --count;
1983         } while (++ents <= last);
1984     }
1985     if (aux) {
1986 #ifdef DEBUGGING
1987         if (aux->xhv_fill_lazy)
1988             assert(aux->xhv_fill_lazy == count);
1989 #endif
1990         aux->xhv_fill_lazy = count;
1991     } else if (HvMAX(hv) >= HV_FILL_THRESHOLD) {
1992         aux = hv_auxinit(hv);
1993         aux->xhv_fill_lazy = count;
1994     }        
1995     return count;
1996 }
1997
1998 /* hash a pointer to a U32 - Used in the hash traversal randomization
1999  * and bucket order randomization code
2000  *
2001  * this code was derived from Sereal, which was derived from autobox.
2002  */
2003
2004 PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
2005 #if PTRSIZE == 8
2006     /*
2007      * This is one of Thomas Wang's hash functions for 64-bit integers from:
2008      * http://www.concentric.net/~Ttwang/tech/inthash.htm
2009      */
2010     u = (~u) + (u << 18);
2011     u = u ^ (u >> 31);
2012     u = u * 21;
2013     u = u ^ (u >> 11);
2014     u = u + (u << 6);
2015     u = u ^ (u >> 22);
2016 #else
2017     /*
2018      * This is one of Bob Jenkins' hash functions for 32-bit integers
2019      * from: http://burtleburtle.net/bob/hash/integer.html
2020      */
2021     u = (u + 0x7ed55d16) + (u << 12);
2022     u = (u ^ 0xc761c23c) ^ (u >> 19);
2023     u = (u + 0x165667b1) + (u << 5);
2024     u = (u + 0xd3a2646c) ^ (u << 9);
2025     u = (u + 0xfd7046c5) + (u << 3);
2026     u = (u ^ 0xb55a4f09) ^ (u >> 16);
2027 #endif
2028     return (U32)u;
2029 }
2030
2031 static struct xpvhv_aux*
2032 S_hv_auxinit_internal(struct xpvhv_aux *iter) {
2033     PERL_ARGS_ASSERT_HV_AUXINIT_INTERNAL;
2034     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
2035     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
2036 #ifdef PERL_HASH_RANDOMIZE_KEYS
2037     iter->xhv_last_rand = iter->xhv_rand;
2038 #endif
2039     iter->xhv_fill_lazy = 0;
2040     iter->xhv_name_u.xhvnameu_name = 0;
2041     iter->xhv_name_count = 0;
2042     iter->xhv_backreferences = 0;
2043     iter->xhv_mro_meta = NULL;
2044     iter->xhv_aux_flags = 0;
2045     return iter;
2046 }
2047
2048
2049 static struct xpvhv_aux*
2050 S_hv_auxinit(pTHX_ HV *hv) {
2051     struct xpvhv_aux *iter;
2052     char *array;
2053
2054     PERL_ARGS_ASSERT_HV_AUXINIT;
2055
2056     if (!SvOOK(hv)) {
2057         if (!HvARRAY(hv)) {
2058             Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
2059                 + sizeof(struct xpvhv_aux), char);
2060         } else {
2061             array = (char *) HvARRAY(hv);
2062             Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
2063                   + sizeof(struct xpvhv_aux), char);
2064         }
2065         HvARRAY(hv) = (HE**)array;
2066         SvOOK_on(hv);
2067         iter = HvAUX(hv);
2068 #ifdef PERL_HASH_RANDOMIZE_KEYS
2069         if (PL_HASH_RAND_BITS_ENABLED) {
2070             /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
2071             if (PL_HASH_RAND_BITS_ENABLED == 1)
2072                 PL_hash_rand_bits += ptr_hash((PTRV)array);
2073             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
2074         }
2075         iter->xhv_rand = (U32)PL_hash_rand_bits;
2076 #endif
2077     } else {
2078         iter = HvAUX(hv);
2079     }
2080
2081     return hv_auxinit_internal(iter);
2082 }
2083
2084 /*
2085 =for apidoc hv_iterinit
2086
2087 Prepares a starting point to traverse a hash table.  Returns the number of
2088 keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>).  The return value is
2089 currently only meaningful for hashes without tie magic.
2090
2091 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
2092 hash buckets that happen to be in use.  If you still need that esoteric
2093 value, you can get it through the macro C<HvFILL(hv)>.
2094
2095
2096 =cut
2097 */
2098
2099 I32
2100 Perl_hv_iterinit(pTHX_ HV *hv)
2101 {
2102     PERL_ARGS_ASSERT_HV_ITERINIT;
2103
2104     if (SvOOK(hv)) {
2105         struct xpvhv_aux * iter = HvAUX(hv);
2106         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2107         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
2108             HvLAZYDEL_off(hv);
2109             hv_free_ent(hv, entry);
2110         }
2111         iter = HvAUX(hv); /* may have been reallocated */
2112         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
2113         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2114 #ifdef PERL_HASH_RANDOMIZE_KEYS
2115         iter->xhv_last_rand = iter->xhv_rand;
2116 #endif
2117     } else {
2118         hv_auxinit(hv);
2119     }
2120
2121     /* used to be xhv->xhv_fill before 5.004_65 */
2122     return HvTOTALKEYS(hv);
2123 }
2124
2125 I32 *
2126 Perl_hv_riter_p(pTHX_ HV *hv) {
2127     struct xpvhv_aux *iter;
2128
2129     PERL_ARGS_ASSERT_HV_RITER_P;
2130
2131     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2132     return &(iter->xhv_riter);
2133 }
2134
2135 HE **
2136 Perl_hv_eiter_p(pTHX_ HV *hv) {
2137     struct xpvhv_aux *iter;
2138
2139     PERL_ARGS_ASSERT_HV_EITER_P;
2140
2141     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2142     return &(iter->xhv_eiter);
2143 }
2144
2145 void
2146 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2147     struct xpvhv_aux *iter;
2148
2149     PERL_ARGS_ASSERT_HV_RITER_SET;
2150
2151     if (SvOOK(hv)) {
2152         iter = HvAUX(hv);
2153     } else {
2154         if (riter == -1)
2155             return;
2156
2157         iter = hv_auxinit(hv);
2158     }
2159     iter->xhv_riter = riter;
2160 }
2161
2162 void
2163 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2164     struct xpvhv_aux *iter;
2165
2166     PERL_ARGS_ASSERT_HV_RAND_SET;
2167
2168 #ifdef PERL_HASH_RANDOMIZE_KEYS
2169     if (SvOOK(hv)) {
2170         iter = HvAUX(hv);
2171     } else {
2172         iter = hv_auxinit(hv);
2173     }
2174     iter->xhv_rand = new_xhv_rand;
2175 #else
2176     Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2177 #endif
2178 }
2179
2180 void
2181 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2182     struct xpvhv_aux *iter;
2183
2184     PERL_ARGS_ASSERT_HV_EITER_SET;
2185
2186     if (SvOOK(hv)) {
2187         iter = HvAUX(hv);
2188     } else {
2189         /* 0 is the default so don't go malloc()ing a new structure just to
2190            hold 0.  */
2191         if (!eiter)
2192             return;
2193
2194         iter = hv_auxinit(hv);
2195     }
2196     iter->xhv_eiter = eiter;
2197 }
2198
2199 void
2200 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2201 {
2202     dVAR;
2203     struct xpvhv_aux *iter;
2204     U32 hash;
2205     HEK **spot;
2206
2207     PERL_ARGS_ASSERT_HV_NAME_SET;
2208
2209     if (len > I32_MAX)
2210         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2211
2212     if (SvOOK(hv)) {
2213         iter = HvAUX(hv);
2214         if (iter->xhv_name_u.xhvnameu_name) {
2215             if(iter->xhv_name_count) {
2216               if(flags & HV_NAME_SETALL) {
2217                 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2218                 HEK **hekp = name + (
2219                     iter->xhv_name_count < 0
2220                      ? -iter->xhv_name_count
2221                      :  iter->xhv_name_count
2222                    );
2223                 while(hekp-- > name+1) 
2224                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2225                 /* The first elem may be null. */
2226                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2227                 Safefree(name);
2228                 iter = HvAUX(hv); /* may been realloced */
2229                 spot = &iter->xhv_name_u.xhvnameu_name;
2230                 iter->xhv_name_count = 0;
2231               }
2232               else {
2233                 if(iter->xhv_name_count > 0) {
2234                     /* shift some things over */
2235                     Renew(
2236                      iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2237                     );
2238                     spot = iter->xhv_name_u.xhvnameu_names;
2239                     spot[iter->xhv_name_count] = spot[1];
2240                     spot[1] = spot[0];
2241                     iter->xhv_name_count = -(iter->xhv_name_count + 1);
2242                 }
2243                 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2244                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2245                 }
2246               }
2247             }
2248             else if (flags & HV_NAME_SETALL) {
2249                 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2250                 iter = HvAUX(hv); /* may been realloced */
2251                 spot = &iter->xhv_name_u.xhvnameu_name;
2252             }
2253             else {
2254                 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2255                 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2256                 iter->xhv_name_count = -2;
2257                 spot = iter->xhv_name_u.xhvnameu_names;
2258                 spot[1] = existing_name;
2259             }
2260         }
2261         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2262     } else {
2263         if (name == 0)
2264             return;
2265
2266         iter = hv_auxinit(hv);
2267         spot = &iter->xhv_name_u.xhvnameu_name;
2268     }
2269     PERL_HASH(hash, name, len);
2270     *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2271 }
2272
2273 /*
2274 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2275 and bytes checking.
2276 */
2277
2278 STATIC I32
2279 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2280     if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2281         if (flags & SVf_UTF8)
2282             return (bytes_cmp_utf8(
2283                         (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2284                         (const U8*)pv, pvlen) == 0);
2285         else
2286             return (bytes_cmp_utf8(
2287                         (const U8*)pv, pvlen,
2288                         (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2289     }
2290     else
2291         return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2292                     || memEQ(HEK_KEY(hek), pv, pvlen));
2293 }
2294
2295 /*
2296 =for apidoc hv_ename_add
2297
2298 Adds a name to a stash's internal list of effective names.  See
2299 C<L</hv_ename_delete>>.
2300
2301 This is called when a stash is assigned to a new location in the symbol
2302 table.
2303
2304 =cut
2305 */
2306
2307 void
2308 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2309 {
2310     dVAR;
2311     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2312     U32 hash;
2313
2314     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2315
2316     if (len > I32_MAX)
2317         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2318
2319     PERL_HASH(hash, name, len);
2320
2321     if (aux->xhv_name_count) {
2322         I32 count = aux->xhv_name_count;
2323         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0);
2324         HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count);
2325         while (hekp-- > xhv_name)
2326         {
2327             assert(*hekp);
2328             if (
2329                  (HEK_UTF8(*hekp) || (flags & SVf_UTF8)) 
2330                     ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2331                     : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2332                ) {
2333                 if (hekp == xhv_name && count < 0)
2334                     aux->xhv_name_count = -count;
2335                 return;
2336             }
2337         }
2338         if (count < 0) aux->xhv_name_count--, count = -count;
2339         else aux->xhv_name_count++;
2340         Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2341         (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2342     }
2343     else {
2344         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2345         if (
2346             existing_name && (
2347              (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2348                 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2349                 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2350             )
2351         ) return;
2352         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2353         aux->xhv_name_count = existing_name ? 2 : -2;
2354         *aux->xhv_name_u.xhvnameu_names = existing_name;
2355         (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2356     }
2357 }
2358
2359 /*
2360 =for apidoc hv_ename_delete
2361
2362 Removes a name from a stash's internal list of effective names.  If this is
2363 the name returned by C<HvENAME>, then another name in the list will take
2364 its place (C<HvENAME> will use it).
2365
2366 This is called when a stash is deleted from the symbol table.
2367
2368 =cut
2369 */
2370
2371 void
2372 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2373 {
2374     struct xpvhv_aux *aux;
2375
2376     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2377
2378     if (len > I32_MAX)
2379         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2380
2381     if (!SvOOK(hv)) return;
2382
2383     aux = HvAUX(hv);
2384     if (!aux->xhv_name_u.xhvnameu_name) return;
2385
2386     if (aux->xhv_name_count) {
2387         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2388         I32 const count = aux->xhv_name_count;
2389         HEK **victim = namep + (count < 0 ? -count : count);
2390         while (victim-- > namep + 1)
2391             if (
2392              (HEK_UTF8(*victim) || (flags & SVf_UTF8)) 
2393                 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2394                 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2395             ) {
2396                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2397                 aux = HvAUX(hv); /* may been realloced */
2398                 if (count < 0) ++aux->xhv_name_count;
2399                 else --aux->xhv_name_count;
2400                 if (
2401                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2402                  && !*namep
2403                 ) {  /* if there are none left */
2404                     Safefree(namep);
2405                     aux->xhv_name_u.xhvnameu_names = NULL;
2406                     aux->xhv_name_count = 0;
2407                 }
2408                 else {
2409                     /* Move the last one back to fill the empty slot. It
2410                        does not matter what order they are in. */
2411                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2412                 }
2413                 return;
2414             }
2415         if (
2416             count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8)) 
2417                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2418                 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2419         ) {
2420             aux->xhv_name_count = -count;
2421         }
2422     }
2423     else if(
2424         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) 
2425                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2426                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2427                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2428     ) {
2429         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2430         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2431         *aux->xhv_name_u.xhvnameu_names = namehek;
2432         aux->xhv_name_count = -1;
2433     }
2434 }
2435
2436 AV **
2437 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2438     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2439     /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
2440     {
2441         struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2442         return &(iter->xhv_backreferences);
2443     }
2444 }
2445
2446 void
2447 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2448     AV *av;
2449
2450     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2451
2452     if (!SvOOK(hv))
2453         return;
2454
2455     av = HvAUX(hv)->xhv_backreferences;
2456
2457     if (av) {
2458         HvAUX(hv)->xhv_backreferences = 0;
2459         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2460         if (SvTYPE(av) == SVt_PVAV)
2461             SvREFCNT_dec_NN(av);
2462     }
2463 }
2464
2465 /*
2466 hv_iternext is implemented as a macro in hv.h
2467
2468 =for apidoc hv_iternext
2469
2470 Returns entries from a hash iterator.  See C<L</hv_iterinit>>.
2471
2472 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2473 iterator currently points to, without losing your place or invalidating your
2474 iterator.  Note that in this case the current entry is deleted from the hash
2475 with your iterator holding the last reference to it.  Your iterator is flagged
2476 to free the entry on the next call to C<hv_iternext>, so you must not discard
2477 your iterator immediately else the entry will leak - call C<hv_iternext> to
2478 trigger the resource deallocation.
2479
2480 =for apidoc hv_iternext_flags
2481
2482 Returns entries from a hash iterator.  See C<L</hv_iterinit>> and
2483 C<L</hv_iternext>>.
2484 The C<flags> value will normally be zero; if C<HV_ITERNEXT_WANTPLACEHOLDERS> is
2485 set the placeholders keys (for restricted hashes) will be returned in addition
2486 to normal keys.  By default placeholders are automatically skipped over.
2487 Currently a placeholder is implemented with a value that is
2488 C<&PL_sv_placeholder>.  Note that the implementation of placeholders and
2489 restricted hashes may change, and the implementation currently is
2490 insufficiently abstracted for any change to be tidy.
2491
2492 =cut
2493 */
2494
2495 HE *
2496 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2497 {
2498     dVAR;
2499     XPVHV* xhv;
2500     HE *entry;
2501     HE *oldentry;
2502     MAGIC* mg;
2503     struct xpvhv_aux *iter;
2504
2505     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2506
2507     xhv = (XPVHV*)SvANY(hv);
2508
2509     if (!SvOOK(hv)) {
2510         /* Too many things (well, pp_each at least) merrily assume that you can
2511            call hv_iternext without calling hv_iterinit, so we'll have to deal
2512            with it.  */
2513         hv_iterinit(hv);
2514     }
2515     iter = HvAUX(hv);
2516
2517     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2518     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2519         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2520             SV * const key = sv_newmortal();
2521             if (entry) {
2522                 sv_setsv(key, HeSVKEY_force(entry));
2523                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2524                 HeSVKEY_set(entry, NULL);
2525             }
2526             else {
2527                 char *k;
2528                 HEK *hek;
2529
2530                 /* one HE per MAGICAL hash */
2531                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2532                 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2533                 Zero(entry, 1, HE);
2534                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2535                 hek = (HEK*)k;
2536                 HeKEY_hek(entry) = hek;
2537                 HeKLEN(entry) = HEf_SVKEY;
2538             }
2539             magic_nextpack(MUTABLE_SV(hv),mg,key);
2540             if (SvOK(key)) {
2541                 /* force key to stay around until next time */
2542                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2543                 return entry;               /* beware, hent_val is not set */
2544             }
2545             SvREFCNT_dec(HeVAL(entry));
2546             Safefree(HeKEY_hek(entry));
2547             del_HE(entry);
2548             iter = HvAUX(hv); /* may been realloced */
2549             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2550             HvLAZYDEL_off(hv);
2551             return NULL;
2552         }
2553     }
2554 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2555     if (!entry && SvRMAGICAL((const SV *)hv)
2556         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2557         prime_env_iter();
2558 #ifdef VMS
2559         /* The prime_env_iter() on VMS just loaded up new hash values
2560          * so the iteration count needs to be reset back to the beginning
2561          */
2562         hv_iterinit(hv);
2563         iter = HvAUX(hv);
2564         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2565 #endif
2566     }
2567 #endif
2568
2569     /* hv_iterinit now ensures this.  */
2570     assert (HvARRAY(hv));
2571
2572     /* At start of hash, entry is NULL.  */
2573     if (entry)
2574     {
2575         entry = HeNEXT(entry);
2576         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2577             /*
2578              * Skip past any placeholders -- don't want to include them in
2579              * any iteration.
2580              */
2581             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2582                 entry = HeNEXT(entry);
2583             }
2584         }
2585     }
2586
2587 #ifdef PERL_HASH_RANDOMIZE_KEYS
2588     if (iter->xhv_last_rand != iter->xhv_rand) {
2589         if (iter->xhv_riter != -1) {
2590             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2591                              "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2592                              pTHX__FORMAT
2593                              pTHX__VALUE);
2594         }
2595         iter = HvAUX(hv); /* may been realloced */
2596         iter->xhv_last_rand = iter->xhv_rand;
2597     }
2598 #endif
2599
2600     /* Skip the entire loop if the hash is empty.   */
2601     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2602         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2603         while (!entry) {
2604             /* OK. Come to the end of the current list.  Grab the next one.  */
2605
2606             iter->xhv_riter++; /* HvRITER(hv)++ */
2607             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2608                 /* There is no next one.  End of the hash.  */
2609                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2610 #ifdef PERL_HASH_RANDOMIZE_KEYS
2611                 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2612 #endif
2613                 break;
2614             }
2615             entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2616
2617             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2618                 /* If we have an entry, but it's a placeholder, don't count it.
2619                    Try the next.  */
2620                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2621                     entry = HeNEXT(entry);
2622             }
2623             /* Will loop again if this linked list starts NULL
2624                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2625                or if we run through it and find only placeholders.  */
2626         }
2627     }
2628     else {
2629         iter->xhv_riter = -1;
2630 #ifdef PERL_HASH_RANDOMIZE_KEYS
2631         iter->xhv_last_rand = iter->xhv_rand;
2632 #endif
2633     }
2634
2635     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2636         HvLAZYDEL_off(hv);
2637         hv_free_ent(hv, oldentry);
2638     }
2639
2640     iter = HvAUX(hv); /* may been realloced */
2641     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2642     return entry;
2643 }
2644
2645 /*
2646 =for apidoc hv_iterkey
2647
2648 Returns the key from the current position of the hash iterator.  See
2649 C<L</hv_iterinit>>.
2650
2651 =cut
2652 */
2653
2654 char *
2655 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2656 {
2657     PERL_ARGS_ASSERT_HV_ITERKEY;
2658
2659     if (HeKLEN(entry) == HEf_SVKEY) {
2660         STRLEN len;
2661         char * const p = SvPV(HeKEY_sv(entry), len);
2662         *retlen = len;
2663         return p;
2664     }
2665     else {
2666         *retlen = HeKLEN(entry);
2667         return HeKEY(entry);
2668     }
2669 }
2670
2671 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2672 /*
2673 =for apidoc hv_iterkeysv
2674
2675 Returns the key as an C<SV*> from the current position of the hash
2676 iterator.  The return value will always be a mortal copy of the key.  Also
2677 see C<L</hv_iterinit>>.
2678
2679 =cut
2680 */
2681
2682 SV *
2683 Perl_hv_iterkeysv(pTHX_ HE *entry)
2684 {
2685     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2686
2687     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2688 }
2689
2690 /*
2691 =for apidoc hv_iterval
2692
2693 Returns the value from the current position of the hash iterator.  See
2694 C<L</hv_iterkey>>.
2695
2696 =cut
2697 */
2698
2699 SV *
2700 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2701 {
2702     PERL_ARGS_ASSERT_HV_ITERVAL;
2703
2704     if (SvRMAGICAL(hv)) {
2705         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2706             SV* const sv = sv_newmortal();
2707             if (HeKLEN(entry) == HEf_SVKEY)
2708                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2709             else
2710                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2711             return sv;
2712         }
2713     }
2714     return HeVAL(entry);
2715 }
2716
2717 /*
2718 =for apidoc hv_iternextsv
2719
2720 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2721 operation.
2722
2723 =cut
2724 */
2725
2726 SV *
2727 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2728 {
2729     HE * const he = hv_iternext_flags(hv, 0);
2730
2731     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2732
2733     if (!he)
2734         return NULL;
2735     *key = hv_iterkey(he, retlen);
2736     return hv_iterval(hv, he);
2737 }
2738
2739 /*
2740
2741 Now a macro in hv.h
2742
2743 =for apidoc hv_magic
2744
2745 Adds magic to a hash.  See C<L</sv_magic>>.
2746
2747 =cut
2748 */
2749
2750 /* possibly free a shared string if no one has access to it
2751  * len and hash must both be valid for str.
2752  */
2753 void
2754 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2755 {
2756     unshare_hek_or_pvn (NULL, str, len, hash);
2757 }
2758
2759
2760 void
2761 Perl_unshare_hek(pTHX_ HEK *hek)
2762 {
2763     assert(hek);
2764     unshare_hek_or_pvn(hek, NULL, 0, 0);
2765 }
2766
2767 /* possibly free a shared string if no one has access to it
2768    hek if non-NULL takes priority over the other 3, else str, len and hash
2769    are used.  If so, len and hash must both be valid for str.
2770  */
2771 STATIC void
2772 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2773 {
2774     XPVHV* xhv;
2775     HE *entry;
2776     HE **oentry;
2777     bool is_utf8 = FALSE;
2778     int k_flags = 0;
2779     const char * const save = str;
2780     struct shared_he *he = NULL;
2781
2782     if (hek) {
2783         /* Find the shared he which is just before us in memory.  */
2784         he = (struct shared_he *)(((char *)hek)
2785                                   - STRUCT_OFFSET(struct shared_he,
2786                                                   shared_he_hek));
2787
2788         /* Assert that the caller passed us a genuine (or at least consistent)
2789            shared hek  */
2790         assert (he->shared_he_he.hent_hek == hek);
2791
2792         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2793             --he->shared_he_he.he_valu.hent_refcount;
2794             return;
2795         }
2796
2797         hash = HEK_HASH(hek);
2798     } else if (len < 0) {
2799         STRLEN tmplen = -len;
2800         is_utf8 = TRUE;
2801         /* See the note in hv_fetch(). --jhi */
2802         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2803         len = tmplen;
2804         if (is_utf8)
2805             k_flags = HVhek_UTF8;
2806         if (str != save)
2807             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2808     }
2809
2810     /* what follows was the moral equivalent of:
2811     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2812         if (--*Svp == NULL)
2813             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2814     } */
2815     xhv = (XPVHV*)SvANY(PL_strtab);
2816     /* assert(xhv_array != 0) */
2817     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2818     if (he) {
2819         const HE *const he_he = &(he->shared_he_he);
2820         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2821             if (entry == he_he)
2822                 break;
2823         }
2824     } else {
2825         const int flags_masked = k_flags & HVhek_MASK;
2826         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2827             if (HeHASH(entry) != hash)          /* strings can't be equal */
2828                 continue;
2829             if (HeKLEN(entry) != len)
2830                 continue;
2831             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2832                 continue;
2833             if (HeKFLAGS(entry) != flags_masked)
2834                 continue;
2835             break;
2836         }
2837     }
2838
2839     if (entry) {
2840         if (--entry->he_valu.hent_refcount == 0) {
2841             *oentry = HeNEXT(entry);
2842             Safefree(entry);
2843             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2844         }
2845     }
2846
2847     if (!entry)
2848         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2849                          "Attempt to free nonexistent shared string '%s'%s"
2850                          pTHX__FORMAT,
2851                          hek ? HEK_KEY(hek) : str,
2852                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2853     if (k_flags & HVhek_FREEKEY)
2854         Safefree(str);
2855 }
2856
2857 /* get a (constant) string ptr from the global string table
2858  * string will get added if it is not already there.
2859  * len and hash must both be valid for str.
2860  */
2861 HEK *
2862 Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
2863 {
2864     bool is_utf8 = FALSE;
2865     int flags = 0;
2866     const char * const save = str;
2867
2868     PERL_ARGS_ASSERT_SHARE_HEK;
2869
2870     if (len < 0) {
2871       STRLEN tmplen = -len;
2872       is_utf8 = TRUE;
2873       /* See the note in hv_fetch(). --jhi */
2874       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2875       len = tmplen;
2876       /* If we were able to downgrade here, then than means that we were passed
2877          in a key which only had chars 0-255, but was utf8 encoded.  */
2878       if (is_utf8)
2879           flags = HVhek_UTF8;
2880       /* If we found we were able to downgrade the string to bytes, then
2881          we should flag that it needs upgrading on keys or each.  Also flag
2882          that we need share_hek_flags to free the string.  */
2883       if (str != save) {
2884           dVAR;
2885           PERL_HASH(hash, str, len);
2886           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2887       }
2888     }
2889
2890     return share_hek_flags (str, len, hash, flags);
2891 }
2892
2893 STATIC HEK *
2894 S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
2895 {
2896     HE *entry;
2897     const int flags_masked = flags & HVhek_MASK;
2898     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2899     XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2900
2901     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2902
2903     /* what follows is the moral equivalent of:
2904
2905     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2906         hv_store(PL_strtab, str, len, NULL, hash);
2907
2908         Can't rehash the shared string table, so not sure if it's worth
2909         counting the number of entries in the linked list
2910     */
2911
2912     /* assert(xhv_array != 0) */
2913     entry = (HvARRAY(PL_strtab))[hindex];
2914     for (;entry; entry = HeNEXT(entry)) {
2915         if (HeHASH(entry) != hash)              /* strings can't be equal */
2916             continue;
2917         if (HeKLEN(entry) != len)
2918             continue;
2919         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2920             continue;
2921         if (HeKFLAGS(entry) != flags_masked)
2922             continue;
2923         break;
2924     }
2925
2926     if (!entry) {
2927         /* What used to be head of the list.
2928            If this is NULL, then we're the first entry for this slot, which
2929            means we need to increate fill.  */
2930         struct shared_he *new_entry;
2931         HEK *hek;
2932         char *k;
2933         HE **const head = &HvARRAY(PL_strtab)[hindex];
2934         HE *const next = *head;
2935
2936         /* We don't actually store a HE from the arena and a regular HEK.
2937            Instead we allocate one chunk of memory big enough for both,
2938            and put the HEK straight after the HE. This way we can find the
2939            HE directly from the HEK.
2940         */
2941
2942         Newx(k, STRUCT_OFFSET(struct shared_he,
2943                                 shared_he_hek.hek_key[0]) + len + 2, char);
2944         new_entry = (struct shared_he *)k;
2945         entry = &(new_entry->shared_he_he);
2946         hek = &(new_entry->shared_he_hek);
2947
2948         Copy(str, HEK_KEY(hek), len, char);
2949         HEK_KEY(hek)[len] = 0;
2950         HEK_LEN(hek) = len;
2951         HEK_HASH(hek) = hash;
2952         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2953
2954         /* Still "point" to the HEK, so that other code need not know what
2955            we're up to.  */
2956         HeKEY_hek(entry) = hek;
2957         entry->he_valu.hent_refcount = 0;
2958         HeNEXT(entry) = next;
2959         *head = entry;
2960
2961         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2962         if (!next) {                    /* initial entry? */
2963         } else if ( DO_HSPLIT(xhv) ) {
2964             const STRLEN oldsize = xhv->xhv_max + 1;
2965             hsplit(PL_strtab, oldsize, oldsize * 2);
2966         }
2967     }
2968
2969     ++entry->he_valu.hent_refcount;
2970
2971     if (flags & HVhek_FREEKEY)
2972         Safefree(str);
2973
2974     return HeKEY_hek(entry);
2975 }
2976
2977 SSize_t *
2978 Perl_hv_placeholders_p(pTHX_ HV *hv)
2979 {
2980     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2981
2982     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2983
2984     if (!mg) {
2985         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2986
2987         if (!mg) {
2988             Perl_die(aTHX_ "panic: hv_placeholders_p");
2989         }
2990     }
2991     return &(mg->mg_len);
2992 }
2993
2994
2995 I32
2996 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2997 {
2998     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2999
3000     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3001     PERL_UNUSED_CONTEXT;
3002
3003     return mg ? mg->mg_len : 0;
3004 }
3005
3006 void
3007 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3008 {
3009     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3010
3011     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3012
3013     if (mg) {
3014         mg->mg_len = ph;
3015     } else if (ph) {
3016         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3017             Perl_die(aTHX_ "panic: hv_placeholders_set");
3018     }
3019     /* else we don't need to add magic to record 0 placeholders.  */
3020 }
3021
3022 STATIC SV *
3023 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3024 {
3025     dVAR;
3026     SV *value;
3027
3028     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3029
3030     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3031     case HVrhek_undef:
3032         value = newSV(0);
3033         break;
3034     case HVrhek_delete:
3035         value = &PL_sv_placeholder;
3036         break;
3037     case HVrhek_IV:
3038         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3039         break;
3040     case HVrhek_UV:
3041         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3042         break;
3043     case HVrhek_PV:
3044     case HVrhek_PV_UTF8:
3045         /* Create a string SV that directly points to the bytes in our
3046            structure.  */
3047         value = newSV_type(SVt_PV);
3048         SvPV_set(value, (char *) he->refcounted_he_data + 1);
3049         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3050         /* This stops anything trying to free it  */
3051         SvLEN_set(value, 0);
3052         SvPOK_on(value);
3053         SvREADONLY_on(value);
3054         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3055             SvUTF8_on(value);
3056         break;
3057     default:
3058         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
3059                    (UV)he->refcounted_he_data[0]);
3060     }
3061     return value;
3062 }
3063
3064 /*
3065 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
3066
3067 Generates and returns a C<HV *> representing the content of a
3068 C<refcounted_he> chain.
3069 C<flags> is currently unused and must be zero.
3070
3071 =cut
3072 */
3073 HV *
3074 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3075 {
3076     dVAR;
3077     HV *hv;
3078     U32 placeholders, max;
3079
3080     if (flags)
3081         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
3082             (UV)flags);
3083
3084     /* We could chase the chain once to get an idea of the number of keys,
3085        and call ksplit.  But for now we'll make a potentially inefficient
3086        hash with only 8 entries in its array.  */
3087     hv = newHV();
3088     max = HvMAX(hv);
3089     if (!HvARRAY(hv)) {
3090         char *array;
3091         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3092         HvARRAY(hv) = (HE**)array;
3093     }
3094
3095     placeholders = 0;
3096     while (chain) {
3097 #ifdef USE_ITHREADS
3098         U32 hash = chain->refcounted_he_hash;
3099 #else
3100         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3101 #endif
3102         HE **oentry = &((HvARRAY(hv))[hash & max]);
3103         HE *entry = *oentry;
3104         SV *value;
3105
3106         for (; entry; entry = HeNEXT(entry)) {
3107             if (HeHASH(entry) == hash) {
3108                 /* We might have a duplicate key here.  If so, entry is older
3109                    than the key we've already put in the hash, so if they are
3110                    the same, skip adding entry.  */
3111 #ifdef USE_ITHREADS
3112                 const STRLEN klen = HeKLEN(entry);
3113                 const char *const key = HeKEY(entry);
3114                 if (klen == chain->refcounted_he_keylen
3115                     && (!!HeKUTF8(entry)
3116                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3117                     && memEQ(key, REF_HE_KEY(chain), klen))
3118                     goto next_please;
3119 #else
3120                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3121                     goto next_please;
3122                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3123                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3124                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3125                              HeKLEN(entry)))
3126                     goto next_please;
3127 #endif
3128             }
3129         }
3130         assert (!entry);
3131         entry = new_HE();
3132
3133 #ifdef USE_ITHREADS
3134         HeKEY_hek(entry)
3135             = share_hek_flags(REF_HE_KEY(chain),
3136                               chain->refcounted_he_keylen,
3137                               chain->refcounted_he_hash,
3138                               (chain->refcounted_he_data[0]
3139                                & (HVhek_UTF8|HVhek_WASUTF8)));
3140 #else
3141         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3142 #endif
3143         value = refcounted_he_value(chain);
3144         if (value == &PL_sv_placeholder)
3145             placeholders++;
3146         HeVAL(entry) = value;
3147
3148         /* Link it into the chain.  */
3149         HeNEXT(entry) = *oentry;
3150         *oentry = entry;
3151
3152         HvTOTALKEYS(hv)++;
3153
3154     next_please:
3155         chain = chain->refcounted_he_next;
3156     }
3157
3158     if (placeholders) {
3159         clear_placeholders(hv, placeholders);
3160         HvTOTALKEYS(hv) -= placeholders;
3161     }
3162
3163     /* We could check in the loop to see if we encounter any keys with key
3164        flags, but it's probably not worth it, as this per-hash flag is only
3165        really meant as an optimisation for things like Storable.  */
3166     HvHASKFLAGS_on(hv);
3167     DEBUG_A(Perl_hv_assert(aTHX_ hv));
3168
3169     return hv;
3170 }
3171
3172 /*
3173 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
3174
3175 Search along a C<refcounted_he> chain for an entry with the key specified
3176 by C<keypv> and C<keylen>.  If C<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3177 bit set, the key octets are interpreted as UTF-8, otherwise they
3178 are interpreted as Latin-1.  C<hash> is a precomputed hash of the key
3179 string, or zero if it has not been precomputed.  Returns a mortal scalar
3180 representing the value associated with the key, or C<&PL_sv_placeholder>
3181 if there is no value associated with the key.
3182
3183 =cut
3184 */
3185
3186 SV *
3187 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3188                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3189 {
3190     dVAR;
3191     U8 utf8_flag;
3192     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3193
3194     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3195         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
3196             (UV)flags);
3197     if (!chain)
3198         goto ret;
3199     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3200         /* For searching purposes, canonicalise to Latin-1 where possible. */
3201         const char *keyend = keypv + keylen, *p;
3202         STRLEN nonascii_count = 0;
3203         for (p = keypv; p != keyend; p++) {
3204             if (! UTF8_IS_INVARIANT(*p)) {
3205                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3206                     goto canonicalised_key;
3207                 }
3208                 nonascii_count++;
3209                 p++;
3210             }
3211         }
3212         if (nonascii_count) {
3213             char *q;
3214             const char *p = keypv, *keyend = keypv + keylen;
3215             keylen -= nonascii_count;
3216             Newx(q, keylen, char);
3217             SAVEFREEPV(q);
3218             keypv = q;
3219             for (; p != keyend; p++, q++) {
3220                 U8 c = (U8)*p;
3221                 if (UTF8_IS_INVARIANT(c)) {
3222                     *q = (char) c;
3223                 }
3224                 else {
3225                     p++;
3226                     *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
3227                 }
3228             }
3229         }
3230         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3231         canonicalised_key: ;
3232     }
3233     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3234     if (!hash)
3235         PERL_HASH(hash, keypv, keylen);
3236
3237     for (; chain; chain = chain->refcounted_he_next) {
3238         if (
3239 #ifdef USE_ITHREADS
3240             hash == chain->refcounted_he_hash &&
3241             keylen == chain->refcounted_he_keylen &&
3242             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3243             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3244 #else
3245             hash == HEK_HASH(chain->refcounted_he_hek) &&
3246             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3247             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3248             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3249 #endif
3250         ) {
3251             if (flags & REFCOUNTED_HE_EXISTS)
3252                 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3253                     == HVrhek_delete
3254                     ? NULL : &PL_sv_yes;
3255             return sv_2mortal(refcounted_he_value(chain));
3256         }
3257     }
3258   ret:
3259     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3260 }
3261
3262 /*
3263 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3264
3265 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3266 instead of a string/length pair.
3267
3268 =cut
3269 */
3270
3271 SV *
3272 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3273                          const char *key, U32 hash, U32 flags)
3274 {
3275     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3276     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3277 }
3278
3279 /*
3280 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3281
3282 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3283 string/length pair.
3284
3285 =cut
3286 */
3287
3288 SV *
3289 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3290                          SV *key, U32 hash, U32 flags)
3291 {
3292     const char *keypv;
3293     STRLEN keylen;
3294     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3295     if (flags & REFCOUNTED_HE_KEY_UTF8)
3296         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3297             (UV)flags);
3298     keypv = SvPV_const(key, keylen);
3299     if (SvUTF8(key))
3300         flags |= REFCOUNTED_HE_KEY_UTF8;
3301     if (!hash && SvIsCOW_shared_hash(key))
3302         hash = SvSHARED_HASH(key);
3303     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3304 }
3305
3306 /*
3307 =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
3308
3309 Creates a new C<refcounted_he>.  This consists of a single key/value
3310 pair and a reference to an existing C<refcounted_he> chain (which may
3311 be empty), and thus forms a longer chain.  When using the longer chain,
3312 the new key/value pair takes precedence over any entry for the same key
3313 further along the chain.
3314
3315 The new key is specified by C<keypv> and C<keylen>.  If C<flags> has
3316 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3317 as UTF-8, otherwise they are interpreted as Latin-1.  C<hash> is
3318 a precomputed hash of the key string, or zero if it has not been
3319 precomputed.
3320
3321 C<value> is the scalar value to store for this key.  C<value> is copied
3322 by this function, which thus does not take ownership of any reference
3323 to it, and later changes to the scalar will not be reflected in the
3324 value visible in the C<refcounted_he>.  Complex types of scalar will not
3325 be stored with referential integrity, but will be coerced to strings.
3326 C<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3327 value is to be associated with the key; this, as with any non-null value,
3328 takes precedence over the existence of a value for the key further along
3329 the chain.
3330
3331 C<parent> points to the rest of the C<refcounted_he> chain to be
3332 attached to the new C<refcounted_he>.  This function takes ownership
3333 of one reference to C<parent>, and returns one reference to the new
3334 C<refcounted_he>.
3335
3336 =cut
3337 */
3338
3339 struct refcounted_he *
3340 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3341         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3342 {
3343     dVAR;
3344     STRLEN value_len = 0;
3345     const char *value_p = NULL;
3346     bool is_pv;
3347     char value_type;
3348     char hekflags;
3349     STRLEN key_offset = 1;
3350     struct refcounted_he *he;
3351     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3352
3353     if (!value || value == &PL_sv_placeholder) {
3354         value_type = HVrhek_delete;
3355     } else if (SvPOK(value)) {
3356         value_type = HVrhek_PV;
3357     } else if (SvIOK(value)) {
3358         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3359     } else if (!SvOK(value)) {
3360         value_type = HVrhek_undef;
3361     } else {
3362         value_type = HVrhek_PV;
3363     }
3364     is_pv = value_type == HVrhek_PV;
3365     if (is_pv) {
3366         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3367            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3368         value_p = SvPV_const(value, value_len);
3369         if (SvUTF8(value))
3370             value_type = HVrhek_PV_UTF8;
3371         key_offset = value_len + 2;
3372     }
3373     hekflags = value_type;
3374
3375     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3376         /* Canonicalise to Latin-1 where possible. */
3377         const char *keyend = keypv + keylen, *p;
3378         STRLEN nonascii_count = 0;
3379         for (p = keypv; p != keyend; p++) {
3380             if (! UTF8_IS_INVARIANT(*p)) {
3381                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3382                     goto canonicalised_key;
3383                 }
3384                 nonascii_count++;
3385                 p++;
3386             }
3387         }
3388         if (nonascii_count) {
3389             char *q;
3390             const char *p = keypv, *keyend = keypv + keylen;
3391             keylen -= nonascii_count;
3392             Newx(q, keylen, char);
3393             SAVEFREEPV(q);
3394             keypv = q;
3395             for (; p != keyend; p++, q++) {
3396                 U8 c = (U8)*p;
3397                 if (UTF8_IS_INVARIANT(c)) {
3398                     *q = (char) c;
3399                 }
3400                 else {
3401                     p++;
3402                     *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
3403                 }
3404             }
3405         }
3406         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3407         canonicalised_key: ;
3408     }
3409     if (flags & REFCOUNTED_HE_KEY_UTF8)
3410         hekflags |= HVhek_UTF8;
3411     if (!hash)
3412         PERL_HASH(hash, keypv, keylen);
3413
3414 #ifdef USE_ITHREADS
3415     he = (struct refcounted_he*)
3416         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3417                              + keylen
3418                              + key_offset);
3419 #else
3420     he = (struct refcounted_he*)
3421         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3422                              + key_offset);
3423 #endif
3424
3425     he->refcounted_he_next = parent;
3426
3427     if (is_pv) {
3428         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3429         he->refcounted_he_val.refcounted_he_u_len = value_len;
3430     } else if (value_type == HVrhek_IV) {
3431         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3432     } else if (value_type == HVrhek_UV) {
3433         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3434     }
3435
3436 #ifdef USE_ITHREADS
3437     he->refcounted_he_hash = hash;
3438     he->refcounted_he_keylen = keylen;
3439     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3440 #else
3441     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3442 #endif
3443
3444     he->refcounted_he_data[0] = hekflags;
3445     he->refcounted_he_refcnt = 1;
3446
3447     return he;
3448 }
3449
3450 /*
3451 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3452
3453 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3454 of a string/length pair.
3455
3456 =cut
3457 */
3458
3459 struct refcounted_he *
3460 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3461         const char *key, U32 hash, SV *value, U32 flags)
3462 {
3463     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3464     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3465 }
3466
3467 /*
3468 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3469
3470 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3471 string/length pair.
3472
3473 =cut
3474 */
3475
3476 struct refcounted_he *
3477 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3478         SV *key, U32 hash, SV *value, U32 flags)
3479 {
3480     const char *keypv;
3481     STRLEN keylen;
3482     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3483     if (flags & REFCOUNTED_HE_KEY_UTF8)
3484         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3485             (UV)flags);
3486     keypv = SvPV_const(key, keylen);
3487     if (SvUTF8(key))
3488         flags |= REFCOUNTED_HE_KEY_UTF8;
3489     if (!hash && SvIsCOW_shared_hash(key))
3490         hash = SvSHARED_HASH(key);
3491     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3492 }
3493
3494 /*
3495 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3496
3497 Decrements the reference count of a C<refcounted_he> by one.  If the
3498 reference count reaches zero the structure's memory is freed, which
3499 (recursively) causes a reduction of its parent C<refcounted_he>'s
3500 reference count.  It is safe to pass a null pointer to this function:
3501 no action occurs in this case.
3502
3503 =cut
3504 */
3505
3506 void
3507 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3508 #ifdef USE_ITHREADS
3509     dVAR;
3510 #endif
3511     PERL_UNUSED_CONTEXT;
3512
3513     while (he) {
3514         struct refcounted_he *copy;
3515         U32 new_count;
3516
3517         HINTS_REFCNT_LOCK;
3518         new_count = --he->refcounted_he_refcnt;
3519         HINTS_REFCNT_UNLOCK;
3520         
3521         if (new_count) {
3522             return;
3523         }
3524
3525 #ifndef USE_ITHREADS
3526         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3527 #endif
3528         copy = he;
3529         he = he->refcounted_he_next;
3530         PerlMemShared_free(copy);
3531     }
3532 }
3533
3534 /*
3535 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3536
3537 Increment the reference count of a C<refcounted_he>.  The pointer to the
3538 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3539 to this function: no action occurs and a null pointer is returned.
3540
3541 =cut
3542 */
3543
3544 struct refcounted_he *
3545 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3546 {
3547 #ifdef USE_ITHREADS
3548     dVAR;
3549 #endif
3550     PERL_UNUSED_CONTEXT;
3551     if (he) {
3552         HINTS_REFCNT_LOCK;
3553         he->refcounted_he_refcnt++;
3554         HINTS_REFCNT_UNLOCK;
3555     }
3556     return he;
3557 }
3558
3559 /*
3560 =for apidoc cop_fetch_label
3561
3562 Returns the label attached to a cop.
3563 The flags pointer may be set to C<SVf_UTF8> or 0.
3564
3565 =cut
3566 */
3567
3568 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3569    the linked list.  */
3570 const char *
3571 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3572     struct refcounted_he *const chain = cop->cop_hints_hash;
3573
3574     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3575     PERL_UNUSED_CONTEXT;
3576
3577     if (!chain)
3578         return NULL;
3579 #ifdef USE_ITHREADS
3580     if (chain->refcounted_he_keylen != 1)
3581         return NULL;
3582     if (*REF_HE_KEY(chain) != ':')
3583         return NULL;
3584 #else
3585     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3586         return NULL;
3587     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3588         return NULL;
3589 #endif
3590     /* Stop anyone trying to really mess us up by adding their own value for
3591        ':' into %^H  */
3592     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3593         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3594         return NULL;
3595
3596     if (len)
3597         *len = chain->refcounted_he_val.refcounted_he_u_len;
3598     if (flags) {
3599         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3600                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3601     }
3602     return chain->refcounted_he_data + 1;
3603 }
3604
3605 /*
3606 =for apidoc cop_store_label
3607
3608 Save a label into a C<cop_hints_hash>.
3609 You need to set flags to C<SVf_UTF8>
3610 for a utf-8 label.
3611
3612 =cut
3613 */
3614
3615 void
3616 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3617                      U32 flags)
3618 {
3619     SV *labelsv;
3620     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3621
3622     if (flags & ~(SVf_UTF8))
3623         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3624                    (UV)flags);
3625     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3626     if (flags & SVf_UTF8)
3627         SvUTF8_on(labelsv);
3628     cop->cop_hints_hash
3629         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3630 }
3631
3632 /*
3633 =for apidoc hv_assert
3634
3635 Check that a hash is in an internally consistent state.
3636
3637 =cut
3638 */
3639
3640 #ifdef DEBUGGING
3641
3642 void
3643 Perl_hv_assert(pTHX_ HV *hv)
3644 {
3645     dVAR;
3646     HE* entry;
3647     int withflags = 0;
3648     int placeholders = 0;
3649     int real = 0;
3650     int bad = 0;
3651     const I32 riter = HvRITER_get(hv);
3652     HE *eiter = HvEITER_get(hv);
3653
3654     PERL_ARGS_ASSERT_HV_ASSERT;
3655
3656     (void)hv_iterinit(hv);
3657
3658     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3659         /* sanity check the values */
3660         if (HeVAL(entry) == &PL_sv_placeholder)
3661             placeholders++;
3662         else
3663             real++;
3664         /* sanity check the keys */
3665         if (HeSVKEY(entry)) {
3666             NOOP;   /* Don't know what to check on SV keys.  */
3667         } else if (HeKUTF8(entry)) {
3668             withflags++;
3669             if (HeKWASUTF8(entry)) {
3670                 PerlIO_printf(Perl_debug_log,
3671                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3672                             (int) HeKLEN(entry),  HeKEY(entry));
3673                 bad = 1;
3674             }
3675         } else if (HeKWASUTF8(entry))
3676             withflags++;
3677     }
3678     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3679         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3680         const int nhashkeys = HvUSEDKEYS(hv);
3681         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3682
3683         if (nhashkeys != real) {
3684             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3685             bad = 1;
3686         }
3687         if (nhashplaceholders != placeholders) {
3688             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3689             bad = 1;
3690         }
3691     }
3692     if (withflags && ! HvHASKFLAGS(hv)) {
3693         PerlIO_printf(Perl_debug_log,
3694                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3695                     withflags);
3696         bad = 1;
3697     }
3698     if (bad) {
3699         sv_dump(MUTABLE_SV(hv));
3700     }
3701     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3702     HvEITER_set(hv, eiter);
3703 }
3704
3705 #endif
3706
3707 /*
3708  * ex: set ts=8 sts=4 sw=4 et:
3709  */