op.c:S_my_kid: Remove obsolete comment
[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     if (!*oentry && SvOOK(hv)) {
833         /* initial entry, and aux struct present.  */
834         struct xpvhv_aux *const aux = HvAUX(hv);
835         if (aux->xhv_fill_lazy)
836             ++aux->xhv_fill_lazy;
837     }
838
839 #ifdef PERL_HASH_RANDOMIZE_KEYS
840     /* This logic semi-randomizes the insert order in a bucket.
841      * Either we insert into the top, or the slot below the top,
842      * making it harder to see if there is a collision. We also
843      * reset the iterator randomizer if there is one.
844      */
845     if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
846         PL_hash_rand_bits++;
847         PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
848         if ( PL_hash_rand_bits & 1 ) {
849             HeNEXT(entry) = HeNEXT(*oentry);
850             HeNEXT(*oentry) = entry;
851         } else {
852             HeNEXT(entry) = *oentry;
853             *oentry = entry;
854         }
855     } else
856 #endif
857     {
858         HeNEXT(entry) = *oentry;
859         *oentry = entry;
860     }
861 #ifdef PERL_HASH_RANDOMIZE_KEYS
862     if (SvOOK(hv)) {
863         /* Currently this makes various tests warn in annoying ways.
864          * So Silenced for now. - Yves | bogus end of comment =>* /
865         if (HvAUX(hv)->xhv_riter != -1) {
866             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
867                              "[TESTING] Inserting into a hash during each() traversal results in undefined behavior"
868                              pTHX__FORMAT
869                              pTHX__VALUE);
870         }
871         */
872         if (PL_HASH_RAND_BITS_ENABLED) {
873             if (PL_HASH_RAND_BITS_ENABLED == 1)
874                 PL_hash_rand_bits += (PTRV)entry + 1;  /* we don't bother to use ptr_hash here */
875             PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
876         }
877         HvAUX(hv)->xhv_rand= (U32)PL_hash_rand_bits;
878     }
879 #endif
880
881     if (val == &PL_sv_placeholder)
882         HvPLACEHOLDERS(hv)++;
883     if (masked_flags & HVhek_ENABLEHVKFLAGS)
884         HvHASKFLAGS_on(hv);
885
886     xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
887     if ( DO_HSPLIT(xhv) ) {
888         const STRLEN oldsize = xhv->xhv_max + 1;
889         const U32 items = (U32)HvPLACEHOLDERS_get(hv);
890
891         if (items /* hash has placeholders  */
892             && !SvREADONLY(hv) /* but is not a restricted hash */) {
893             /* If this hash previously was a "restricted hash" and had
894                placeholders, but the "restricted" flag has been turned off,
895                then the placeholders no longer serve any useful purpose.
896                However, they have the downsides of taking up RAM, and adding
897                extra steps when finding used values. It's safe to clear them
898                at this point, even though Storable rebuilds restricted hashes by
899                putting in all the placeholders (first) before turning on the
900                readonly flag, because Storable always pre-splits the hash.
901                If we're lucky, then we may clear sufficient placeholders to
902                avoid needing to split the hash at all.  */
903             clear_placeholders(hv, items);
904             if (DO_HSPLIT(xhv))
905                 hsplit(hv, oldsize, oldsize * 2);
906         } else
907             hsplit(hv, oldsize, oldsize * 2);
908     }
909
910     if (return_svp) {
911         return entry ? (void *) &HeVAL(entry) : NULL;
912     }
913     return (void *) entry;
914 }
915
916 STATIC void
917 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
918 {
919     const MAGIC *mg = SvMAGIC(hv);
920
921     PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
922
923     *needs_copy = FALSE;
924     *needs_store = TRUE;
925     while (mg) {
926         if (isUPPER(mg->mg_type)) {
927             *needs_copy = TRUE;
928             if (mg->mg_type == PERL_MAGIC_tied) {
929                 *needs_store = FALSE;
930                 return; /* We've set all there is to set. */
931             }
932         }
933         mg = mg->mg_moremagic;
934     }
935 }
936
937 /*
938 =for apidoc hv_scalar
939
940 Evaluates the hash in scalar context and returns the result.  Handles magic
941 when the hash is tied.
942
943 =cut
944 */
945
946 SV *
947 Perl_hv_scalar(pTHX_ HV *hv)
948 {
949     SV *sv;
950
951     PERL_ARGS_ASSERT_HV_SCALAR;
952
953     if (SvRMAGICAL(hv)) {
954         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
955         if (mg)
956             return magic_scalarpack(hv, mg);
957     }
958
959     sv = sv_newmortal();
960     if (HvTOTALKEYS((const HV *)hv)) 
961         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
962                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
963     else
964         sv_setiv(sv, 0);
965     
966     return sv;
967 }
968
969 /*
970 =for apidoc hv_delete
971
972 Deletes a key/value pair in the hash.  The value's SV is removed from
973 the hash, made mortal, and returned to the caller.  The absolute
974 value of C<klen> is the length of the key.  If C<klen> is negative the
975 key is assumed to be in UTF-8-encoded Unicode.  The C<flags> value
976 will normally be zero; if set to C<G_DISCARD> then C<NULL> will be returned.
977 C<NULL> will also be returned if the key is not found.
978
979 =for apidoc hv_delete_ent
980
981 Deletes a key/value pair in the hash.  The value SV is removed from the hash,
982 made mortal, and returned to the caller.  The C<flags> value will normally be
983 zero; if set to C<G_DISCARD> then C<NULL> will be returned.  C<NULL> will also
984 be returned if the key is not found.  C<hash> can be a valid precomputed hash
985 value, or 0 to ask for it to be computed.
986
987 =cut
988 */
989
990 STATIC SV *
991 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
992                    int k_flags, I32 d_flags, U32 hash)
993 {
994     dVAR;
995     XPVHV* xhv;
996     HE *entry;
997     HE **oentry;
998     HE **first_entry;
999     bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
1000     int masked_flags;
1001     HEK *keysv_hek = NULL;
1002     U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
1003     SV *sv;
1004     GV *gv = NULL;
1005     HV *stash = NULL;
1006
1007     if (SvRMAGICAL(hv)) {
1008         bool needs_copy;
1009         bool needs_store;
1010         hv_magic_check (hv, &needs_copy, &needs_store);
1011
1012         if (needs_copy) {
1013             SV *sv;
1014             entry = (HE *) hv_common(hv, keysv, key, klen,
1015                                      k_flags & ~HVhek_FREEKEY,
1016                                      HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
1017                                      NULL, hash);
1018             sv = entry ? HeVAL(entry) : NULL;
1019             if (sv) {
1020                 if (SvMAGICAL(sv)) {
1021                     mg_clear(sv);
1022                 }
1023                 if (!needs_store) {
1024                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
1025                         /* No longer an element */
1026                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
1027                         return sv;
1028                     }           
1029                     return NULL;                /* element cannot be deleted */
1030                 }
1031 #ifdef ENV_IS_CASELESS
1032                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
1033                     /* XXX This code isn't UTF8 clean.  */
1034                     keysv = newSVpvn_flags(key, klen, SVs_TEMP);
1035                     if (k_flags & HVhek_FREEKEY) {
1036                         Safefree(key);
1037                     }
1038                     key = strupr(SvPVX(keysv));
1039                     is_utf8 = 0;
1040                     k_flags = 0;
1041                     hash = 0;
1042                 }
1043 #endif
1044             }
1045         }
1046     }
1047     xhv = (XPVHV*)SvANY(hv);
1048     if (!HvARRAY(hv))
1049         return NULL;
1050
1051     if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
1052         const char * const keysave = key;
1053         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1054
1055         if (is_utf8)
1056             k_flags |= HVhek_UTF8;
1057         else
1058             k_flags &= ~HVhek_UTF8;
1059         if (key != keysave) {
1060             if (k_flags & HVhek_FREEKEY) {
1061                 /* This shouldn't happen if our caller does what we expect,
1062                    but strictly the API allows it.  */
1063                 Safefree(keysave);
1064             }
1065             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1066         }
1067         HvHASKFLAGS_on(MUTABLE_SV(hv));
1068     }
1069
1070     if (keysv && (SvIsCOW_shared_hash(keysv))) {
1071         if (HvSHAREKEYS(hv))
1072             keysv_hek  = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
1073         hash = SvSHARED_HASH(keysv);
1074     }
1075     else if (!hash)
1076         PERL_HASH(hash, key, klen);
1077
1078     masked_flags = (k_flags & HVhek_MASK);
1079
1080     first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1081     entry = *oentry;
1082
1083     if (!entry)
1084         goto not_found;
1085
1086     if (keysv_hek) {
1087         /* keysv is actually a HEK in disguise, so we can match just by
1088          * comparing the HEK pointers in the HE chain. There is a slight
1089          * caveat: on something like "\x80", which has both plain and utf8
1090          * representations, perl's hashes do encoding-insensitive lookups,
1091          * but preserve the encoding of the stored key. Thus a particular
1092          * key could map to two different HEKs in PL_strtab. We only
1093          * conclude 'not found' if all the flags are the same; otherwise
1094          * we fall back to a full search (this should only happen in rare
1095          * cases).
1096          */
1097         int keysv_flags = HEK_FLAGS(keysv_hek);
1098
1099         for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1100             HEK *hek = HeKEY_hek(entry);
1101             if (hek == keysv_hek)
1102                 goto found;
1103             if (HEK_FLAGS(hek) != keysv_flags)
1104                 break; /* need to do full match */
1105         }
1106         if (!entry)
1107             goto not_found;
1108         /* failed on shortcut - do full search loop */
1109         oentry = first_entry;
1110         entry = *oentry;
1111     }
1112
1113     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1114         if (HeHASH(entry) != hash)              /* strings can't be equal */
1115             continue;
1116         if (HeKLEN(entry) != (I32)klen)
1117             continue;
1118         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
1119             continue;
1120         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1121             continue;
1122
1123       found:
1124         if (hv == PL_strtab) {
1125             if (k_flags & HVhek_FREEKEY)
1126                 Safefree(key);
1127             Perl_croak(aTHX_ S_strtab_error, "delete");
1128         }
1129
1130         /* if placeholder is here, it's already been deleted.... */
1131         if (HeVAL(entry) == &PL_sv_placeholder) {
1132             if (k_flags & HVhek_FREEKEY)
1133                 Safefree(key);
1134             return NULL;
1135         }
1136         if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1137             hv_notallowed(k_flags, key, klen,
1138                             "Attempt to delete readonly key '%"SVf"' from"
1139                             " a restricted hash");
1140         }
1141         if (k_flags & HVhek_FREEKEY)
1142             Safefree(key);
1143
1144         /* If this is a stash and the key ends with ::, then someone is 
1145          * deleting a package.
1146          */
1147         if (HeVAL(entry) && HvENAME_get(hv)) {
1148                 gv = (GV *)HeVAL(entry);
1149                 if (keysv) key = SvPV(keysv, klen);
1150                 if ((
1151                      (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1152                       ||
1153                      (klen == 1 && key[0] == ':')
1154                     )
1155                  && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1156                  && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
1157                  && HvENAME_get(stash)) {
1158                         /* A previous version of this code checked that the
1159                          * GV was still in the symbol table by fetching the
1160                          * GV with its name. That is not necessary (and
1161                          * sometimes incorrect), as HvENAME cannot be set
1162                          * on hv if it is not in the symtab. */
1163                         mro_changes = 2;
1164                         /* Hang on to it for a bit. */
1165                         SvREFCNT_inc_simple_void_NN(
1166                          sv_2mortal((SV *)gv)
1167                         );
1168                 }
1169                 else if (klen == 3 && strnEQ(key, "ISA", 3) && GvAV(gv)) {
1170                     AV *isa = GvAV(gv);
1171                     MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa);
1172
1173                     mro_changes = 1;
1174                     if (mg) {
1175                         if (mg->mg_obj == (SV*)gv) {
1176                             /* This is the only stash this ISA was used for.
1177                              * The isaelem magic asserts if there's no
1178                              * isa magic on the array, so explicitly
1179                              * remove the magic on both the array and its
1180                              * elements.  @ISA shouldn't be /too/ large.
1181                              */
1182                             SV **svp, **end;
1183                         strip_magic:
1184                             svp = AvARRAY(isa);
1185                             end = svp + AvFILLp(isa)+1;
1186                             while (svp < end) {
1187                                 if (*svp)
1188                                     mg_free_type(*svp, PERL_MAGIC_isaelem);
1189                                 ++svp;
1190                             }
1191                             mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
1192                         }
1193                         else {
1194                             /* mg_obj is an array of stashes
1195                                Note that the array doesn't keep a reference
1196                                count on the stashes.
1197                              */
1198                             AV *av = (AV*)mg->mg_obj;
1199                             SV **svp, **arrayp;
1200                             SSize_t index;
1201                             SSize_t items;
1202
1203                             assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
1204
1205                             /* remove the stash from the magic array */
1206                             arrayp = svp = AvARRAY(av);
1207                             items = AvFILLp(av) + 1;
1208                             if (items == 1) {
1209                                 assert(*arrayp == (SV *)gv);
1210                                 mg->mg_obj = NULL;
1211                                 /* avoid a double free on the last stash */
1212                                 AvFILLp(av) = -1;
1213                                 /* The magic isn't MGf_REFCOUNTED, so release
1214                                  * the array manually.
1215                                  */
1216                                 SvREFCNT_dec_NN(av);
1217                                 goto strip_magic;
1218                             }
1219                             else {
1220                                 while (items--) {
1221                                     if (*svp == (SV*)gv)
1222                                         break;
1223                                     ++svp;
1224                                 }
1225                                 index = svp - arrayp;
1226                                 assert(index >= 0 && index <= AvFILLp(av));
1227                                 if (index < AvFILLp(av)) {
1228                                     arrayp[index] = arrayp[AvFILLp(av)];
1229                                 }
1230                                 arrayp[AvFILLp(av)] = NULL;
1231                                 --AvFILLp(av);
1232                             }
1233                         }
1234                     }
1235                 }
1236         }
1237
1238         sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
1239         HeVAL(entry) = &PL_sv_placeholder;
1240         if (sv) {
1241             /* deletion of method from stash */
1242             if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1243              && HvENAME_get(hv))
1244                 mro_method_changed_in(hv);
1245         }
1246
1247         /*
1248          * If a restricted hash, rather than really deleting the entry, put
1249          * a placeholder there. This marks the key as being "approved", so
1250          * we can still access via not-really-existing key without raising
1251          * an error.
1252          */
1253         if (SvREADONLY(hv))
1254             /* We'll be saving this slot, so the number of allocated keys
1255              * doesn't go down, but the number placeholders goes up */
1256             HvPLACEHOLDERS(hv)++;
1257         else {
1258             *oentry = HeNEXT(entry);
1259             if(!*first_entry && SvOOK(hv)) {
1260                 /* removed last entry, and aux struct present.  */
1261                 struct xpvhv_aux *const aux = HvAUX(hv);
1262                 if (aux->xhv_fill_lazy)
1263                     --aux->xhv_fill_lazy;
1264             }
1265             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1266                 HvLAZYDEL_on(hv);
1267             else {
1268                 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1269                     entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1270                     HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1271                 hv_free_ent(hv, entry);
1272             }
1273             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1274             if (xhv->xhv_keys == 0)
1275                 HvHASKFLAGS_off(hv);
1276         }
1277
1278         if (d_flags & G_DISCARD) {
1279             SvREFCNT_dec(sv);
1280             sv = NULL;
1281         }
1282
1283         if (mro_changes == 1) mro_isa_changed_in(hv);
1284         else if (mro_changes == 2)
1285             mro_package_moved(NULL, stash, gv, 1);
1286
1287         return sv;
1288     }
1289
1290   not_found:
1291     if (SvREADONLY(hv)) {
1292         hv_notallowed(k_flags, key, klen,
1293                         "Attempt to delete disallowed key '%"SVf"' from"
1294                         " a restricted hash");
1295     }
1296
1297     if (k_flags & HVhek_FREEKEY)
1298         Safefree(key);
1299     return NULL;
1300 }
1301
1302
1303 STATIC void
1304 S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1305 {
1306     STRLEN i = 0;
1307     char *a = (char*) HvARRAY(hv);
1308     HE **aep;
1309
1310     bool do_aux= (
1311         /* already have an HvAUX(hv) so we have to move it */
1312         SvOOK(hv) ||
1313         /* no HvAUX() but array we are going to allocate is large enough
1314          * there is no point in saving the space for the iterator, and
1315          * speeds up later traversals. */
1316         ( ( hv != PL_strtab ) && ( newsize >= PERL_HV_ALLOC_AUX_SIZE ) )
1317     );
1318
1319     PERL_ARGS_ASSERT_HSPLIT;
1320
1321     PL_nomemok = TRUE;
1322     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1323           + (do_aux ? sizeof(struct xpvhv_aux) : 0), char);
1324     PL_nomemok = FALSE;
1325     if (!a) {
1326       return;
1327     }
1328
1329 #ifdef PERL_HASH_RANDOMIZE_KEYS
1330     /* the idea of this is that we create a "random" value by hashing the address of
1331      * the array, we then use the low bit to decide if we insert at the top, or insert
1332      * second from top. After each such insert we rotate the hashed value. So we can
1333      * use the same hashed value over and over, and in normal build environments use
1334      * very few ops to do so. ROTL32() should produce a single machine operation. */
1335     if (PL_HASH_RAND_BITS_ENABLED) {
1336         if (PL_HASH_RAND_BITS_ENABLED == 1)
1337             PL_hash_rand_bits += ptr_hash((PTRV)a);
1338         PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1339     }
1340 #endif
1341     HvARRAY(hv) = (HE**) a;
1342     HvMAX(hv) = newsize - 1;
1343     /* before we zero the newly added memory, we
1344      * need to deal with the aux struct that may be there
1345      * or have been allocated by us*/
1346     if (do_aux) {
1347         struct xpvhv_aux *const dest
1348             = (struct xpvhv_aux*) &a[newsize * sizeof(HE*)];
1349         if (SvOOK(hv)) {
1350             /* alread have an aux, copy the old one in place. */
1351             Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
1352             /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
1353 #ifdef PERL_HASH_RANDOMIZE_KEYS
1354             dest->xhv_rand = (U32)PL_hash_rand_bits;
1355 #endif
1356             /* For now, just reset the lazy fill counter.
1357                It would be possible to update the counter in the code below
1358                instead.  */
1359             dest->xhv_fill_lazy = 0;
1360         } else {
1361             /* no existing aux structure, but we allocated space for one
1362              * so initialize it properly. This unrolls hv_auxinit() a bit,
1363              * since we have to do the realloc anyway. */
1364             /* first we set the iterator's xhv_rand so it can be copied into lastrand below */
1365 #ifdef PERL_HASH_RANDOMIZE_KEYS
1366             dest->xhv_rand = (U32)PL_hash_rand_bits;
1367 #endif
1368             /* this is the "non realloc" part of the hv_auxinit() */
1369             (void)hv_auxinit_internal(dest);
1370             /* Turn on the OOK flag */
1371             SvOOK_on(hv);
1372         }
1373     }
1374     /* now we can safely clear the second half */
1375     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1376
1377     if (!HvTOTALKEYS(hv))       /* skip rest if no entries */
1378         return;
1379
1380     newsize--;
1381     aep = (HE**)a;
1382     do {
1383         HE **oentry = aep + i;
1384         HE *entry = aep[i];
1385
1386         if (!entry)                             /* non-existent */
1387             continue;
1388         do {
1389             U32 j = (HeHASH(entry) & newsize);
1390             if (j != (U32)i) {
1391                 *oentry = HeNEXT(entry);
1392 #ifdef PERL_HASH_RANDOMIZE_KEYS
1393                 /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
1394                  * insert to top, otherwise rotate the bucket rand 1 bit,
1395                  * and use the new low bit to decide if we insert at top,
1396                  * or next from top. IOW, we only rotate on a collision.*/
1397                 if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
1398                     PL_hash_rand_bits+= ROTL32(HeHASH(entry), 17);
1399                     PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
1400                     if (PL_hash_rand_bits & 1) {
1401                         HeNEXT(entry)= HeNEXT(aep[j]);
1402                         HeNEXT(aep[j])= entry;
1403                     } else {
1404                         /* Note, this is structured in such a way as the optimizer
1405                         * should eliminate the duplicated code here and below without
1406                         * us needing to explicitly use a goto. */
1407                         HeNEXT(entry) = aep[j];
1408                         aep[j] = entry;
1409                     }
1410                 } else
1411 #endif
1412                 {
1413                     /* see comment above about duplicated code */
1414                     HeNEXT(entry) = aep[j];
1415                     aep[j] = entry;
1416                 }
1417             }
1418             else {
1419                 oentry = &HeNEXT(entry);
1420             }
1421             entry = *oentry;
1422         } while (entry);
1423     } while (i++ < oldsize);
1424 }
1425
1426 void
1427 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1428 {
1429     XPVHV* xhv = (XPVHV*)SvANY(hv);
1430     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1431     I32 newsize;
1432     char *a;
1433
1434     PERL_ARGS_ASSERT_HV_KSPLIT;
1435
1436     newsize = (I32) newmax;                     /* possible truncation here */
1437     if (newsize != newmax || newmax <= oldsize)
1438         return;
1439     while ((newsize & (1 + ~newsize)) != newsize) {
1440         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1441     }
1442     if (newsize < newmax)
1443         newsize *= 2;
1444     if (newsize < newmax)
1445         return;                                 /* overflow detection */
1446
1447     a = (char *) HvARRAY(hv);
1448     if (a) {
1449         hsplit(hv, oldsize, newsize);
1450     } else {
1451         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1452         xhv->xhv_max = --newsize;
1453         HvARRAY(hv) = (HE **) a;
1454     }
1455 }
1456
1457 /* IMO this should also handle cases where hv_max is smaller than hv_keys
1458  * as tied hashes could play silly buggers and mess us around. We will
1459  * do the right thing during hv_store() afterwards, but still - Yves */
1460 #define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
1461     /* Can we use fewer buckets? (hv_max is always 2^n-1) */        \
1462     if (hv_max < PERL_HASH_DEFAULT_HvMAX) {                         \
1463         hv_max = PERL_HASH_DEFAULT_HvMAX;                           \
1464     } else {                                                        \
1465         while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
1466             hv_max = hv_max / 2;                                    \
1467     }                                                               \
1468     HvMAX(hv) = hv_max;                                             \
1469 } STMT_END
1470
1471
1472 HV *
1473 Perl_newHVhv(pTHX_ HV *ohv)
1474 {
1475     dVAR;
1476     HV * const hv = newHV();
1477     STRLEN hv_max;
1478
1479     if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
1480         return hv;
1481     hv_max = HvMAX(ohv);
1482
1483     if (!SvMAGICAL((const SV *)ohv)) {
1484         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1485         STRLEN i;
1486         const bool shared = !!HvSHAREKEYS(ohv);
1487         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1488         char *a;
1489         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1490         ents = (HE**)a;
1491
1492         /* In each bucket... */
1493         for (i = 0; i <= hv_max; i++) {
1494             HE *prev = NULL;
1495             HE *oent = oents[i];
1496
1497             if (!oent) {
1498                 ents[i] = NULL;
1499                 continue;
1500             }
1501
1502             /* Copy the linked list of entries. */
1503             for (; oent; oent = HeNEXT(oent)) {
1504                 const U32 hash   = HeHASH(oent);
1505                 const char * const key = HeKEY(oent);
1506                 const STRLEN len = HeKLEN(oent);
1507                 const int flags  = HeKFLAGS(oent);
1508                 HE * const ent   = new_HE();
1509                 SV *const val    = HeVAL(oent);
1510
1511                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1512                 HeKEY_hek(ent)
1513                     = shared ? share_hek_flags(key, len, hash, flags)
1514                              :  save_hek_flags(key, len, hash, flags);
1515                 if (prev)
1516                     HeNEXT(prev) = ent;
1517                 else
1518                     ents[i] = ent;
1519                 prev = ent;
1520                 HeNEXT(ent) = NULL;
1521             }
1522         }
1523
1524         HvMAX(hv)   = hv_max;
1525         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1526         HvARRAY(hv) = ents;
1527     } /* not magical */
1528     else {
1529         /* Iterate over ohv, copying keys and values one at a time. */
1530         HE *entry;
1531         const I32 riter = HvRITER_get(ohv);
1532         HE * const eiter = HvEITER_get(ohv);
1533         STRLEN hv_keys = HvTOTALKEYS(ohv);
1534
1535         HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1536
1537         hv_iterinit(ohv);
1538         while ((entry = hv_iternext_flags(ohv, 0))) {
1539             SV *val = hv_iterval(ohv,entry);
1540             SV * const keysv = HeSVKEY(entry);
1541             val = SvIMMORTAL(val) ? val : newSVsv(val);
1542             if (keysv)
1543                 (void)hv_store_ent(hv, keysv, val, 0);
1544             else
1545                 (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1546                                  HeHASH(entry), HeKFLAGS(entry));
1547         }
1548         HvRITER_set(ohv, riter);
1549         HvEITER_set(ohv, eiter);
1550     }
1551
1552     return hv;
1553 }
1554
1555 /*
1556 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1557
1558 A specialised version of L</newHVhv> for copying C<%^H>.  C<ohv> must be
1559 a pointer to a hash (which may have C<%^H> magic, but should be generally
1560 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1561 of C<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1562 added to it.  A pointer to the new hash is returned.
1563
1564 =cut
1565 */
1566
1567 HV *
1568 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1569 {
1570     HV * const hv = newHV();
1571
1572     if (ohv) {
1573         STRLEN hv_max = HvMAX(ohv);
1574         STRLEN hv_keys = HvTOTALKEYS(ohv);
1575         HE *entry;
1576         const I32 riter = HvRITER_get(ohv);
1577         HE * const eiter = HvEITER_get(ohv);
1578
1579         ENTER;
1580         SAVEFREESV(hv);
1581
1582         HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
1583
1584         hv_iterinit(ohv);
1585         while ((entry = hv_iternext_flags(ohv, 0))) {
1586             SV *const sv = newSVsv(hv_iterval(ohv,entry));
1587             SV *heksv = HeSVKEY(entry);
1588             if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1589             if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1590                      (char *)heksv, HEf_SVKEY);
1591             if (heksv == HeSVKEY(entry))
1592                 (void)hv_store_ent(hv, heksv, sv, 0);
1593             else {
1594                 (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1595                                  HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1596                 SvREFCNT_dec_NN(heksv);
1597             }
1598         }
1599         HvRITER_set(ohv, riter);
1600         HvEITER_set(ohv, eiter);
1601
1602         SvREFCNT_inc_simple_void_NN(hv);
1603         LEAVE;
1604     }
1605     hv_magic(hv, NULL, PERL_MAGIC_hints);
1606     return hv;
1607 }
1608 #undef HV_SET_MAX_ADJUSTED_FOR_KEYS
1609
1610 /* like hv_free_ent, but returns the SV rather than freeing it */
1611 STATIC SV*
1612 S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
1613 {
1614     SV *val;
1615
1616     PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1617
1618     val = HeVAL(entry);
1619     if (HeKLEN(entry) == HEf_SVKEY) {
1620         SvREFCNT_dec(HeKEY_sv(entry));
1621         Safefree(HeKEY_hek(entry));
1622     }
1623     else if (HvSHAREKEYS(hv))
1624         unshare_hek(HeKEY_hek(entry));
1625     else
1626         Safefree(HeKEY_hek(entry));
1627     del_HE(entry);
1628     return val;
1629 }
1630
1631
1632 void
1633 Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
1634 {
1635     SV *val;
1636
1637     PERL_ARGS_ASSERT_HV_FREE_ENT;
1638
1639     if (!entry)
1640         return;
1641     val = hv_free_ent_ret(hv, entry);
1642     SvREFCNT_dec(val);
1643 }
1644
1645
1646 void
1647 Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
1648 {
1649     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1650
1651     if (!entry)
1652         return;
1653     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1654     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1655     if (HeKLEN(entry) == HEf_SVKEY) {
1656         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1657     }
1658     hv_free_ent(hv, entry);
1659 }
1660
1661 /*
1662 =for apidoc hv_clear
1663
1664 Frees the all the elements of a hash, leaving it empty.
1665 The XS equivalent of C<%hash = ()>.  See also L</hv_undef>.
1666
1667 See L</av_clear> for a note about the hash possibly being invalid on
1668 return.
1669
1670 =cut
1671 */
1672
1673 void
1674 Perl_hv_clear(pTHX_ HV *hv)
1675 {
1676     dVAR;
1677     XPVHV* xhv;
1678     if (!hv)
1679         return;
1680
1681     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1682
1683     xhv = (XPVHV*)SvANY(hv);
1684
1685     ENTER;
1686     SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1687     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1688         /* restricted hash: convert all keys to placeholders */
1689         STRLEN i;
1690         for (i = 0; i <= xhv->xhv_max; i++) {
1691             HE *entry = (HvARRAY(hv))[i];
1692             for (; entry; entry = HeNEXT(entry)) {
1693                 /* not already placeholder */
1694                 if (HeVAL(entry) != &PL_sv_placeholder) {
1695                     if (HeVAL(entry)) {
1696                         if (SvREADONLY(HeVAL(entry))) {
1697                             SV* const keysv = hv_iterkeysv(entry);
1698                             Perl_croak_nocontext(
1699                                 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1700                                 (void*)keysv);
1701                         }
1702                         SvREFCNT_dec_NN(HeVAL(entry));
1703                     }
1704                     HeVAL(entry) = &PL_sv_placeholder;
1705                     HvPLACEHOLDERS(hv)++;
1706                 }
1707             }
1708         }
1709     }
1710     else {
1711         hfreeentries(hv);
1712         HvPLACEHOLDERS_set(hv, 0);
1713
1714         if (SvRMAGICAL(hv))
1715             mg_clear(MUTABLE_SV(hv));
1716
1717         HvHASKFLAGS_off(hv);
1718     }
1719     if (SvOOK(hv)) {
1720         if(HvENAME_get(hv))
1721             mro_isa_changed_in(hv);
1722         HvEITER_set(hv, NULL);
1723     }
1724     LEAVE;
1725 }
1726
1727 /*
1728 =for apidoc hv_clear_placeholders
1729
1730 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1731 marked as readonly and the key is subsequently deleted, the key is not actually
1732 deleted but is marked by assigning it a value of C<&PL_sv_placeholder>.  This tags
1733 it so it will be ignored by future operations such as iterating over the hash,
1734 but will still allow the hash to have a value reassigned to the key at some
1735 future point.  This function clears any such placeholder keys from the hash.
1736 See C<L<Hash::Util::lock_keys()|Hash::Util/lock_keys>> for an example of its
1737 use.
1738
1739 =cut
1740 */
1741
1742 void
1743 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1744 {
1745     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1746
1747     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1748
1749     if (items)
1750         clear_placeholders(hv, items);
1751 }
1752
1753 static void
1754 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1755 {
1756     dVAR;
1757     I32 i;
1758
1759     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1760
1761     if (items == 0)
1762         return;
1763
1764     i = HvMAX(hv);
1765     do {
1766         /* Loop down the linked list heads  */
1767         HE **oentry = &(HvARRAY(hv))[i];
1768         HE *entry;
1769
1770         while ((entry = *oentry)) {
1771             if (HeVAL(entry) == &PL_sv_placeholder) {
1772                 *oentry = HeNEXT(entry);
1773                 if (entry == HvEITER_get(hv))
1774                     HvLAZYDEL_on(hv);
1775                 else {
1776                     if (SvOOK(hv) && HvLAZYDEL(hv) &&
1777                         entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1778                         HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1779                     hv_free_ent(hv, entry);
1780                 }
1781
1782                 if (--items == 0) {
1783                     /* Finished.  */
1784                     I32 placeholders = HvPLACEHOLDERS_get(hv);
1785                     HvTOTALKEYS(hv) -= (IV)placeholders;
1786                     /* HvUSEDKEYS expanded */
1787                     if ((HvTOTALKEYS(hv) - placeholders) == 0)
1788                         HvHASKFLAGS_off(hv);
1789                     HvPLACEHOLDERS_set(hv, 0);
1790                     return;
1791                 }
1792             } else {
1793                 oentry = &HeNEXT(entry);
1794             }
1795         }
1796     } while (--i >= 0);
1797     /* You can't get here, hence assertion should always fail.  */
1798     assert (items == 0);
1799     NOT_REACHED; /* NOTREACHED */
1800 }
1801
1802 STATIC void
1803 S_hfreeentries(pTHX_ HV *hv)
1804 {
1805     STRLEN index = 0;
1806     XPVHV * const xhv = (XPVHV*)SvANY(hv);
1807     SV *sv;
1808
1809     PERL_ARGS_ASSERT_HFREEENTRIES;
1810
1811     while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
1812         SvREFCNT_dec(sv);
1813     }
1814 }
1815
1816
1817 /* hfree_next_entry()
1818  * For use only by S_hfreeentries() and sv_clear().
1819  * Delete the next available HE from hv and return the associated SV.
1820  * Returns null on empty hash. Nevertheless null is not a reliable
1821  * indicator that the hash is empty, as the deleted entry may have a
1822  * null value.
1823  * indexp is a pointer to the current index into HvARRAY. The index should
1824  * initially be set to 0. hfree_next_entry() may update it.  */
1825
1826 SV*
1827 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1828 {
1829     struct xpvhv_aux *iter;
1830     HE *entry;
1831     HE ** array;
1832 #ifdef DEBUGGING
1833     STRLEN orig_index = *indexp;
1834 #endif
1835
1836     PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1837
1838     if (SvOOK(hv) && ((iter = HvAUX(hv)))) {
1839         if ((entry = iter->xhv_eiter)) {
1840             /* the iterator may get resurrected after each
1841              * destructor call, so check each time */
1842             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1843                 HvLAZYDEL_off(hv);
1844                 hv_free_ent(hv, entry);
1845                 /* warning: at this point HvARRAY may have been
1846                  * re-allocated, HvMAX changed etc */
1847             }
1848             iter = HvAUX(hv); /* may have been realloced */
1849             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1850             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1851 #ifdef PERL_HASH_RANDOMIZE_KEYS
1852             iter->xhv_last_rand = iter->xhv_rand;
1853 #endif
1854         }
1855         /* Reset any cached HvFILL() to "unknown".  It's unlikely that anyone
1856            will actually call HvFILL() on a hash under destruction, so it
1857            seems pointless attempting to track the number of keys remaining.
1858            But if they do, we want to reset it again.  */
1859         if (iter->xhv_fill_lazy)
1860             iter->xhv_fill_lazy = 0;
1861     }
1862
1863     if (!((XPVHV*)SvANY(hv))->xhv_keys)
1864         return NULL;
1865
1866     array = HvARRAY(hv);
1867     assert(array);
1868     while ( ! ((entry = array[*indexp])) ) {
1869         if ((*indexp)++ >= HvMAX(hv))
1870             *indexp = 0;
1871         assert(*indexp != orig_index);
1872     }
1873     array[*indexp] = HeNEXT(entry);
1874     ((XPVHV*) SvANY(hv))->xhv_keys--;
1875
1876     if (   PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
1877         && HeVAL(entry) && isGV(HeVAL(entry))
1878         && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
1879     ) {
1880         STRLEN klen;
1881         const char * const key = HePV(entry,klen);
1882         if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
1883          || (klen == 1 && key[0] == ':')) {
1884             mro_package_moved(
1885              NULL, GvHV(HeVAL(entry)),
1886              (GV *)HeVAL(entry), 0
1887             );
1888         }
1889     }
1890     return hv_free_ent_ret(hv, entry);
1891 }
1892
1893
1894 /*
1895 =for apidoc hv_undef
1896
1897 Undefines the hash.  The XS equivalent of C<undef(%hash)>.
1898
1899 As well as freeing all the elements of the hash (like C<hv_clear()>), this
1900 also frees any auxiliary data and storage associated with the hash.
1901
1902 See L</av_clear> for a note about the hash possibly being invalid on
1903 return.
1904
1905 =cut
1906 */
1907
1908 void
1909 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1910 {
1911     XPVHV* xhv;
1912     bool save;
1913
1914     if (!hv)
1915         return;
1916     save = !!SvREFCNT(hv);
1917     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1918     xhv = (XPVHV*)SvANY(hv);
1919
1920     /* The name must be deleted before the call to hfreeeeentries so that
1921        CVs are anonymised properly. But the effective name must be pre-
1922        served until after that call (and only deleted afterwards if the
1923        call originated from sv_clear). For stashes with one name that is
1924        both the canonical name and the effective name, hv_name_set has to
1925        allocate an array for storing the effective name. We can skip that
1926        during global destruction, as it does not matter where the CVs point
1927        if they will be freed anyway. */
1928     /* note that the code following prior to hfreeentries is duplicated
1929      * in sv_clear(), and changes here should be done there too */
1930     if (PL_phase != PERL_PHASE_DESTRUCT && HvNAME(hv)) {
1931         if (PL_stashcache) {
1932             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
1933                              HEKf"'\n", HEKfARG(HvNAME_HEK(hv))));
1934             (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
1935         }
1936         hv_name_set(hv, NULL, 0, 0);
1937     }
1938     if (save) {
1939         ENTER;
1940         SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1941     }
1942     hfreeentries(hv);
1943     if (SvOOK(hv)) {
1944       struct mro_meta *meta;
1945       const char *name;
1946
1947       if (HvENAME_get(hv)) {
1948         if (PL_phase != PERL_PHASE_DESTRUCT)
1949             mro_isa_changed_in(hv);
1950         if (PL_stashcache) {
1951             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
1952                              HEKf"'\n", HEKfARG(HvENAME_HEK(hv))));
1953             (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD);
1954         }
1955       }
1956
1957       /* If this call originated from sv_clear, then we must check for
1958        * effective names that need freeing, as well as the usual name. */
1959       name = HvNAME(hv);
1960       if (flags & HV_NAME_SETALL ? !!HvAUX(hv)->xhv_name_u.xhvnameu_name : !!name) {
1961         if (name && PL_stashcache) {
1962             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
1963                              HEKf"'\n", HEKfARG(HvNAME_HEK(hv))));
1964             (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
1965         }
1966         hv_name_set(hv, NULL, 0, flags);
1967       }
1968       if((meta = HvAUX(hv)->xhv_mro_meta)) {
1969         if (meta->mro_linear_all) {
1970             SvREFCNT_dec_NN(meta->mro_linear_all);
1971             /* mro_linear_current is just acting as a shortcut pointer,
1972                hence the else.  */
1973         }
1974         else
1975             /* Only the current MRO is stored, so this owns the data.
1976              */
1977             SvREFCNT_dec(meta->mro_linear_current);
1978         SvREFCNT_dec(meta->mro_nextmethod);
1979         SvREFCNT_dec(meta->isa);
1980         SvREFCNT_dec(meta->super);
1981         Safefree(meta);
1982         HvAUX(hv)->xhv_mro_meta = NULL;
1983       }
1984       if (!HvAUX(hv)->xhv_name_u.xhvnameu_name && ! HvAUX(hv)->xhv_backreferences)
1985         SvFLAGS(hv) &= ~SVf_OOK;
1986     }
1987     if (!SvOOK(hv)) {
1988         Safefree(HvARRAY(hv));
1989         xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX;        /* HvMAX(hv) = 7 (it's a normal hash) */
1990         HvARRAY(hv) = 0;
1991     }
1992     /* if we're freeing the HV, the SvMAGIC field has been reused for
1993      * other purposes, and so there can't be any placeholder magic */
1994     if (SvREFCNT(hv))
1995         HvPLACEHOLDERS_set(hv, 0);
1996
1997     if (SvRMAGICAL(hv))
1998         mg_clear(MUTABLE_SV(hv));
1999     if (save) LEAVE;
2000 }
2001
2002 /*
2003 =for apidoc hv_fill
2004
2005 Returns the number of hash buckets that
2006 happen to be in use.  This function is
2007 wrapped by the macro C<HvFILL>.
2008
2009 Previously this value was always stored in the HV structure, which created an
2010 overhead on every hash (and pretty much every object) for something that was
2011 rarely used.  Now we calculate it on demand the first
2012 time that it is needed, and cache it if that calculation
2013 is going to be costly to repeat.  The cached
2014 value is updated by insertions and deletions, but (currently) discarded if
2015 the hash is split.
2016
2017 =cut
2018 */
2019
2020 STRLEN
2021 Perl_hv_fill(pTHX_ HV *const hv)
2022 {
2023     STRLEN count = 0;
2024     HE **ents = HvARRAY(hv);
2025     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : NULL;
2026
2027     PERL_ARGS_ASSERT_HV_FILL;
2028
2029     /* No keys implies no buckets used.
2030        One key can only possibly mean one bucket used.  */
2031     if (HvTOTALKEYS(hv) < 2)
2032         return HvTOTALKEYS(hv);
2033
2034 #ifndef DEBUGGING
2035     if (aux && aux->xhv_fill_lazy)
2036         return aux->xhv_fill_lazy;
2037 #endif
2038
2039     if (ents) {
2040         HE *const *const last = ents + HvMAX(hv);
2041         count = last + 1 - ents;
2042
2043         do {
2044             if (!*ents)
2045                 --count;
2046         } while (++ents <= last);
2047     }
2048     if (aux) {
2049 #ifdef DEBUGGING
2050         if (aux->xhv_fill_lazy)
2051             assert(aux->xhv_fill_lazy == count);
2052 #endif
2053         aux->xhv_fill_lazy = count;
2054     } else if (HvMAX(hv) >= HV_FILL_THRESHOLD) {
2055         aux = hv_auxinit(hv);
2056         aux->xhv_fill_lazy = count;
2057     }        
2058     return count;
2059 }
2060
2061 /* hash a pointer to a U32 - Used in the hash traversal randomization
2062  * and bucket order randomization code
2063  *
2064  * this code was derived from Sereal, which was derived from autobox.
2065  */
2066
2067 PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
2068 #if PTRSIZE == 8
2069     /*
2070      * This is one of Thomas Wang's hash functions for 64-bit integers from:
2071      * http://www.concentric.net/~Ttwang/tech/inthash.htm
2072      */
2073     u = (~u) + (u << 18);
2074     u = u ^ (u >> 31);
2075     u = u * 21;
2076     u = u ^ (u >> 11);
2077     u = u + (u << 6);
2078     u = u ^ (u >> 22);
2079 #else
2080     /*
2081      * This is one of Bob Jenkins' hash functions for 32-bit integers
2082      * from: http://burtleburtle.net/bob/hash/integer.html
2083      */
2084     u = (u + 0x7ed55d16) + (u << 12);
2085     u = (u ^ 0xc761c23c) ^ (u >> 19);
2086     u = (u + 0x165667b1) + (u << 5);
2087     u = (u + 0xd3a2646c) ^ (u << 9);
2088     u = (u + 0xfd7046c5) + (u << 3);
2089     u = (u ^ 0xb55a4f09) ^ (u >> 16);
2090 #endif
2091     return (U32)u;
2092 }
2093
2094 static struct xpvhv_aux*
2095 S_hv_auxinit_internal(struct xpvhv_aux *iter) {
2096     PERL_ARGS_ASSERT_HV_AUXINIT_INTERNAL;
2097     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
2098     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
2099 #ifdef PERL_HASH_RANDOMIZE_KEYS
2100     iter->xhv_last_rand = iter->xhv_rand;
2101 #endif
2102     iter->xhv_fill_lazy = 0;
2103     iter->xhv_name_u.xhvnameu_name = 0;
2104     iter->xhv_name_count = 0;
2105     iter->xhv_backreferences = 0;
2106     iter->xhv_mro_meta = NULL;
2107     iter->xhv_aux_flags = 0;
2108     return iter;
2109 }
2110
2111
2112 static struct xpvhv_aux*
2113 S_hv_auxinit(pTHX_ HV *hv) {
2114     struct xpvhv_aux *iter;
2115     char *array;
2116
2117     PERL_ARGS_ASSERT_HV_AUXINIT;
2118
2119     if (!SvOOK(hv)) {
2120         if (!HvARRAY(hv)) {
2121             Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
2122                 + sizeof(struct xpvhv_aux), char);
2123         } else {
2124             array = (char *) HvARRAY(hv);
2125             Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
2126                   + sizeof(struct xpvhv_aux), char);
2127         }
2128         HvARRAY(hv) = (HE**)array;
2129         SvOOK_on(hv);
2130         iter = HvAUX(hv);
2131 #ifdef PERL_HASH_RANDOMIZE_KEYS
2132         if (PL_HASH_RAND_BITS_ENABLED) {
2133             /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
2134             if (PL_HASH_RAND_BITS_ENABLED == 1)
2135                 PL_hash_rand_bits += ptr_hash((PTRV)array);
2136             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
2137         }
2138         iter->xhv_rand = (U32)PL_hash_rand_bits;
2139 #endif
2140     } else {
2141         iter = HvAUX(hv);
2142     }
2143
2144     return hv_auxinit_internal(iter);
2145 }
2146
2147 /*
2148 =for apidoc hv_iterinit
2149
2150 Prepares a starting point to traverse a hash table.  Returns the number of
2151 keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>).  The return value is
2152 currently only meaningful for hashes without tie magic.
2153
2154 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
2155 hash buckets that happen to be in use.  If you still need that esoteric
2156 value, you can get it through the macro C<HvFILL(hv)>.
2157
2158
2159 =cut
2160 */
2161
2162 I32
2163 Perl_hv_iterinit(pTHX_ HV *hv)
2164 {
2165     PERL_ARGS_ASSERT_HV_ITERINIT;
2166
2167     if (SvOOK(hv)) {
2168         struct xpvhv_aux * iter = HvAUX(hv);
2169         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2170         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
2171             HvLAZYDEL_off(hv);
2172             hv_free_ent(hv, entry);
2173         }
2174         iter = HvAUX(hv); /* may have been reallocated */
2175         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
2176         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2177 #ifdef PERL_HASH_RANDOMIZE_KEYS
2178         iter->xhv_last_rand = iter->xhv_rand;
2179 #endif
2180     } else {
2181         hv_auxinit(hv);
2182     }
2183
2184     /* used to be xhv->xhv_fill before 5.004_65 */
2185     return HvTOTALKEYS(hv);
2186 }
2187
2188 I32 *
2189 Perl_hv_riter_p(pTHX_ HV *hv) {
2190     struct xpvhv_aux *iter;
2191
2192     PERL_ARGS_ASSERT_HV_RITER_P;
2193
2194     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2195     return &(iter->xhv_riter);
2196 }
2197
2198 HE **
2199 Perl_hv_eiter_p(pTHX_ HV *hv) {
2200     struct xpvhv_aux *iter;
2201
2202     PERL_ARGS_ASSERT_HV_EITER_P;
2203
2204     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2205     return &(iter->xhv_eiter);
2206 }
2207
2208 void
2209 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2210     struct xpvhv_aux *iter;
2211
2212     PERL_ARGS_ASSERT_HV_RITER_SET;
2213
2214     if (SvOOK(hv)) {
2215         iter = HvAUX(hv);
2216     } else {
2217         if (riter == -1)
2218             return;
2219
2220         iter = hv_auxinit(hv);
2221     }
2222     iter->xhv_riter = riter;
2223 }
2224
2225 void
2226 Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2227     struct xpvhv_aux *iter;
2228
2229     PERL_ARGS_ASSERT_HV_RAND_SET;
2230
2231 #ifdef PERL_HASH_RANDOMIZE_KEYS
2232     if (SvOOK(hv)) {
2233         iter = HvAUX(hv);
2234     } else {
2235         iter = hv_auxinit(hv);
2236     }
2237     iter->xhv_rand = new_xhv_rand;
2238 #else
2239     Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2240 #endif
2241 }
2242
2243 void
2244 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2245     struct xpvhv_aux *iter;
2246
2247     PERL_ARGS_ASSERT_HV_EITER_SET;
2248
2249     if (SvOOK(hv)) {
2250         iter = HvAUX(hv);
2251     } else {
2252         /* 0 is the default so don't go malloc()ing a new structure just to
2253            hold 0.  */
2254         if (!eiter)
2255             return;
2256
2257         iter = hv_auxinit(hv);
2258     }
2259     iter->xhv_eiter = eiter;
2260 }
2261
2262 void
2263 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2264 {
2265     dVAR;
2266     struct xpvhv_aux *iter;
2267     U32 hash;
2268     HEK **spot;
2269
2270     PERL_ARGS_ASSERT_HV_NAME_SET;
2271
2272     if (len > I32_MAX)
2273         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2274
2275     if (SvOOK(hv)) {
2276         iter = HvAUX(hv);
2277         if (iter->xhv_name_u.xhvnameu_name) {
2278             if(iter->xhv_name_count) {
2279               if(flags & HV_NAME_SETALL) {
2280                 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2281                 HEK **hekp = name + (
2282                     iter->xhv_name_count < 0
2283                      ? -iter->xhv_name_count
2284                      :  iter->xhv_name_count
2285                    );
2286                 while(hekp-- > name+1) 
2287                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2288                 /* The first elem may be null. */
2289                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2290                 Safefree(name);
2291                 iter = HvAUX(hv); /* may been realloced */
2292                 spot = &iter->xhv_name_u.xhvnameu_name;
2293                 iter->xhv_name_count = 0;
2294               }
2295               else {
2296                 if(iter->xhv_name_count > 0) {
2297                     /* shift some things over */
2298                     Renew(
2299                      iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2300                     );
2301                     spot = iter->xhv_name_u.xhvnameu_names;
2302                     spot[iter->xhv_name_count] = spot[1];
2303                     spot[1] = spot[0];
2304                     iter->xhv_name_count = -(iter->xhv_name_count + 1);
2305                 }
2306                 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2307                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2308                 }
2309               }
2310             }
2311             else if (flags & HV_NAME_SETALL) {
2312                 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2313                 iter = HvAUX(hv); /* may been realloced */
2314                 spot = &iter->xhv_name_u.xhvnameu_name;
2315             }
2316             else {
2317                 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2318                 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2319                 iter->xhv_name_count = -2;
2320                 spot = iter->xhv_name_u.xhvnameu_names;
2321                 spot[1] = existing_name;
2322             }
2323         }
2324         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2325     } else {
2326         if (name == 0)
2327             return;
2328
2329         iter = hv_auxinit(hv);
2330         spot = &iter->xhv_name_u.xhvnameu_name;
2331     }
2332     PERL_HASH(hash, name, len);
2333     *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2334 }
2335
2336 /*
2337 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2338 and bytes checking.
2339 */
2340
2341 STATIC I32
2342 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2343     if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2344         if (flags & SVf_UTF8)
2345             return (bytes_cmp_utf8(
2346                         (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2347                         (const U8*)pv, pvlen) == 0);
2348         else
2349             return (bytes_cmp_utf8(
2350                         (const U8*)pv, pvlen,
2351                         (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2352     }
2353     else
2354         return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2355                     || memEQ(HEK_KEY(hek), pv, pvlen));
2356 }
2357
2358 /*
2359 =for apidoc hv_ename_add
2360
2361 Adds a name to a stash's internal list of effective names.  See
2362 C<L</hv_ename_delete>>.
2363
2364 This is called when a stash is assigned to a new location in the symbol
2365 table.
2366
2367 =cut
2368 */
2369
2370 void
2371 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2372 {
2373     dVAR;
2374     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2375     U32 hash;
2376
2377     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2378
2379     if (len > I32_MAX)
2380         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2381
2382     PERL_HASH(hash, name, len);
2383
2384     if (aux->xhv_name_count) {
2385         I32 count = aux->xhv_name_count;
2386         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0);
2387         HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count);
2388         while (hekp-- > xhv_name)
2389         {
2390             assert(*hekp);
2391             if (
2392                  (HEK_UTF8(*hekp) || (flags & SVf_UTF8)) 
2393                     ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2394                     : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2395                ) {
2396                 if (hekp == xhv_name && count < 0)
2397                     aux->xhv_name_count = -count;
2398                 return;
2399             }
2400         }
2401         if (count < 0) aux->xhv_name_count--, count = -count;
2402         else aux->xhv_name_count++;
2403         Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2404         (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2405     }
2406     else {
2407         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2408         if (
2409             existing_name && (
2410              (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2411                 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2412                 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2413             )
2414         ) return;
2415         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2416         aux->xhv_name_count = existing_name ? 2 : -2;
2417         *aux->xhv_name_u.xhvnameu_names = existing_name;
2418         (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2419     }
2420 }
2421
2422 /*
2423 =for apidoc hv_ename_delete
2424
2425 Removes a name from a stash's internal list of effective names.  If this is
2426 the name returned by C<HvENAME>, then another name in the list will take
2427 its place (C<HvENAME> will use it).
2428
2429 This is called when a stash is deleted from the symbol table.
2430
2431 =cut
2432 */
2433
2434 void
2435 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2436 {
2437     struct xpvhv_aux *aux;
2438
2439     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2440
2441     if (len > I32_MAX)
2442         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2443
2444     if (!SvOOK(hv)) return;
2445
2446     aux = HvAUX(hv);
2447     if (!aux->xhv_name_u.xhvnameu_name) return;
2448
2449     if (aux->xhv_name_count) {
2450         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2451         I32 const count = aux->xhv_name_count;
2452         HEK **victim = namep + (count < 0 ? -count : count);
2453         while (victim-- > namep + 1)
2454             if (
2455              (HEK_UTF8(*victim) || (flags & SVf_UTF8)) 
2456                 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2457                 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2458             ) {
2459                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2460                 aux = HvAUX(hv); /* may been realloced */
2461                 if (count < 0) ++aux->xhv_name_count;
2462                 else --aux->xhv_name_count;
2463                 if (
2464                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2465                  && !*namep
2466                 ) {  /* if there are none left */
2467                     Safefree(namep);
2468                     aux->xhv_name_u.xhvnameu_names = NULL;
2469                     aux->xhv_name_count = 0;
2470                 }
2471                 else {
2472                     /* Move the last one back to fill the empty slot. It
2473                        does not matter what order they are in. */
2474                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2475                 }
2476                 return;
2477             }
2478         if (
2479             count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8)) 
2480                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2481                 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2482             )
2483         ) {
2484             aux->xhv_name_count = -count;
2485         }
2486     }
2487     else if(
2488         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) 
2489                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2490                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2491                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2492     ) {
2493         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2494         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2495         *aux->xhv_name_u.xhvnameu_names = namehek;
2496         aux->xhv_name_count = -1;
2497     }
2498 }
2499
2500 AV **
2501 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2502     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2503     /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
2504     {
2505         struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2506         return &(iter->xhv_backreferences);
2507     }
2508 }
2509
2510 void
2511 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2512     AV *av;
2513
2514     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2515
2516     if (!SvOOK(hv))
2517         return;
2518
2519     av = HvAUX(hv)->xhv_backreferences;
2520
2521     if (av) {
2522         HvAUX(hv)->xhv_backreferences = 0;
2523         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2524         if (SvTYPE(av) == SVt_PVAV)
2525             SvREFCNT_dec_NN(av);
2526     }
2527 }
2528
2529 /*
2530 hv_iternext is implemented as a macro in hv.h
2531
2532 =for apidoc hv_iternext
2533
2534 Returns entries from a hash iterator.  See C<L</hv_iterinit>>.
2535
2536 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2537 iterator currently points to, without losing your place or invalidating your
2538 iterator.  Note that in this case the current entry is deleted from the hash
2539 with your iterator holding the last reference to it.  Your iterator is flagged
2540 to free the entry on the next call to C<hv_iternext>, so you must not discard
2541 your iterator immediately else the entry will leak - call C<hv_iternext> to
2542 trigger the resource deallocation.
2543
2544 =for apidoc hv_iternext_flags
2545
2546 Returns entries from a hash iterator.  See C<L</hv_iterinit>> and
2547 C<L</hv_iternext>>.
2548 The C<flags> value will normally be zero; if C<HV_ITERNEXT_WANTPLACEHOLDERS> is
2549 set the placeholders keys (for restricted hashes) will be returned in addition
2550 to normal keys.  By default placeholders are automatically skipped over.
2551 Currently a placeholder is implemented with a value that is
2552 C<&PL_sv_placeholder>.  Note that the implementation of placeholders and
2553 restricted hashes may change, and the implementation currently is
2554 insufficiently abstracted for any change to be tidy.
2555
2556 =cut
2557 */
2558
2559 HE *
2560 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2561 {
2562     dVAR;
2563     XPVHV* xhv;
2564     HE *entry;
2565     HE *oldentry;
2566     MAGIC* mg;
2567     struct xpvhv_aux *iter;
2568
2569     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2570
2571     xhv = (XPVHV*)SvANY(hv);
2572
2573     if (!SvOOK(hv)) {
2574         /* Too many things (well, pp_each at least) merrily assume that you can
2575            call hv_iternext without calling hv_iterinit, so we'll have to deal
2576            with it.  */
2577         hv_iterinit(hv);
2578     }
2579     iter = HvAUX(hv);
2580
2581     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2582     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2583         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2584             SV * const key = sv_newmortal();
2585             if (entry) {
2586                 sv_setsv(key, HeSVKEY_force(entry));
2587                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2588                 HeSVKEY_set(entry, NULL);
2589             }
2590             else {
2591                 char *k;
2592                 HEK *hek;
2593
2594                 /* one HE per MAGICAL hash */
2595                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2596                 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2597                 Zero(entry, 1, HE);
2598                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2599                 hek = (HEK*)k;
2600                 HeKEY_hek(entry) = hek;
2601                 HeKLEN(entry) = HEf_SVKEY;
2602             }
2603             magic_nextpack(MUTABLE_SV(hv),mg,key);
2604             if (SvOK(key)) {
2605                 /* force key to stay around until next time */
2606                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2607                 return entry;               /* beware, hent_val is not set */
2608             }
2609             SvREFCNT_dec(HeVAL(entry));
2610             Safefree(HeKEY_hek(entry));
2611             del_HE(entry);
2612             iter = HvAUX(hv); /* may been realloced */
2613             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2614             HvLAZYDEL_off(hv);
2615             return NULL;
2616         }
2617     }
2618 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2619     if (!entry && SvRMAGICAL((const SV *)hv)
2620         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2621         prime_env_iter();
2622 #ifdef VMS
2623         /* The prime_env_iter() on VMS just loaded up new hash values
2624          * so the iteration count needs to be reset back to the beginning
2625          */
2626         hv_iterinit(hv);
2627         iter = HvAUX(hv);
2628         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2629 #endif
2630     }
2631 #endif
2632
2633     /* hv_iterinit now ensures this.  */
2634     assert (HvARRAY(hv));
2635
2636     /* At start of hash, entry is NULL.  */
2637     if (entry)
2638     {
2639         entry = HeNEXT(entry);
2640         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2641             /*
2642              * Skip past any placeholders -- don't want to include them in
2643              * any iteration.
2644              */
2645             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2646                 entry = HeNEXT(entry);
2647             }
2648         }
2649     }
2650
2651 #ifdef PERL_HASH_RANDOMIZE_KEYS
2652     if (iter->xhv_last_rand != iter->xhv_rand) {
2653         if (iter->xhv_riter != -1) {
2654             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2655                              "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2656                              pTHX__FORMAT
2657                              pTHX__VALUE);
2658         }
2659         iter = HvAUX(hv); /* may been realloced */
2660         iter->xhv_last_rand = iter->xhv_rand;
2661     }
2662 #endif
2663
2664     /* Skip the entire loop if the hash is empty.   */
2665     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2666         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2667         while (!entry) {
2668             /* OK. Come to the end of the current list.  Grab the next one.  */
2669
2670             iter->xhv_riter++; /* HvRITER(hv)++ */
2671             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2672                 /* There is no next one.  End of the hash.  */
2673                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2674 #ifdef PERL_HASH_RANDOMIZE_KEYS
2675                 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2676 #endif
2677                 break;
2678             }
2679             entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2680
2681             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2682                 /* If we have an entry, but it's a placeholder, don't count it.
2683                    Try the next.  */
2684                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2685                     entry = HeNEXT(entry);
2686             }
2687             /* Will loop again if this linked list starts NULL
2688                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2689                or if we run through it and find only placeholders.  */
2690         }
2691     }
2692     else {
2693         iter->xhv_riter = -1;
2694 #ifdef PERL_HASH_RANDOMIZE_KEYS
2695         iter->xhv_last_rand = iter->xhv_rand;
2696 #endif
2697     }
2698
2699     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2700         HvLAZYDEL_off(hv);
2701         hv_free_ent(hv, oldentry);
2702     }
2703
2704     iter = HvAUX(hv); /* may been realloced */
2705     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2706     return entry;
2707 }
2708
2709 /*
2710 =for apidoc hv_iterkey
2711
2712 Returns the key from the current position of the hash iterator.  See
2713 C<L</hv_iterinit>>.
2714
2715 =cut
2716 */
2717
2718 char *
2719 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2720 {
2721     PERL_ARGS_ASSERT_HV_ITERKEY;
2722
2723     if (HeKLEN(entry) == HEf_SVKEY) {
2724         STRLEN len;
2725         char * const p = SvPV(HeKEY_sv(entry), len);
2726         *retlen = len;
2727         return p;
2728     }
2729     else {
2730         *retlen = HeKLEN(entry);
2731         return HeKEY(entry);
2732     }
2733 }
2734
2735 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2736 /*
2737 =for apidoc hv_iterkeysv
2738
2739 Returns the key as an C<SV*> from the current position of the hash
2740 iterator.  The return value will always be a mortal copy of the key.  Also
2741 see C<L</hv_iterinit>>.
2742
2743 =cut
2744 */
2745
2746 SV *
2747 Perl_hv_iterkeysv(pTHX_ HE *entry)
2748 {
2749     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2750
2751     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2752 }
2753
2754 /*
2755 =for apidoc hv_iterval
2756
2757 Returns the value from the current position of the hash iterator.  See
2758 C<L</hv_iterkey>>.
2759
2760 =cut
2761 */
2762
2763 SV *
2764 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2765 {
2766     PERL_ARGS_ASSERT_HV_ITERVAL;
2767
2768     if (SvRMAGICAL(hv)) {
2769         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2770             SV* const sv = sv_newmortal();
2771             if (HeKLEN(entry) == HEf_SVKEY)
2772                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2773             else
2774                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2775             return sv;
2776         }
2777     }
2778     return HeVAL(entry);
2779 }
2780
2781 /*
2782 =for apidoc hv_iternextsv
2783
2784 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2785 operation.
2786
2787 =cut
2788 */
2789
2790 SV *
2791 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2792 {
2793     HE * const he = hv_iternext_flags(hv, 0);
2794
2795     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2796
2797     if (!he)
2798         return NULL;
2799     *key = hv_iterkey(he, retlen);
2800     return hv_iterval(hv, he);
2801 }
2802
2803 /*
2804
2805 Now a macro in hv.h
2806
2807 =for apidoc hv_magic
2808
2809 Adds magic to a hash.  See C<L</sv_magic>>.
2810
2811 =cut
2812 */
2813
2814 /* possibly free a shared string if no one has access to it
2815  * len and hash must both be valid for str.
2816  */
2817 void
2818 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2819 {
2820     unshare_hek_or_pvn (NULL, str, len, hash);
2821 }
2822
2823
2824 void
2825 Perl_unshare_hek(pTHX_ HEK *hek)
2826 {
2827     assert(hek);
2828     unshare_hek_or_pvn(hek, NULL, 0, 0);
2829 }
2830
2831 /* possibly free a shared string if no one has access to it
2832    hek if non-NULL takes priority over the other 3, else str, len and hash
2833    are used.  If so, len and hash must both be valid for str.
2834  */
2835 STATIC void
2836 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2837 {
2838     XPVHV* xhv;
2839     HE *entry;
2840     HE **oentry;
2841     bool is_utf8 = FALSE;
2842     int k_flags = 0;
2843     const char * const save = str;
2844     struct shared_he *he = NULL;
2845
2846     if (hek) {
2847         /* Find the shared he which is just before us in memory.  */
2848         he = (struct shared_he *)(((char *)hek)
2849                                   - STRUCT_OFFSET(struct shared_he,
2850                                                   shared_he_hek));
2851
2852         /* Assert that the caller passed us a genuine (or at least consistent)
2853            shared hek  */
2854         assert (he->shared_he_he.hent_hek == hek);
2855
2856         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2857             --he->shared_he_he.he_valu.hent_refcount;
2858             return;
2859         }
2860
2861         hash = HEK_HASH(hek);
2862     } else if (len < 0) {
2863         STRLEN tmplen = -len;
2864         is_utf8 = TRUE;
2865         /* See the note in hv_fetch(). --jhi */
2866         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2867         len = tmplen;
2868         if (is_utf8)
2869             k_flags = HVhek_UTF8;
2870         if (str != save)
2871             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2872     }
2873
2874     /* what follows was the moral equivalent of:
2875     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2876         if (--*Svp == NULL)
2877             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2878     } */
2879     xhv = (XPVHV*)SvANY(PL_strtab);
2880     /* assert(xhv_array != 0) */
2881     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2882     if (he) {
2883         const HE *const he_he = &(he->shared_he_he);
2884         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2885             if (entry == he_he)
2886                 break;
2887         }
2888     } else {
2889         const int flags_masked = k_flags & HVhek_MASK;
2890         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2891             if (HeHASH(entry) != hash)          /* strings can't be equal */
2892                 continue;
2893             if (HeKLEN(entry) != len)
2894                 continue;
2895             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2896                 continue;
2897             if (HeKFLAGS(entry) != flags_masked)
2898                 continue;
2899             break;
2900         }
2901     }
2902
2903     if (entry) {
2904         if (--entry->he_valu.hent_refcount == 0) {
2905             *oentry = HeNEXT(entry);
2906             Safefree(entry);
2907             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2908         }
2909     }
2910
2911     if (!entry)
2912         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2913                          "Attempt to free nonexistent shared string '%s'%s"
2914                          pTHX__FORMAT,
2915                          hek ? HEK_KEY(hek) : str,
2916                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2917     if (k_flags & HVhek_FREEKEY)
2918         Safefree(str);
2919 }
2920
2921 /* get a (constant) string ptr from the global string table
2922  * string will get added if it is not already there.
2923  * len and hash must both be valid for str.
2924  */
2925 HEK *
2926 Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
2927 {
2928     bool is_utf8 = FALSE;
2929     int flags = 0;
2930     const char * const save = str;
2931
2932     PERL_ARGS_ASSERT_SHARE_HEK;
2933
2934     if (len < 0) {
2935       STRLEN tmplen = -len;
2936       is_utf8 = TRUE;
2937       /* See the note in hv_fetch(). --jhi */
2938       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2939       len = tmplen;
2940       /* If we were able to downgrade here, then than means that we were passed
2941          in a key which only had chars 0-255, but was utf8 encoded.  */
2942       if (is_utf8)
2943           flags = HVhek_UTF8;
2944       /* If we found we were able to downgrade the string to bytes, then
2945          we should flag that it needs upgrading on keys or each.  Also flag
2946          that we need share_hek_flags to free the string.  */
2947       if (str != save) {
2948           dVAR;
2949           PERL_HASH(hash, str, len);
2950           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2951       }
2952     }
2953
2954     return share_hek_flags (str, len, hash, flags);
2955 }
2956
2957 STATIC HEK *
2958 S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
2959 {
2960     HE *entry;
2961     const int flags_masked = flags & HVhek_MASK;
2962     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2963     XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2964
2965     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2966
2967     /* what follows is the moral equivalent of:
2968
2969     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2970         hv_store(PL_strtab, str, len, NULL, hash);
2971
2972         Can't rehash the shared string table, so not sure if it's worth
2973         counting the number of entries in the linked list
2974     */
2975
2976     /* assert(xhv_array != 0) */
2977     entry = (HvARRAY(PL_strtab))[hindex];
2978     for (;entry; entry = HeNEXT(entry)) {
2979         if (HeHASH(entry) != hash)              /* strings can't be equal */
2980             continue;
2981         if (HeKLEN(entry) != len)
2982             continue;
2983         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2984             continue;
2985         if (HeKFLAGS(entry) != flags_masked)
2986             continue;
2987         break;
2988     }
2989
2990     if (!entry) {
2991         /* What used to be head of the list.
2992            If this is NULL, then we're the first entry for this slot, which
2993            means we need to increate fill.  */
2994         struct shared_he *new_entry;
2995         HEK *hek;
2996         char *k;
2997         HE **const head = &HvARRAY(PL_strtab)[hindex];
2998         HE *const next = *head;
2999
3000         /* We don't actually store a HE from the arena and a regular HEK.
3001            Instead we allocate one chunk of memory big enough for both,
3002            and put the HEK straight after the HE. This way we can find the
3003            HE directly from the HEK.
3004         */
3005
3006         Newx(k, STRUCT_OFFSET(struct shared_he,
3007                                 shared_he_hek.hek_key[0]) + len + 2, char);
3008         new_entry = (struct shared_he *)k;
3009         entry = &(new_entry->shared_he_he);
3010         hek = &(new_entry->shared_he_hek);
3011
3012         Copy(str, HEK_KEY(hek), len, char);
3013         HEK_KEY(hek)[len] = 0;
3014         HEK_LEN(hek) = len;
3015         HEK_HASH(hek) = hash;
3016         HEK_FLAGS(hek) = (unsigned char)flags_masked;
3017
3018         /* Still "point" to the HEK, so that other code need not know what
3019            we're up to.  */
3020         HeKEY_hek(entry) = hek;
3021         entry->he_valu.hent_refcount = 0;
3022         HeNEXT(entry) = next;
3023         *head = entry;
3024
3025         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
3026         if (!next) {                    /* initial entry? */
3027         } else if ( DO_HSPLIT(xhv) ) {
3028             const STRLEN oldsize = xhv->xhv_max + 1;
3029             hsplit(PL_strtab, oldsize, oldsize * 2);
3030         }
3031     }
3032
3033     ++entry->he_valu.hent_refcount;
3034
3035     if (flags & HVhek_FREEKEY)
3036         Safefree(str);
3037
3038     return HeKEY_hek(entry);
3039 }
3040
3041 SSize_t *
3042 Perl_hv_placeholders_p(pTHX_ HV *hv)
3043 {
3044     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3045
3046     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
3047
3048     if (!mg) {
3049         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
3050
3051         if (!mg) {
3052             Perl_die(aTHX_ "panic: hv_placeholders_p");
3053         }
3054     }
3055     return &(mg->mg_len);
3056 }
3057
3058
3059 I32
3060 Perl_hv_placeholders_get(pTHX_ const HV *hv)
3061 {
3062     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3063
3064     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3065     PERL_UNUSED_CONTEXT;
3066
3067     return mg ? mg->mg_len : 0;
3068 }
3069
3070 void
3071 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3072 {
3073     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3074
3075     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3076
3077     if (mg) {
3078         mg->mg_len = ph;
3079     } else if (ph) {
3080         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3081             Perl_die(aTHX_ "panic: hv_placeholders_set");
3082     }
3083     /* else we don't need to add magic to record 0 placeholders.  */
3084 }
3085
3086 STATIC SV *
3087 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3088 {
3089     dVAR;
3090     SV *value;
3091
3092     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3093
3094     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3095     case HVrhek_undef:
3096         value = newSV(0);
3097         break;
3098     case HVrhek_delete:
3099         value = &PL_sv_placeholder;
3100         break;
3101     case HVrhek_IV:
3102         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3103         break;
3104     case HVrhek_UV:
3105         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3106         break;
3107     case HVrhek_PV:
3108     case HVrhek_PV_UTF8:
3109         /* Create a string SV that directly points to the bytes in our
3110            structure.  */
3111         value = newSV_type(SVt_PV);
3112         SvPV_set(value, (char *) he->refcounted_he_data + 1);
3113         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3114         /* This stops anything trying to free it  */
3115         SvLEN_set(value, 0);
3116         SvPOK_on(value);
3117         SvREADONLY_on(value);
3118         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3119             SvUTF8_on(value);
3120         break;
3121     default:
3122         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
3123                    (UV)he->refcounted_he_data[0]);
3124     }
3125     return value;
3126 }
3127
3128 /*
3129 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
3130
3131 Generates and returns a C<HV *> representing the content of a
3132 C<refcounted_he> chain.
3133 C<flags> is currently unused and must be zero.
3134
3135 =cut
3136 */
3137 HV *
3138 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3139 {
3140     dVAR;
3141     HV *hv;
3142     U32 placeholders, max;
3143
3144     if (flags)
3145         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
3146             (UV)flags);
3147
3148     /* We could chase the chain once to get an idea of the number of keys,
3149        and call ksplit.  But for now we'll make a potentially inefficient
3150        hash with only 8 entries in its array.  */
3151     hv = newHV();
3152     max = HvMAX(hv);
3153     if (!HvARRAY(hv)) {
3154         char *array;
3155         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3156         HvARRAY(hv) = (HE**)array;
3157     }
3158
3159     placeholders = 0;
3160     while (chain) {
3161 #ifdef USE_ITHREADS
3162         U32 hash = chain->refcounted_he_hash;
3163 #else
3164         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3165 #endif
3166         HE **oentry = &((HvARRAY(hv))[hash & max]);
3167         HE *entry = *oentry;
3168         SV *value;
3169
3170         for (; entry; entry = HeNEXT(entry)) {
3171             if (HeHASH(entry) == hash) {
3172                 /* We might have a duplicate key here.  If so, entry is older
3173                    than the key we've already put in the hash, so if they are
3174                    the same, skip adding entry.  */
3175 #ifdef USE_ITHREADS
3176                 const STRLEN klen = HeKLEN(entry);
3177                 const char *const key = HeKEY(entry);
3178                 if (klen == chain->refcounted_he_keylen
3179                     && (!!HeKUTF8(entry)
3180                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3181                     && memEQ(key, REF_HE_KEY(chain), klen))
3182                     goto next_please;
3183 #else
3184                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3185                     goto next_please;
3186                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3187                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3188                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3189                              HeKLEN(entry)))
3190                     goto next_please;
3191 #endif
3192             }
3193         }
3194         assert (!entry);
3195         entry = new_HE();
3196
3197 #ifdef USE_ITHREADS
3198         HeKEY_hek(entry)
3199             = share_hek_flags(REF_HE_KEY(chain),
3200                               chain->refcounted_he_keylen,
3201                               chain->refcounted_he_hash,
3202                               (chain->refcounted_he_data[0]
3203                                & (HVhek_UTF8|HVhek_WASUTF8)));
3204 #else
3205         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3206 #endif
3207         value = refcounted_he_value(chain);
3208         if (value == &PL_sv_placeholder)
3209             placeholders++;
3210         HeVAL(entry) = value;
3211
3212         /* Link it into the chain.  */
3213         HeNEXT(entry) = *oentry;
3214         *oentry = entry;
3215
3216         HvTOTALKEYS(hv)++;
3217
3218     next_please:
3219         chain = chain->refcounted_he_next;
3220     }
3221
3222     if (placeholders) {
3223         clear_placeholders(hv, placeholders);
3224         HvTOTALKEYS(hv) -= placeholders;
3225     }
3226
3227     /* We could check in the loop to see if we encounter any keys with key
3228        flags, but it's probably not worth it, as this per-hash flag is only
3229        really meant as an optimisation for things like Storable.  */
3230     HvHASKFLAGS_on(hv);
3231     DEBUG_A(Perl_hv_assert(aTHX_ hv));
3232
3233     return hv;
3234 }
3235
3236 /*
3237 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
3238
3239 Search along a C<refcounted_he> chain for an entry with the key specified
3240 by C<keypv> and C<keylen>.  If C<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3241 bit set, the key octets are interpreted as UTF-8, otherwise they
3242 are interpreted as Latin-1.  C<hash> is a precomputed hash of the key
3243 string, or zero if it has not been precomputed.  Returns a mortal scalar
3244 representing the value associated with the key, or C<&PL_sv_placeholder>
3245 if there is no value associated with the key.
3246
3247 =cut
3248 */
3249
3250 SV *
3251 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3252                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3253 {
3254     dVAR;
3255     U8 utf8_flag;
3256     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3257
3258     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3259         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
3260             (UV)flags);
3261     if (!chain)
3262         goto ret;
3263     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3264         /* For searching purposes, canonicalise to Latin-1 where possible. */
3265         const char *keyend = keypv + keylen, *p;
3266         STRLEN nonascii_count = 0;
3267         for (p = keypv; p != keyend; p++) {
3268             if (! UTF8_IS_INVARIANT(*p)) {
3269                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3270                     goto canonicalised_key;
3271                 }
3272                 nonascii_count++;
3273                 p++;
3274             }
3275         }
3276         if (nonascii_count) {
3277             char *q;
3278             const char *p = keypv, *keyend = keypv + keylen;
3279             keylen -= nonascii_count;
3280             Newx(q, keylen, char);
3281             SAVEFREEPV(q);
3282             keypv = q;
3283             for (; p != keyend; p++, q++) {
3284                 U8 c = (U8)*p;
3285                 if (UTF8_IS_INVARIANT(c)) {
3286                     *q = (char) c;
3287                 }
3288                 else {
3289                     p++;
3290                     *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3291                 }
3292             }
3293         }
3294         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3295         canonicalised_key: ;
3296     }
3297     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3298     if (!hash)
3299         PERL_HASH(hash, keypv, keylen);
3300
3301     for (; chain; chain = chain->refcounted_he_next) {
3302         if (
3303 #ifdef USE_ITHREADS
3304             hash == chain->refcounted_he_hash &&
3305             keylen == chain->refcounted_he_keylen &&
3306             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3307             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3308 #else
3309             hash == HEK_HASH(chain->refcounted_he_hek) &&
3310             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3311             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3312             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3313 #endif
3314         ) {
3315             if (flags & REFCOUNTED_HE_EXISTS)
3316                 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3317                     == HVrhek_delete
3318                     ? NULL : &PL_sv_yes;
3319             return sv_2mortal(refcounted_he_value(chain));
3320         }
3321     }
3322   ret:
3323     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3324 }
3325
3326 /*
3327 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3328
3329 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3330 instead of a string/length pair.
3331
3332 =cut
3333 */
3334
3335 SV *
3336 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3337                          const char *key, U32 hash, U32 flags)
3338 {
3339     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3340     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3341 }
3342
3343 /*
3344 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3345
3346 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3347 string/length pair.
3348
3349 =cut
3350 */
3351
3352 SV *
3353 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3354                          SV *key, U32 hash, U32 flags)
3355 {
3356     const char *keypv;
3357     STRLEN keylen;
3358     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3359     if (flags & REFCOUNTED_HE_KEY_UTF8)
3360         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3361             (UV)flags);
3362     keypv = SvPV_const(key, keylen);
3363     if (SvUTF8(key))
3364         flags |= REFCOUNTED_HE_KEY_UTF8;
3365     if (!hash && SvIsCOW_shared_hash(key))
3366         hash = SvSHARED_HASH(key);
3367     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3368 }
3369
3370 /*
3371 =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
3372
3373 Creates a new C<refcounted_he>.  This consists of a single key/value
3374 pair and a reference to an existing C<refcounted_he> chain (which may
3375 be empty), and thus forms a longer chain.  When using the longer chain,
3376 the new key/value pair takes precedence over any entry for the same key
3377 further along the chain.
3378
3379 The new key is specified by C<keypv> and C<keylen>.  If C<flags> has
3380 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3381 as UTF-8, otherwise they are interpreted as Latin-1.  C<hash> is
3382 a precomputed hash of the key string, or zero if it has not been
3383 precomputed.
3384
3385 C<value> is the scalar value to store for this key.  C<value> is copied
3386 by this function, which thus does not take ownership of any reference
3387 to it, and later changes to the scalar will not be reflected in the
3388 value visible in the C<refcounted_he>.  Complex types of scalar will not
3389 be stored with referential integrity, but will be coerced to strings.
3390 C<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3391 value is to be associated with the key; this, as with any non-null value,
3392 takes precedence over the existence of a value for the key further along
3393 the chain.
3394
3395 C<parent> points to the rest of the C<refcounted_he> chain to be
3396 attached to the new C<refcounted_he>.  This function takes ownership
3397 of one reference to C<parent>, and returns one reference to the new
3398 C<refcounted_he>.
3399
3400 =cut
3401 */
3402
3403 struct refcounted_he *
3404 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3405         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3406 {
3407     dVAR;
3408     STRLEN value_len = 0;
3409     const char *value_p = NULL;
3410     bool is_pv;
3411     char value_type;
3412     char hekflags;
3413     STRLEN key_offset = 1;
3414     struct refcounted_he *he;
3415     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3416
3417     if (!value || value == &PL_sv_placeholder) {
3418         value_type = HVrhek_delete;
3419     } else if (SvPOK(value)) {
3420         value_type = HVrhek_PV;
3421     } else if (SvIOK(value)) {
3422         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3423     } else if (!SvOK(value)) {
3424         value_type = HVrhek_undef;
3425     } else {
3426         value_type = HVrhek_PV;
3427     }
3428     is_pv = value_type == HVrhek_PV;
3429     if (is_pv) {
3430         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3431            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3432         value_p = SvPV_const(value, value_len);
3433         if (SvUTF8(value))
3434             value_type = HVrhek_PV_UTF8;
3435         key_offset = value_len + 2;
3436     }
3437     hekflags = value_type;
3438
3439     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3440         /* Canonicalise to Latin-1 where possible. */
3441         const char *keyend = keypv + keylen, *p;
3442         STRLEN nonascii_count = 0;
3443         for (p = keypv; p != keyend; p++) {
3444             if (! UTF8_IS_INVARIANT(*p)) {
3445                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3446                     goto canonicalised_key;
3447                 }
3448                 nonascii_count++;
3449                 p++;
3450             }
3451         }
3452         if (nonascii_count) {
3453             char *q;
3454             const char *p = keypv, *keyend = keypv + keylen;
3455             keylen -= nonascii_count;
3456             Newx(q, keylen, char);
3457             SAVEFREEPV(q);
3458             keypv = q;
3459             for (; p != keyend; p++, q++) {
3460                 U8 c = (U8)*p;
3461                 if (UTF8_IS_INVARIANT(c)) {
3462                     *q = (char) c;
3463                 }
3464                 else {
3465                     p++;
3466                     *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3467                 }
3468             }
3469         }
3470         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3471         canonicalised_key: ;
3472     }
3473     if (flags & REFCOUNTED_HE_KEY_UTF8)
3474         hekflags |= HVhek_UTF8;
3475     if (!hash)
3476         PERL_HASH(hash, keypv, keylen);
3477
3478 #ifdef USE_ITHREADS
3479     he = (struct refcounted_he*)
3480         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3481                              + keylen
3482                              + key_offset);
3483 #else
3484     he = (struct refcounted_he*)
3485         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3486                              + key_offset);
3487 #endif
3488
3489     he->refcounted_he_next = parent;
3490
3491     if (is_pv) {
3492         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3493         he->refcounted_he_val.refcounted_he_u_len = value_len;
3494     } else if (value_type == HVrhek_IV) {
3495         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3496     } else if (value_type == HVrhek_UV) {
3497         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3498     }
3499
3500 #ifdef USE_ITHREADS
3501     he->refcounted_he_hash = hash;
3502     he->refcounted_he_keylen = keylen;
3503     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3504 #else
3505     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3506 #endif
3507
3508     he->refcounted_he_data[0] = hekflags;
3509     he->refcounted_he_refcnt = 1;
3510
3511     return he;
3512 }
3513
3514 /*
3515 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3516
3517 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3518 of a string/length pair.
3519
3520 =cut
3521 */
3522
3523 struct refcounted_he *
3524 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3525         const char *key, U32 hash, SV *value, U32 flags)
3526 {
3527     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3528     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3529 }
3530
3531 /*
3532 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3533
3534 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3535 string/length pair.
3536
3537 =cut
3538 */
3539
3540 struct refcounted_he *
3541 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3542         SV *key, U32 hash, SV *value, U32 flags)
3543 {
3544     const char *keypv;
3545     STRLEN keylen;
3546     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3547     if (flags & REFCOUNTED_HE_KEY_UTF8)
3548         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3549             (UV)flags);
3550     keypv = SvPV_const(key, keylen);
3551     if (SvUTF8(key))
3552         flags |= REFCOUNTED_HE_KEY_UTF8;
3553     if (!hash && SvIsCOW_shared_hash(key))
3554         hash = SvSHARED_HASH(key);
3555     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3556 }
3557
3558 /*
3559 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3560
3561 Decrements the reference count of a C<refcounted_he> by one.  If the
3562 reference count reaches zero the structure's memory is freed, which
3563 (recursively) causes a reduction of its parent C<refcounted_he>'s
3564 reference count.  It is safe to pass a null pointer to this function:
3565 no action occurs in this case.
3566
3567 =cut
3568 */
3569
3570 void
3571 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3572 #ifdef USE_ITHREADS
3573     dVAR;
3574 #endif
3575     PERL_UNUSED_CONTEXT;
3576
3577     while (he) {
3578         struct refcounted_he *copy;
3579         U32 new_count;
3580
3581         HINTS_REFCNT_LOCK;
3582         new_count = --he->refcounted_he_refcnt;
3583         HINTS_REFCNT_UNLOCK;
3584         
3585         if (new_count) {
3586             return;
3587         }
3588
3589 #ifndef USE_ITHREADS
3590         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3591 #endif
3592         copy = he;
3593         he = he->refcounted_he_next;
3594         PerlMemShared_free(copy);
3595     }
3596 }
3597
3598 /*
3599 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3600
3601 Increment the reference count of a C<refcounted_he>.  The pointer to the
3602 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3603 to this function: no action occurs and a null pointer is returned.
3604
3605 =cut
3606 */
3607
3608 struct refcounted_he *
3609 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3610 {
3611 #ifdef USE_ITHREADS
3612     dVAR;
3613 #endif
3614     PERL_UNUSED_CONTEXT;
3615     if (he) {
3616         HINTS_REFCNT_LOCK;
3617         he->refcounted_he_refcnt++;
3618         HINTS_REFCNT_UNLOCK;
3619     }
3620     return he;
3621 }
3622
3623 /*
3624 =for apidoc cop_fetch_label
3625
3626 Returns the label attached to a cop.
3627 The flags pointer may be set to C<SVf_UTF8> or 0.
3628
3629 =cut
3630 */
3631
3632 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3633    the linked list.  */
3634 const char *
3635 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3636     struct refcounted_he *const chain = cop->cop_hints_hash;
3637
3638     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3639     PERL_UNUSED_CONTEXT;
3640
3641     if (!chain)
3642         return NULL;
3643 #ifdef USE_ITHREADS
3644     if (chain->refcounted_he_keylen != 1)
3645         return NULL;
3646     if (*REF_HE_KEY(chain) != ':')
3647         return NULL;
3648 #else
3649     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3650         return NULL;
3651     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3652         return NULL;
3653 #endif
3654     /* Stop anyone trying to really mess us up by adding their own value for
3655        ':' into %^H  */
3656     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3657         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3658         return NULL;
3659
3660     if (len)
3661         *len = chain->refcounted_he_val.refcounted_he_u_len;
3662     if (flags) {
3663         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3664                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3665     }
3666     return chain->refcounted_he_data + 1;
3667 }
3668
3669 /*
3670 =for apidoc cop_store_label
3671
3672 Save a label into a C<cop_hints_hash>.
3673 You need to set flags to C<SVf_UTF8>
3674 for a UTF-8 label.
3675
3676 =cut
3677 */
3678
3679 void
3680 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3681                      U32 flags)
3682 {
3683     SV *labelsv;
3684     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3685
3686     if (flags & ~(SVf_UTF8))
3687         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3688                    (UV)flags);
3689     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3690     if (flags & SVf_UTF8)
3691         SvUTF8_on(labelsv);
3692     cop->cop_hints_hash
3693         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3694 }
3695
3696 /*
3697 =for apidoc hv_assert
3698
3699 Check that a hash is in an internally consistent state.
3700
3701 =cut
3702 */
3703
3704 #ifdef DEBUGGING
3705
3706 void
3707 Perl_hv_assert(pTHX_ HV *hv)
3708 {
3709     dVAR;
3710     HE* entry;
3711     int withflags = 0;
3712     int placeholders = 0;
3713     int real = 0;
3714     int bad = 0;
3715     const I32 riter = HvRITER_get(hv);
3716     HE *eiter = HvEITER_get(hv);
3717
3718     PERL_ARGS_ASSERT_HV_ASSERT;
3719
3720     (void)hv_iterinit(hv);
3721
3722     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3723         /* sanity check the values */
3724         if (HeVAL(entry) == &PL_sv_placeholder)
3725             placeholders++;
3726         else
3727             real++;
3728         /* sanity check the keys */
3729         if (HeSVKEY(entry)) {
3730             NOOP;   /* Don't know what to check on SV keys.  */
3731         } else if (HeKUTF8(entry)) {
3732             withflags++;
3733             if (HeKWASUTF8(entry)) {
3734                 PerlIO_printf(Perl_debug_log,
3735                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3736                             (int) HeKLEN(entry),  HeKEY(entry));
3737                 bad = 1;
3738             }
3739         } else if (HeKWASUTF8(entry))
3740             withflags++;
3741     }
3742     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3743         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3744         const int nhashkeys = HvUSEDKEYS(hv);
3745         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3746
3747         if (nhashkeys != real) {
3748             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3749             bad = 1;
3750         }
3751         if (nhashplaceholders != placeholders) {
3752             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3753             bad = 1;
3754         }
3755     }
3756     if (withflags && ! HvHASKFLAGS(hv)) {
3757         PerlIO_printf(Perl_debug_log,
3758                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3759                     withflags);
3760         bad = 1;
3761     }
3762     if (bad) {
3763         sv_dump(MUTABLE_SV(hv));
3764     }
3765     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3766     HvEITER_set(hv, eiter);
3767 }
3768
3769 #endif
3770
3771 /*
3772  * ex: set ts=8 sts=4 sw=4 et:
3773  */