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