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