perldelta: update module versions
[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             aux->xhv_name_count = -count;
2484         }
2485     }
2486     else if(
2487         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) 
2488                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2489                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2490                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2491     ) {
2492         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2493         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2494         *aux->xhv_name_u.xhvnameu_names = namehek;
2495         aux->xhv_name_count = -1;
2496     }
2497 }
2498
2499 AV **
2500 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2501     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2502     /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
2503     {
2504         struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2505         return &(iter->xhv_backreferences);
2506     }
2507 }
2508
2509 void
2510 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2511     AV *av;
2512
2513     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2514
2515     if (!SvOOK(hv))
2516         return;
2517
2518     av = HvAUX(hv)->xhv_backreferences;
2519
2520     if (av) {
2521         HvAUX(hv)->xhv_backreferences = 0;
2522         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2523         if (SvTYPE(av) == SVt_PVAV)
2524             SvREFCNT_dec_NN(av);
2525     }
2526 }
2527
2528 /*
2529 hv_iternext is implemented as a macro in hv.h
2530
2531 =for apidoc hv_iternext
2532
2533 Returns entries from a hash iterator.  See C<L</hv_iterinit>>.
2534
2535 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2536 iterator currently points to, without losing your place or invalidating your
2537 iterator.  Note that in this case the current entry is deleted from the hash
2538 with your iterator holding the last reference to it.  Your iterator is flagged
2539 to free the entry on the next call to C<hv_iternext>, so you must not discard
2540 your iterator immediately else the entry will leak - call C<hv_iternext> to
2541 trigger the resource deallocation.
2542
2543 =for apidoc hv_iternext_flags
2544
2545 Returns entries from a hash iterator.  See C<L</hv_iterinit>> and
2546 C<L</hv_iternext>>.
2547 The C<flags> value will normally be zero; if C<HV_ITERNEXT_WANTPLACEHOLDERS> is
2548 set the placeholders keys (for restricted hashes) will be returned in addition
2549 to normal keys.  By default placeholders are automatically skipped over.
2550 Currently a placeholder is implemented with a value that is
2551 C<&PL_sv_placeholder>.  Note that the implementation of placeholders and
2552 restricted hashes may change, and the implementation currently is
2553 insufficiently abstracted for any change to be tidy.
2554
2555 =cut
2556 */
2557
2558 HE *
2559 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2560 {
2561     dVAR;
2562     XPVHV* xhv;
2563     HE *entry;
2564     HE *oldentry;
2565     MAGIC* mg;
2566     struct xpvhv_aux *iter;
2567
2568     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2569
2570     xhv = (XPVHV*)SvANY(hv);
2571
2572     if (!SvOOK(hv)) {
2573         /* Too many things (well, pp_each at least) merrily assume that you can
2574            call hv_iternext without calling hv_iterinit, so we'll have to deal
2575            with it.  */
2576         hv_iterinit(hv);
2577     }
2578     iter = HvAUX(hv);
2579
2580     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2581     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2582         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2583             SV * const key = sv_newmortal();
2584             if (entry) {
2585                 sv_setsv(key, HeSVKEY_force(entry));
2586                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2587                 HeSVKEY_set(entry, NULL);
2588             }
2589             else {
2590                 char *k;
2591                 HEK *hek;
2592
2593                 /* one HE per MAGICAL hash */
2594                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2595                 HvLAZYDEL_on(hv); /* make sure entry gets freed */
2596                 Zero(entry, 1, HE);
2597                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2598                 hek = (HEK*)k;
2599                 HeKEY_hek(entry) = hek;
2600                 HeKLEN(entry) = HEf_SVKEY;
2601             }
2602             magic_nextpack(MUTABLE_SV(hv),mg,key);
2603             if (SvOK(key)) {
2604                 /* force key to stay around until next time */
2605                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2606                 return entry;               /* beware, hent_val is not set */
2607             }
2608             SvREFCNT_dec(HeVAL(entry));
2609             Safefree(HeKEY_hek(entry));
2610             del_HE(entry);
2611             iter = HvAUX(hv); /* may been realloced */
2612             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2613             HvLAZYDEL_off(hv);
2614             return NULL;
2615         }
2616     }
2617 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2618     if (!entry && SvRMAGICAL((const SV *)hv)
2619         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2620         prime_env_iter();
2621 #ifdef VMS
2622         /* The prime_env_iter() on VMS just loaded up new hash values
2623          * so the iteration count needs to be reset back to the beginning
2624          */
2625         hv_iterinit(hv);
2626         iter = HvAUX(hv);
2627         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2628 #endif
2629     }
2630 #endif
2631
2632     /* hv_iterinit now ensures this.  */
2633     assert (HvARRAY(hv));
2634
2635     /* At start of hash, entry is NULL.  */
2636     if (entry)
2637     {
2638         entry = HeNEXT(entry);
2639         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2640             /*
2641              * Skip past any placeholders -- don't want to include them in
2642              * any iteration.
2643              */
2644             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2645                 entry = HeNEXT(entry);
2646             }
2647         }
2648     }
2649
2650 #ifdef PERL_HASH_RANDOMIZE_KEYS
2651     if (iter->xhv_last_rand != iter->xhv_rand) {
2652         if (iter->xhv_riter != -1) {
2653             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2654                              "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2655                              pTHX__FORMAT
2656                              pTHX__VALUE);
2657         }
2658         iter = HvAUX(hv); /* may been realloced */
2659         iter->xhv_last_rand = iter->xhv_rand;
2660     }
2661 #endif
2662
2663     /* Skip the entire loop if the hash is empty.   */
2664     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2665         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2666         while (!entry) {
2667             /* OK. Come to the end of the current list.  Grab the next one.  */
2668
2669             iter->xhv_riter++; /* HvRITER(hv)++ */
2670             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2671                 /* There is no next one.  End of the hash.  */
2672                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2673 #ifdef PERL_HASH_RANDOMIZE_KEYS
2674                 iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2675 #endif
2676                 break;
2677             }
2678             entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2679
2680             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2681                 /* If we have an entry, but it's a placeholder, don't count it.
2682                    Try the next.  */
2683                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2684                     entry = HeNEXT(entry);
2685             }
2686             /* Will loop again if this linked list starts NULL
2687                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2688                or if we run through it and find only placeholders.  */
2689         }
2690     }
2691     else {
2692         iter->xhv_riter = -1;
2693 #ifdef PERL_HASH_RANDOMIZE_KEYS
2694         iter->xhv_last_rand = iter->xhv_rand;
2695 #endif
2696     }
2697
2698     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2699         HvLAZYDEL_off(hv);
2700         hv_free_ent(hv, oldentry);
2701     }
2702
2703     iter = HvAUX(hv); /* may been realloced */
2704     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2705     return entry;
2706 }
2707
2708 /*
2709 =for apidoc hv_iterkey
2710
2711 Returns the key from the current position of the hash iterator.  See
2712 C<L</hv_iterinit>>.
2713
2714 =cut
2715 */
2716
2717 char *
2718 Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2719 {
2720     PERL_ARGS_ASSERT_HV_ITERKEY;
2721
2722     if (HeKLEN(entry) == HEf_SVKEY) {
2723         STRLEN len;
2724         char * const p = SvPV(HeKEY_sv(entry), len);
2725         *retlen = len;
2726         return p;
2727     }
2728     else {
2729         *retlen = HeKLEN(entry);
2730         return HeKEY(entry);
2731     }
2732 }
2733
2734 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2735 /*
2736 =for apidoc hv_iterkeysv
2737
2738 Returns the key as an C<SV*> from the current position of the hash
2739 iterator.  The return value will always be a mortal copy of the key.  Also
2740 see C<L</hv_iterinit>>.
2741
2742 =cut
2743 */
2744
2745 SV *
2746 Perl_hv_iterkeysv(pTHX_ HE *entry)
2747 {
2748     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2749
2750     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2751 }
2752
2753 /*
2754 =for apidoc hv_iterval
2755
2756 Returns the value from the current position of the hash iterator.  See
2757 C<L</hv_iterkey>>.
2758
2759 =cut
2760 */
2761
2762 SV *
2763 Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2764 {
2765     PERL_ARGS_ASSERT_HV_ITERVAL;
2766
2767     if (SvRMAGICAL(hv)) {
2768         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2769             SV* const sv = sv_newmortal();
2770             if (HeKLEN(entry) == HEf_SVKEY)
2771                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2772             else
2773                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2774             return sv;
2775         }
2776     }
2777     return HeVAL(entry);
2778 }
2779
2780 /*
2781 =for apidoc hv_iternextsv
2782
2783 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2784 operation.
2785
2786 =cut
2787 */
2788
2789 SV *
2790 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2791 {
2792     HE * const he = hv_iternext_flags(hv, 0);
2793
2794     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2795
2796     if (!he)
2797         return NULL;
2798     *key = hv_iterkey(he, retlen);
2799     return hv_iterval(hv, he);
2800 }
2801
2802 /*
2803
2804 Now a macro in hv.h
2805
2806 =for apidoc hv_magic
2807
2808 Adds magic to a hash.  See C<L</sv_magic>>.
2809
2810 =cut
2811 */
2812
2813 /* possibly free a shared string if no one has access to it
2814  * len and hash must both be valid for str.
2815  */
2816 void
2817 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2818 {
2819     unshare_hek_or_pvn (NULL, str, len, hash);
2820 }
2821
2822
2823 void
2824 Perl_unshare_hek(pTHX_ HEK *hek)
2825 {
2826     assert(hek);
2827     unshare_hek_or_pvn(hek, NULL, 0, 0);
2828 }
2829
2830 /* possibly free a shared string if no one has access to it
2831    hek if non-NULL takes priority over the other 3, else str, len and hash
2832    are used.  If so, len and hash must both be valid for str.
2833  */
2834 STATIC void
2835 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2836 {
2837     XPVHV* xhv;
2838     HE *entry;
2839     HE **oentry;
2840     bool is_utf8 = FALSE;
2841     int k_flags = 0;
2842     const char * const save = str;
2843     struct shared_he *he = NULL;
2844
2845     if (hek) {
2846         /* Find the shared he which is just before us in memory.  */
2847         he = (struct shared_he *)(((char *)hek)
2848                                   - STRUCT_OFFSET(struct shared_he,
2849                                                   shared_he_hek));
2850
2851         /* Assert that the caller passed us a genuine (or at least consistent)
2852            shared hek  */
2853         assert (he->shared_he_he.hent_hek == hek);
2854
2855         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2856             --he->shared_he_he.he_valu.hent_refcount;
2857             return;
2858         }
2859
2860         hash = HEK_HASH(hek);
2861     } else if (len < 0) {
2862         STRLEN tmplen = -len;
2863         is_utf8 = TRUE;
2864         /* See the note in hv_fetch(). --jhi */
2865         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2866         len = tmplen;
2867         if (is_utf8)
2868             k_flags = HVhek_UTF8;
2869         if (str != save)
2870             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2871     }
2872
2873     /* what follows was the moral equivalent of:
2874     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2875         if (--*Svp == NULL)
2876             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2877     } */
2878     xhv = (XPVHV*)SvANY(PL_strtab);
2879     /* assert(xhv_array != 0) */
2880     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2881     if (he) {
2882         const HE *const he_he = &(he->shared_he_he);
2883         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2884             if (entry == he_he)
2885                 break;
2886         }
2887     } else {
2888         const int flags_masked = k_flags & HVhek_MASK;
2889         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2890             if (HeHASH(entry) != hash)          /* strings can't be equal */
2891                 continue;
2892             if (HeKLEN(entry) != len)
2893                 continue;
2894             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2895                 continue;
2896             if (HeKFLAGS(entry) != flags_masked)
2897                 continue;
2898             break;
2899         }
2900     }
2901
2902     if (entry) {
2903         if (--entry->he_valu.hent_refcount == 0) {
2904             *oentry = HeNEXT(entry);
2905             Safefree(entry);
2906             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2907         }
2908     }
2909
2910     if (!entry)
2911         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2912                          "Attempt to free nonexistent shared string '%s'%s"
2913                          pTHX__FORMAT,
2914                          hek ? HEK_KEY(hek) : str,
2915                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2916     if (k_flags & HVhek_FREEKEY)
2917         Safefree(str);
2918 }
2919
2920 /* get a (constant) string ptr from the global string table
2921  * string will get added if it is not already there.
2922  * len and hash must both be valid for str.
2923  */
2924 HEK *
2925 Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
2926 {
2927     bool is_utf8 = FALSE;
2928     int flags = 0;
2929     const char * const save = str;
2930
2931     PERL_ARGS_ASSERT_SHARE_HEK;
2932
2933     if (len < 0) {
2934       STRLEN tmplen = -len;
2935       is_utf8 = TRUE;
2936       /* See the note in hv_fetch(). --jhi */
2937       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2938       len = tmplen;
2939       /* If we were able to downgrade here, then than means that we were passed
2940          in a key which only had chars 0-255, but was utf8 encoded.  */
2941       if (is_utf8)
2942           flags = HVhek_UTF8;
2943       /* If we found we were able to downgrade the string to bytes, then
2944          we should flag that it needs upgrading on keys or each.  Also flag
2945          that we need share_hek_flags to free the string.  */
2946       if (str != save) {
2947           dVAR;
2948           PERL_HASH(hash, str, len);
2949           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2950       }
2951     }
2952
2953     return share_hek_flags (str, len, hash, flags);
2954 }
2955
2956 STATIC HEK *
2957 S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
2958 {
2959     HE *entry;
2960     const int flags_masked = flags & HVhek_MASK;
2961     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2962     XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2963
2964     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2965
2966     /* what follows is the moral equivalent of:
2967
2968     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2969         hv_store(PL_strtab, str, len, NULL, hash);
2970
2971         Can't rehash the shared string table, so not sure if it's worth
2972         counting the number of entries in the linked list
2973     */
2974
2975     /* assert(xhv_array != 0) */
2976     entry = (HvARRAY(PL_strtab))[hindex];
2977     for (;entry; entry = HeNEXT(entry)) {
2978         if (HeHASH(entry) != hash)              /* strings can't be equal */
2979             continue;
2980         if (HeKLEN(entry) != len)
2981             continue;
2982         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2983             continue;
2984         if (HeKFLAGS(entry) != flags_masked)
2985             continue;
2986         break;
2987     }
2988
2989     if (!entry) {
2990         /* What used to be head of the list.
2991            If this is NULL, then we're the first entry for this slot, which
2992            means we need to increate fill.  */
2993         struct shared_he *new_entry;
2994         HEK *hek;
2995         char *k;
2996         HE **const head = &HvARRAY(PL_strtab)[hindex];
2997         HE *const next = *head;
2998
2999         /* We don't actually store a HE from the arena and a regular HEK.
3000            Instead we allocate one chunk of memory big enough for both,
3001            and put the HEK straight after the HE. This way we can find the
3002            HE directly from the HEK.
3003         */
3004
3005         Newx(k, STRUCT_OFFSET(struct shared_he,
3006                                 shared_he_hek.hek_key[0]) + len + 2, char);
3007         new_entry = (struct shared_he *)k;
3008         entry = &(new_entry->shared_he_he);
3009         hek = &(new_entry->shared_he_hek);
3010
3011         Copy(str, HEK_KEY(hek), len, char);
3012         HEK_KEY(hek)[len] = 0;
3013         HEK_LEN(hek) = len;
3014         HEK_HASH(hek) = hash;
3015         HEK_FLAGS(hek) = (unsigned char)flags_masked;
3016
3017         /* Still "point" to the HEK, so that other code need not know what
3018            we're up to.  */
3019         HeKEY_hek(entry) = hek;
3020         entry->he_valu.hent_refcount = 0;
3021         HeNEXT(entry) = next;
3022         *head = entry;
3023
3024         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
3025         if (!next) {                    /* initial entry? */
3026         } else if ( DO_HSPLIT(xhv) ) {
3027             const STRLEN oldsize = xhv->xhv_max + 1;
3028             hsplit(PL_strtab, oldsize, oldsize * 2);
3029         }
3030     }
3031
3032     ++entry->he_valu.hent_refcount;
3033
3034     if (flags & HVhek_FREEKEY)
3035         Safefree(str);
3036
3037     return HeKEY_hek(entry);
3038 }
3039
3040 SSize_t *
3041 Perl_hv_placeholders_p(pTHX_ HV *hv)
3042 {
3043     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3044
3045     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
3046
3047     if (!mg) {
3048         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
3049
3050         if (!mg) {
3051             Perl_die(aTHX_ "panic: hv_placeholders_p");
3052         }
3053     }
3054     return &(mg->mg_len);
3055 }
3056
3057
3058 I32
3059 Perl_hv_placeholders_get(pTHX_ const HV *hv)
3060 {
3061     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3062
3063     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
3064     PERL_UNUSED_CONTEXT;
3065
3066     return mg ? mg->mg_len : 0;
3067 }
3068
3069 void
3070 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
3071 {
3072     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
3073
3074     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
3075
3076     if (mg) {
3077         mg->mg_len = ph;
3078     } else if (ph) {
3079         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
3080             Perl_die(aTHX_ "panic: hv_placeholders_set");
3081     }
3082     /* else we don't need to add magic to record 0 placeholders.  */
3083 }
3084
3085 STATIC SV *
3086 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
3087 {
3088     dVAR;
3089     SV *value;
3090
3091     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
3092
3093     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
3094     case HVrhek_undef:
3095         value = newSV(0);
3096         break;
3097     case HVrhek_delete:
3098         value = &PL_sv_placeholder;
3099         break;
3100     case HVrhek_IV:
3101         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
3102         break;
3103     case HVrhek_UV:
3104         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
3105         break;
3106     case HVrhek_PV:
3107     case HVrhek_PV_UTF8:
3108         /* Create a string SV that directly points to the bytes in our
3109            structure.  */
3110         value = newSV_type(SVt_PV);
3111         SvPV_set(value, (char *) he->refcounted_he_data + 1);
3112         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
3113         /* This stops anything trying to free it  */
3114         SvLEN_set(value, 0);
3115         SvPOK_on(value);
3116         SvREADONLY_on(value);
3117         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
3118             SvUTF8_on(value);
3119         break;
3120     default:
3121         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
3122                    (UV)he->refcounted_he_data[0]);
3123     }
3124     return value;
3125 }
3126
3127 /*
3128 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
3129
3130 Generates and returns a C<HV *> representing the content of a
3131 C<refcounted_he> chain.
3132 C<flags> is currently unused and must be zero.
3133
3134 =cut
3135 */
3136 HV *
3137 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
3138 {
3139     dVAR;
3140     HV *hv;
3141     U32 placeholders, max;
3142
3143     if (flags)
3144         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
3145             (UV)flags);
3146
3147     /* We could chase the chain once to get an idea of the number of keys,
3148        and call ksplit.  But for now we'll make a potentially inefficient
3149        hash with only 8 entries in its array.  */
3150     hv = newHV();
3151     max = HvMAX(hv);
3152     if (!HvARRAY(hv)) {
3153         char *array;
3154         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3155         HvARRAY(hv) = (HE**)array;
3156     }
3157
3158     placeholders = 0;
3159     while (chain) {
3160 #ifdef USE_ITHREADS
3161         U32 hash = chain->refcounted_he_hash;
3162 #else
3163         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3164 #endif
3165         HE **oentry = &((HvARRAY(hv))[hash & max]);
3166         HE *entry = *oentry;
3167         SV *value;
3168
3169         for (; entry; entry = HeNEXT(entry)) {
3170             if (HeHASH(entry) == hash) {
3171                 /* We might have a duplicate key here.  If so, entry is older
3172                    than the key we've already put in the hash, so if they are
3173                    the same, skip adding entry.  */
3174 #ifdef USE_ITHREADS
3175                 const STRLEN klen = HeKLEN(entry);
3176                 const char *const key = HeKEY(entry);
3177                 if (klen == chain->refcounted_he_keylen
3178                     && (!!HeKUTF8(entry)
3179                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3180                     && memEQ(key, REF_HE_KEY(chain), klen))
3181                     goto next_please;
3182 #else
3183                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3184                     goto next_please;
3185                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3186                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3187                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3188                              HeKLEN(entry)))
3189                     goto next_please;
3190 #endif
3191             }
3192         }
3193         assert (!entry);
3194         entry = new_HE();
3195
3196 #ifdef USE_ITHREADS
3197         HeKEY_hek(entry)
3198             = share_hek_flags(REF_HE_KEY(chain),
3199                               chain->refcounted_he_keylen,
3200                               chain->refcounted_he_hash,
3201                               (chain->refcounted_he_data[0]
3202                                & (HVhek_UTF8|HVhek_WASUTF8)));
3203 #else
3204         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3205 #endif
3206         value = refcounted_he_value(chain);
3207         if (value == &PL_sv_placeholder)
3208             placeholders++;
3209         HeVAL(entry) = value;
3210
3211         /* Link it into the chain.  */
3212         HeNEXT(entry) = *oentry;
3213         *oentry = entry;
3214
3215         HvTOTALKEYS(hv)++;
3216
3217     next_please:
3218         chain = chain->refcounted_he_next;
3219     }
3220
3221     if (placeholders) {
3222         clear_placeholders(hv, placeholders);
3223         HvTOTALKEYS(hv) -= placeholders;
3224     }
3225
3226     /* We could check in the loop to see if we encounter any keys with key
3227        flags, but it's probably not worth it, as this per-hash flag is only
3228        really meant as an optimisation for things like Storable.  */
3229     HvHASKFLAGS_on(hv);
3230     DEBUG_A(Perl_hv_assert(aTHX_ hv));
3231
3232     return hv;
3233 }
3234
3235 /*
3236 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
3237
3238 Search along a C<refcounted_he> chain for an entry with the key specified
3239 by C<keypv> and C<keylen>.  If C<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
3240 bit set, the key octets are interpreted as UTF-8, otherwise they
3241 are interpreted as Latin-1.  C<hash> is a precomputed hash of the key
3242 string, or zero if it has not been precomputed.  Returns a mortal scalar
3243 representing the value associated with the key, or C<&PL_sv_placeholder>
3244 if there is no value associated with the key.
3245
3246 =cut
3247 */
3248
3249 SV *
3250 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3251                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3252 {
3253     dVAR;
3254     U8 utf8_flag;
3255     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3256
3257     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3258         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
3259             (UV)flags);
3260     if (!chain)
3261         goto ret;
3262     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3263         /* For searching purposes, canonicalise to Latin-1 where possible. */
3264         const char *keyend = keypv + keylen, *p;
3265         STRLEN nonascii_count = 0;
3266         for (p = keypv; p != keyend; p++) {
3267             if (! UTF8_IS_INVARIANT(*p)) {
3268                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3269                     goto canonicalised_key;
3270                 }
3271                 nonascii_count++;
3272                 p++;
3273             }
3274         }
3275         if (nonascii_count) {
3276             char *q;
3277             const char *p = keypv, *keyend = keypv + keylen;
3278             keylen -= nonascii_count;
3279             Newx(q, keylen, char);
3280             SAVEFREEPV(q);
3281             keypv = q;
3282             for (; p != keyend; p++, q++) {
3283                 U8 c = (U8)*p;
3284                 if (UTF8_IS_INVARIANT(c)) {
3285                     *q = (char) c;
3286                 }
3287                 else {
3288                     p++;
3289                     *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3290                 }
3291             }
3292         }
3293         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3294         canonicalised_key: ;
3295     }
3296     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3297     if (!hash)
3298         PERL_HASH(hash, keypv, keylen);
3299
3300     for (; chain; chain = chain->refcounted_he_next) {
3301         if (
3302 #ifdef USE_ITHREADS
3303             hash == chain->refcounted_he_hash &&
3304             keylen == chain->refcounted_he_keylen &&
3305             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3306             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3307 #else
3308             hash == HEK_HASH(chain->refcounted_he_hek) &&
3309             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3310             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3311             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3312 #endif
3313         ) {
3314             if (flags & REFCOUNTED_HE_EXISTS)
3315                 return (chain->refcounted_he_data[0] & HVrhek_typemask)
3316                     == HVrhek_delete
3317                     ? NULL : &PL_sv_yes;
3318             return sv_2mortal(refcounted_he_value(chain));
3319         }
3320     }
3321   ret:
3322     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3323 }
3324
3325 /*
3326 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3327
3328 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3329 instead of a string/length pair.
3330
3331 =cut
3332 */
3333
3334 SV *
3335 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3336                          const char *key, U32 hash, U32 flags)
3337 {
3338     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3339     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3340 }
3341
3342 /*
3343 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3344
3345 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3346 string/length pair.
3347
3348 =cut
3349 */
3350
3351 SV *
3352 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3353                          SV *key, U32 hash, U32 flags)
3354 {
3355     const char *keypv;
3356     STRLEN keylen;
3357     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3358     if (flags & REFCOUNTED_HE_KEY_UTF8)
3359         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3360             (UV)flags);
3361     keypv = SvPV_const(key, keylen);
3362     if (SvUTF8(key))
3363         flags |= REFCOUNTED_HE_KEY_UTF8;
3364     if (!hash && SvIsCOW_shared_hash(key))
3365         hash = SvSHARED_HASH(key);
3366     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3367 }
3368
3369 /*
3370 =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
3371
3372 Creates a new C<refcounted_he>.  This consists of a single key/value
3373 pair and a reference to an existing C<refcounted_he> chain (which may
3374 be empty), and thus forms a longer chain.  When using the longer chain,
3375 the new key/value pair takes precedence over any entry for the same key
3376 further along the chain.
3377
3378 The new key is specified by C<keypv> and C<keylen>.  If C<flags> has
3379 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3380 as UTF-8, otherwise they are interpreted as Latin-1.  C<hash> is
3381 a precomputed hash of the key string, or zero if it has not been
3382 precomputed.
3383
3384 C<value> is the scalar value to store for this key.  C<value> is copied
3385 by this function, which thus does not take ownership of any reference
3386 to it, and later changes to the scalar will not be reflected in the
3387 value visible in the C<refcounted_he>.  Complex types of scalar will not
3388 be stored with referential integrity, but will be coerced to strings.
3389 C<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3390 value is to be associated with the key; this, as with any non-null value,
3391 takes precedence over the existence of a value for the key further along
3392 the chain.
3393
3394 C<parent> points to the rest of the C<refcounted_he> chain to be
3395 attached to the new C<refcounted_he>.  This function takes ownership
3396 of one reference to C<parent>, and returns one reference to the new
3397 C<refcounted_he>.
3398
3399 =cut
3400 */
3401
3402 struct refcounted_he *
3403 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3404         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3405 {
3406     dVAR;
3407     STRLEN value_len = 0;
3408     const char *value_p = NULL;
3409     bool is_pv;
3410     char value_type;
3411     char hekflags;
3412     STRLEN key_offset = 1;
3413     struct refcounted_he *he;
3414     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3415
3416     if (!value || value == &PL_sv_placeholder) {
3417         value_type = HVrhek_delete;
3418     } else if (SvPOK(value)) {
3419         value_type = HVrhek_PV;
3420     } else if (SvIOK(value)) {
3421         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3422     } else if (!SvOK(value)) {
3423         value_type = HVrhek_undef;
3424     } else {
3425         value_type = HVrhek_PV;
3426     }
3427     is_pv = value_type == HVrhek_PV;
3428     if (is_pv) {
3429         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3430            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3431         value_p = SvPV_const(value, value_len);
3432         if (SvUTF8(value))
3433             value_type = HVrhek_PV_UTF8;
3434         key_offset = value_len + 2;
3435     }
3436     hekflags = value_type;
3437
3438     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3439         /* Canonicalise to Latin-1 where possible. */
3440         const char *keyend = keypv + keylen, *p;
3441         STRLEN nonascii_count = 0;
3442         for (p = keypv; p != keyend; p++) {
3443             if (! UTF8_IS_INVARIANT(*p)) {
3444                 if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
3445                     goto canonicalised_key;
3446                 }
3447                 nonascii_count++;
3448                 p++;
3449             }
3450         }
3451         if (nonascii_count) {
3452             char *q;
3453             const char *p = keypv, *keyend = keypv + keylen;
3454             keylen -= nonascii_count;
3455             Newx(q, keylen, char);
3456             SAVEFREEPV(q);
3457             keypv = q;
3458             for (; p != keyend; p++, q++) {
3459                 U8 c = (U8)*p;
3460                 if (UTF8_IS_INVARIANT(c)) {
3461                     *q = (char) c;
3462                 }
3463                 else {
3464                     p++;
3465                     *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p);
3466                 }
3467             }
3468         }
3469         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3470         canonicalised_key: ;
3471     }
3472     if (flags & REFCOUNTED_HE_KEY_UTF8)
3473         hekflags |= HVhek_UTF8;
3474     if (!hash)
3475         PERL_HASH(hash, keypv, keylen);
3476
3477 #ifdef USE_ITHREADS
3478     he = (struct refcounted_he*)
3479         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3480                              + keylen
3481                              + key_offset);
3482 #else
3483     he = (struct refcounted_he*)
3484         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3485                              + key_offset);
3486 #endif
3487
3488     he->refcounted_he_next = parent;
3489
3490     if (is_pv) {
3491         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3492         he->refcounted_he_val.refcounted_he_u_len = value_len;
3493     } else if (value_type == HVrhek_IV) {
3494         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3495     } else if (value_type == HVrhek_UV) {
3496         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3497     }
3498
3499 #ifdef USE_ITHREADS
3500     he->refcounted_he_hash = hash;
3501     he->refcounted_he_keylen = keylen;
3502     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3503 #else
3504     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3505 #endif
3506
3507     he->refcounted_he_data[0] = hekflags;
3508     he->refcounted_he_refcnt = 1;
3509
3510     return he;
3511 }
3512
3513 /*
3514 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3515
3516 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3517 of a string/length pair.
3518
3519 =cut
3520 */
3521
3522 struct refcounted_he *
3523 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3524         const char *key, U32 hash, SV *value, U32 flags)
3525 {
3526     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3527     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3528 }
3529
3530 /*
3531 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3532
3533 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3534 string/length pair.
3535
3536 =cut
3537 */
3538
3539 struct refcounted_he *
3540 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3541         SV *key, U32 hash, SV *value, U32 flags)
3542 {
3543     const char *keypv;
3544     STRLEN keylen;
3545     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3546     if (flags & REFCOUNTED_HE_KEY_UTF8)
3547         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3548             (UV)flags);
3549     keypv = SvPV_const(key, keylen);
3550     if (SvUTF8(key))
3551         flags |= REFCOUNTED_HE_KEY_UTF8;
3552     if (!hash && SvIsCOW_shared_hash(key))
3553         hash = SvSHARED_HASH(key);
3554     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3555 }
3556
3557 /*
3558 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3559
3560 Decrements the reference count of a C<refcounted_he> by one.  If the
3561 reference count reaches zero the structure's memory is freed, which
3562 (recursively) causes a reduction of its parent C<refcounted_he>'s
3563 reference count.  It is safe to pass a null pointer to this function:
3564 no action occurs in this case.
3565
3566 =cut
3567 */
3568
3569 void
3570 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3571 #ifdef USE_ITHREADS
3572     dVAR;
3573 #endif
3574     PERL_UNUSED_CONTEXT;
3575
3576     while (he) {
3577         struct refcounted_he *copy;
3578         U32 new_count;
3579
3580         HINTS_REFCNT_LOCK;
3581         new_count = --he->refcounted_he_refcnt;
3582         HINTS_REFCNT_UNLOCK;
3583         
3584         if (new_count) {
3585             return;
3586         }
3587
3588 #ifndef USE_ITHREADS
3589         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3590 #endif
3591         copy = he;
3592         he = he->refcounted_he_next;
3593         PerlMemShared_free(copy);
3594     }
3595 }
3596
3597 /*
3598 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3599
3600 Increment the reference count of a C<refcounted_he>.  The pointer to the
3601 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3602 to this function: no action occurs and a null pointer is returned.
3603
3604 =cut
3605 */
3606
3607 struct refcounted_he *
3608 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3609 {
3610 #ifdef USE_ITHREADS
3611     dVAR;
3612 #endif
3613     PERL_UNUSED_CONTEXT;
3614     if (he) {
3615         HINTS_REFCNT_LOCK;
3616         he->refcounted_he_refcnt++;
3617         HINTS_REFCNT_UNLOCK;
3618     }
3619     return he;
3620 }
3621
3622 /*
3623 =for apidoc cop_fetch_label
3624
3625 Returns the label attached to a cop.
3626 The flags pointer may be set to C<SVf_UTF8> or 0.
3627
3628 =cut
3629 */
3630
3631 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3632    the linked list.  */
3633 const char *
3634 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3635     struct refcounted_he *const chain = cop->cop_hints_hash;
3636
3637     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3638     PERL_UNUSED_CONTEXT;
3639
3640     if (!chain)
3641         return NULL;
3642 #ifdef USE_ITHREADS
3643     if (chain->refcounted_he_keylen != 1)
3644         return NULL;
3645     if (*REF_HE_KEY(chain) != ':')
3646         return NULL;
3647 #else
3648     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3649         return NULL;
3650     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3651         return NULL;
3652 #endif
3653     /* Stop anyone trying to really mess us up by adding their own value for
3654        ':' into %^H  */
3655     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3656         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3657         return NULL;
3658
3659     if (len)
3660         *len = chain->refcounted_he_val.refcounted_he_u_len;
3661     if (flags) {
3662         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3663                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3664     }
3665     return chain->refcounted_he_data + 1;
3666 }
3667
3668 /*
3669 =for apidoc cop_store_label
3670
3671 Save a label into a C<cop_hints_hash>.
3672 You need to set flags to C<SVf_UTF8>
3673 for a UTF-8 label.
3674
3675 =cut
3676 */
3677
3678 void
3679 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3680                      U32 flags)
3681 {
3682     SV *labelsv;
3683     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3684
3685     if (flags & ~(SVf_UTF8))
3686         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3687                    (UV)flags);
3688     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3689     if (flags & SVf_UTF8)
3690         SvUTF8_on(labelsv);
3691     cop->cop_hints_hash
3692         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3693 }
3694
3695 /*
3696 =for apidoc hv_assert
3697
3698 Check that a hash is in an internally consistent state.
3699
3700 =cut
3701 */
3702
3703 #ifdef DEBUGGING
3704
3705 void
3706 Perl_hv_assert(pTHX_ HV *hv)
3707 {
3708     dVAR;
3709     HE* entry;
3710     int withflags = 0;
3711     int placeholders = 0;
3712     int real = 0;
3713     int bad = 0;
3714     const I32 riter = HvRITER_get(hv);
3715     HE *eiter = HvEITER_get(hv);
3716
3717     PERL_ARGS_ASSERT_HV_ASSERT;
3718
3719     (void)hv_iterinit(hv);
3720
3721     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3722         /* sanity check the values */
3723         if (HeVAL(entry) == &PL_sv_placeholder)
3724             placeholders++;
3725         else
3726             real++;
3727         /* sanity check the keys */
3728         if (HeSVKEY(entry)) {
3729             NOOP;   /* Don't know what to check on SV keys.  */
3730         } else if (HeKUTF8(entry)) {
3731             withflags++;
3732             if (HeKWASUTF8(entry)) {
3733                 PerlIO_printf(Perl_debug_log,
3734                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3735                             (int) HeKLEN(entry),  HeKEY(entry));
3736                 bad = 1;
3737             }
3738         } else if (HeKWASUTF8(entry))
3739             withflags++;
3740     }
3741     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3742         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3743         const int nhashkeys = HvUSEDKEYS(hv);
3744         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3745
3746         if (nhashkeys != real) {
3747             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3748             bad = 1;
3749         }
3750         if (nhashplaceholders != placeholders) {
3751             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3752             bad = 1;
3753         }
3754     }
3755     if (withflags && ! HvHASKFLAGS(hv)) {
3756         PerlIO_printf(Perl_debug_log,
3757                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3758                     withflags);
3759         bad = 1;
3760     }
3761     if (bad) {
3762         sv_dump(MUTABLE_SV(hv));
3763     }
3764     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3765     HvEITER_set(hv, eiter);
3766 }
3767
3768 #endif
3769
3770 /*
3771  * ex: set ts=8 sts=4 sw=4 et:
3772  */