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