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