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