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