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