This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Switch the core MRO code over to HvENAME
[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 actaully 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 = 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             hsplit(hv);
804         } else if(!HvREHASH(hv)) {
805             U32 n_links = 1;
806
807             while ((counter = HeNEXT(counter)))
808                 n_links++;
809
810             if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
811                 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
812                    bucket splits on a rehashed hash, as we're not going to
813                    split it again, and if someone is lucky (evil) enough to
814                    get all the keys in one list they could exhaust our memory
815                    as we repeatedly double the number of buckets on every
816                    entry. Linear search feels a less worse thing to do.  */
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     HE *const *first_entry;
908     bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
909     int masked_flags;
910
911     if (SvRMAGICAL(hv)) {
912         bool needs_copy;
913         bool needs_store;
914         hv_magic_check (hv, &needs_copy, &needs_store);
915
916         if (needs_copy) {
917             SV *sv;
918             entry = (HE *) hv_common(hv, keysv, key, klen,
919                                      k_flags & ~HVhek_FREEKEY,
920                                      HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
921                                      NULL, hash);
922             sv = entry ? HeVAL(entry) : NULL;
923             if (sv) {
924                 if (SvMAGICAL(sv)) {
925                     mg_clear(sv);
926                 }
927                 if (!needs_store) {
928                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
929                         /* No longer an element */
930                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
931                         return sv;
932                     }           
933                     return NULL;                /* element cannot be deleted */
934                 }
935 #ifdef ENV_IS_CASELESS
936                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
937                     /* XXX This code isn't UTF8 clean.  */
938                     keysv = newSVpvn_flags(key, klen, SVs_TEMP);
939                     if (k_flags & HVhek_FREEKEY) {
940                         Safefree(key);
941                     }
942                     key = strupr(SvPVX(keysv));
943                     is_utf8 = 0;
944                     k_flags = 0;
945                     hash = 0;
946                 }
947 #endif
948             }
949         }
950     }
951     xhv = (XPVHV*)SvANY(hv);
952     if (!HvARRAY(hv))
953         return NULL;
954
955     if (is_utf8) {
956         const char * const keysave = key;
957         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
958
959         if (is_utf8)
960             k_flags |= HVhek_UTF8;
961         else
962             k_flags &= ~HVhek_UTF8;
963         if (key != keysave) {
964             if (k_flags & HVhek_FREEKEY) {
965                 /* This shouldn't happen if our caller does what we expect,
966                    but strictly the API allows it.  */
967                 Safefree(keysave);
968             }
969             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
970         }
971         HvHASKFLAGS_on(MUTABLE_SV(hv));
972     }
973
974     if (HvREHASH(hv)) {
975         PERL_HASH_INTERNAL(hash, key, klen);
976     } else if (!hash) {
977         if (keysv && (SvIsCOW_shared_hash(keysv))) {
978             hash = SvSHARED_HASH(keysv);
979         } else {
980             PERL_HASH(hash, key, klen);
981         }
982     }
983
984     masked_flags = (k_flags & HVhek_MASK);
985
986     first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
987     entry = *oentry;
988     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
989         SV *sv;
990         bool mpm = FALSE;
991         const char *name = NULL;
992         STRLEN namlen;
993         HV *stash = NULL;
994
995         if (HeHASH(entry) != hash)              /* strings can't be equal */
996             continue;
997         if (HeKLEN(entry) != (I32)klen)
998             continue;
999         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1000             continue;
1001         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1002             continue;
1003
1004         if (hv == PL_strtab) {
1005             if (k_flags & HVhek_FREEKEY)
1006                 Safefree(key);
1007             Perl_croak(aTHX_ S_strtab_error, "delete");
1008         }
1009
1010         /* if placeholder is here, it's already been deleted.... */
1011         if (HeVAL(entry) == &PL_sv_placeholder) {
1012             if (k_flags & HVhek_FREEKEY)
1013                 Safefree(key);
1014             return NULL;
1015         }
1016         if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1017             hv_notallowed(k_flags, key, klen,
1018                             "Attempt to delete readonly key '%"SVf"' from"
1019                             " a restricted hash");
1020         }
1021         if (k_flags & HVhek_FREEKEY)
1022             Safefree(key);
1023
1024         /* If this is a stash and the key ends with ::, then someone is 
1025          * deleting a package.
1026          * Check whether the gv (HeVAL(entry)) is still in the symbol
1027          * table and then save the name to pass to mro_package_moved after
1028          * the deletion.
1029          * We cannot pass the gv to mro_package_moved directly, as that
1030          * function also checks whether the gv is to be found at the loca-
1031          * tion its name indicates, which will no longer be the case once
1032          * this element is deleted. So we have to do that check here.
1033          */
1034         if (HeVAL(entry) && HvENAME_get(hv)) {
1035                 sv = HeVAL(entry);
1036                 if (keysv) key = SvPV(keysv, klen);
1037                 if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':'
1038                  && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1039                  && SvTYPE(sv) == SVt_PVGV && (stash = GvHV((GV *)sv))
1040                  && HvENAME_get(stash)) {
1041                     SV * const namesv = sv_newmortal();
1042                     gv_fullname4(namesv, (GV *)sv, NULL, 0);
1043                     if (
1044                      gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV)
1045                        == (GV *)sv
1046                     ) {
1047                         mpm = TRUE;
1048                         name = SvPV_const(namesv, namlen);
1049                         namlen -= 2; /* skip trailing :: */
1050                         /* Hang on to it for a bit. */
1051                         SvREFCNT_inc_simple_void_NN(
1052                          sv_2mortal((SV *)stash)
1053                         );
1054                     }
1055                 }
1056         }
1057
1058         if (d_flags & G_DISCARD)
1059             sv = NULL;
1060         else {
1061             sv = sv_2mortal(HeVAL(entry));
1062             HeVAL(entry) = &PL_sv_placeholder;
1063         }
1064
1065         /*
1066          * If a restricted hash, rather than really deleting the entry, put
1067          * a placeholder there. This marks the key as being "approved", so
1068          * we can still access via not-really-existing key without raising
1069          * an error.
1070          */
1071         if (SvREADONLY(hv)) {
1072             SvREFCNT_dec(HeVAL(entry));
1073             HeVAL(entry) = &PL_sv_placeholder;
1074             /* We'll be saving this slot, so the number of allocated keys
1075              * doesn't go down, but the number placeholders goes up */
1076             HvPLACEHOLDERS(hv)++;
1077         } else {
1078             *oentry = HeNEXT(entry);
1079             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1080                 HvLAZYDEL_on(hv);
1081             else
1082                 hv_free_ent(hv, entry);
1083             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1084             if (xhv->xhv_keys == 0)
1085                 HvHASKFLAGS_off(hv);
1086         }
1087
1088         if (mpm) mro_package_moved(NULL, stash, NULL, name, namlen);
1089
1090         return sv;
1091     }
1092     if (SvREADONLY(hv)) {
1093         hv_notallowed(k_flags, key, klen,
1094                         "Attempt to delete disallowed key '%"SVf"' from"
1095                         " a restricted hash");
1096     }
1097
1098     if (k_flags & HVhek_FREEKEY)
1099         Safefree(key);
1100     return NULL;
1101 }
1102
1103 STATIC void
1104 S_hsplit(pTHX_ HV *hv)
1105 {
1106     dVAR;
1107     register XPVHV* const xhv = (XPVHV*)SvANY(hv);
1108     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1109     register I32 newsize = oldsize * 2;
1110     register I32 i;
1111     char *a = (char*) HvARRAY(hv);
1112     register HE **aep;
1113     int longest_chain = 0;
1114     int was_shared;
1115
1116     PERL_ARGS_ASSERT_HSPLIT;
1117
1118     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1119       (void*)hv, (int) oldsize);*/
1120
1121     if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1122       /* Can make this clear any placeholders first for non-restricted hashes,
1123          even though Storable rebuilds restricted hashes by putting in all the
1124          placeholders (first) before turning on the readonly flag, because
1125          Storable always pre-splits the hash.  */
1126       hv_clear_placeholders(hv);
1127     }
1128                
1129     PL_nomemok = TRUE;
1130 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1131     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1132           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1133     if (!a) {
1134       PL_nomemok = FALSE;
1135       return;
1136     }
1137     if (SvOOK(hv)) {
1138         Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1139     }
1140 #else
1141     Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1142         + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1143     if (!a) {
1144       PL_nomemok = FALSE;
1145       return;
1146     }
1147     Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1148     if (SvOOK(hv)) {
1149         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1150     }
1151     Safefree(HvARRAY(hv));
1152 #endif
1153
1154     PL_nomemok = FALSE;
1155     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1156     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1157     HvARRAY(hv) = (HE**) a;
1158     aep = (HE**)a;
1159
1160     for (i=0; i<oldsize; i++,aep++) {
1161         int left_length = 0;
1162         int right_length = 0;
1163         HE **oentry = aep;
1164         HE *entry = *aep;
1165         register HE **bep;
1166
1167         if (!entry)                             /* non-existent */
1168             continue;
1169         bep = aep+oldsize;
1170         do {
1171             if ((HeHASH(entry) & newsize) != (U32)i) {
1172                 *oentry = HeNEXT(entry);
1173                 HeNEXT(entry) = *bep;
1174                 *bep = entry;
1175                 right_length++;
1176             }
1177             else {
1178                 oentry = &HeNEXT(entry);
1179                 left_length++;
1180             }
1181             entry = *oentry;
1182         } while (entry);
1183         /* I think we don't actually need to keep track of the longest length,
1184            merely flag if anything is too long. But for the moment while
1185            developing this code I'll track it.  */
1186         if (left_length > longest_chain)
1187             longest_chain = left_length;
1188         if (right_length > longest_chain)
1189             longest_chain = right_length;
1190     }
1191
1192
1193     /* Pick your policy for "hashing isn't working" here:  */
1194     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1195         || HvREHASH(hv)) {
1196         return;
1197     }
1198
1199     if (hv == PL_strtab) {
1200         /* Urg. Someone is doing something nasty to the string table.
1201            Can't win.  */
1202         return;
1203     }
1204
1205     /* Awooga. Awooga. Pathological data.  */
1206     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
1207       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1208
1209     ++newsize;
1210     Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1211          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1212     if (SvOOK(hv)) {
1213         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1214     }
1215
1216     was_shared = HvSHAREKEYS(hv);
1217
1218     HvSHAREKEYS_off(hv);
1219     HvREHASH_on(hv);
1220
1221     aep = HvARRAY(hv);
1222
1223     for (i=0; i<newsize; i++,aep++) {
1224         register HE *entry = *aep;
1225         while (entry) {
1226             /* We're going to trash this HE's next pointer when we chain it
1227                into the new hash below, so store where we go next.  */
1228             HE * const next = HeNEXT(entry);
1229             UV hash;
1230             HE **bep;
1231
1232             /* Rehash it */
1233             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1234
1235             if (was_shared) {
1236                 /* Unshare it.  */
1237                 HEK * const new_hek
1238                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1239                                      hash, HeKFLAGS(entry));
1240                 unshare_hek (HeKEY_hek(entry));
1241                 HeKEY_hek(entry) = new_hek;
1242             } else {
1243                 /* Not shared, so simply write the new hash in. */
1244                 HeHASH(entry) = hash;
1245             }
1246             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1247             HEK_REHASH_on(HeKEY_hek(entry));
1248             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1249
1250             /* Copy oentry to the correct new chain.  */
1251             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1252             HeNEXT(entry) = *bep;
1253             *bep = entry;
1254
1255             entry = next;
1256         }
1257     }
1258     Safefree (HvARRAY(hv));
1259     HvARRAY(hv) = (HE **)a;
1260 }
1261
1262 void
1263 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1264 {
1265     dVAR;
1266     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1267     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1268     register I32 newsize;
1269     register I32 i;
1270     register char *a;
1271     register HE **aep;
1272
1273     PERL_ARGS_ASSERT_HV_KSPLIT;
1274
1275     newsize = (I32) newmax;                     /* possible truncation here */
1276     if (newsize != newmax || newmax <= oldsize)
1277         return;
1278     while ((newsize & (1 + ~newsize)) != newsize) {
1279         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1280     }
1281     if (newsize < newmax)
1282         newsize *= 2;
1283     if (newsize < newmax)
1284         return;                                 /* overflow detection */
1285
1286     a = (char *) HvARRAY(hv);
1287     if (a) {
1288         PL_nomemok = TRUE;
1289 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1290         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1291               + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1292         if (!a) {
1293           PL_nomemok = FALSE;
1294           return;
1295         }
1296         if (SvOOK(hv)) {
1297             Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1298         }
1299 #else
1300         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1301             + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1302         if (!a) {
1303           PL_nomemok = FALSE;
1304           return;
1305         }
1306         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1307         if (SvOOK(hv)) {
1308             Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1309         }
1310         Safefree(HvARRAY(hv));
1311 #endif
1312         PL_nomemok = FALSE;
1313         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1314     }
1315     else {
1316         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1317     }
1318     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1319     HvARRAY(hv) = (HE **) a;
1320     if (!xhv->xhv_keys /* !HvTOTALKEYS(hv) */)  /* skip rest if no entries */
1321         return;
1322
1323     aep = (HE**)a;
1324     for (i=0; i<oldsize; i++,aep++) {
1325         HE **oentry = aep;
1326         HE *entry = *aep;
1327
1328         if (!entry)                             /* non-existent */
1329             continue;
1330         do {
1331             register I32 j = (HeHASH(entry) & newsize);
1332
1333             if (j != i) {
1334                 j -= i;
1335                 *oentry = HeNEXT(entry);
1336                 HeNEXT(entry) = aep[j];
1337                 aep[j] = entry;
1338             }
1339             else
1340                 oentry = &HeNEXT(entry);
1341             entry = *oentry;
1342         } while (entry);
1343     }
1344 }
1345
1346 HV *
1347 Perl_newHVhv(pTHX_ HV *ohv)
1348 {
1349     dVAR;
1350     HV * const hv = newHV();
1351     STRLEN hv_max;
1352
1353     if (!ohv || !HvTOTALKEYS(ohv))
1354         return hv;
1355     hv_max = HvMAX(ohv);
1356
1357     if (!SvMAGICAL((const SV *)ohv)) {
1358         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1359         STRLEN i;
1360         const bool shared = !!HvSHAREKEYS(ohv);
1361         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1362         char *a;
1363         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1364         ents = (HE**)a;
1365
1366         /* In each bucket... */
1367         for (i = 0; i <= hv_max; i++) {
1368             HE *prev = NULL;
1369             HE *oent = oents[i];
1370
1371             if (!oent) {
1372                 ents[i] = NULL;
1373                 continue;
1374             }
1375
1376             /* Copy the linked list of entries. */
1377             for (; oent; oent = HeNEXT(oent)) {
1378                 const U32 hash   = HeHASH(oent);
1379                 const char * const key = HeKEY(oent);
1380                 const STRLEN len = HeKLEN(oent);
1381                 const int flags  = HeKFLAGS(oent);
1382                 HE * const ent   = new_HE();
1383                 SV *const val    = HeVAL(oent);
1384
1385                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1386                 HeKEY_hek(ent)
1387                     = shared ? share_hek_flags(key, len, hash, flags)
1388                              :  save_hek_flags(key, len, hash, flags);
1389                 if (prev)
1390                     HeNEXT(prev) = ent;
1391                 else
1392                     ents[i] = ent;
1393                 prev = ent;
1394                 HeNEXT(ent) = NULL;
1395             }
1396         }
1397
1398         HvMAX(hv)   = hv_max;
1399         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1400         HvARRAY(hv) = ents;
1401     } /* not magical */
1402     else {
1403         /* Iterate over ohv, copying keys and values one at a time. */
1404         HE *entry;
1405         const I32 riter = HvRITER_get(ohv);
1406         HE * const eiter = HvEITER_get(ohv);
1407         STRLEN hv_fill = HvFILL(ohv);
1408
1409         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1410         while (hv_max && hv_max + 1 >= hv_fill * 2)
1411             hv_max = hv_max / 2;
1412         HvMAX(hv) = hv_max;
1413
1414         hv_iterinit(ohv);
1415         while ((entry = hv_iternext_flags(ohv, 0))) {
1416             SV *const val = HeVAL(entry);
1417             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1418                                  SvIMMORTAL(val) ? val : newSVsv(val),
1419                                  HeHASH(entry), HeKFLAGS(entry));
1420         }
1421         HvRITER_set(ohv, riter);
1422         HvEITER_set(ohv, eiter);
1423     }
1424
1425     return hv;
1426 }
1427
1428 /*
1429 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1430
1431 A specialised version of L</newHVhv> for copying C<%^H>.  I<ohv> must be
1432 a pointer to a hash (which may have C<%^H> magic, but should be generally
1433 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1434 of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1435 added to it.  A pointer to the new hash is returned.
1436
1437 =cut
1438 */
1439
1440 HV *
1441 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1442 {
1443     HV * const hv = newHV();
1444
1445     if (ohv && HvTOTALKEYS(ohv)) {
1446         STRLEN hv_max = HvMAX(ohv);
1447         STRLEN hv_fill = HvFILL(ohv);
1448         HE *entry;
1449         const I32 riter = HvRITER_get(ohv);
1450         HE * const eiter = HvEITER_get(ohv);
1451
1452         while (hv_max && hv_max + 1 >= hv_fill * 2)
1453             hv_max = hv_max / 2;
1454         HvMAX(hv) = hv_max;
1455
1456         hv_iterinit(ohv);
1457         while ((entry = hv_iternext_flags(ohv, 0))) {
1458             SV *const sv = newSVsv(HeVAL(entry));
1459             SV *heksv = newSVhek(HeKEY_hek(entry));
1460             sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1461                      (char *)heksv, HEf_SVKEY);
1462             SvREFCNT_dec(heksv);
1463             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1464                                  sv, HeHASH(entry), HeKFLAGS(entry));
1465         }
1466         HvRITER_set(ohv, riter);
1467         HvEITER_set(ohv, eiter);
1468     }
1469     hv_magic(hv, NULL, PERL_MAGIC_hints);
1470     return hv;
1471 }
1472
1473 void
1474 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1475 {
1476     dVAR;
1477     SV *val;
1478
1479     PERL_ARGS_ASSERT_HV_FREE_ENT;
1480
1481     if (!entry)
1482         return;
1483     val = HeVAL(entry);
1484     if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvENAME(hv))
1485         mro_method_changed_in(hv);      /* deletion of method from stash */
1486     SvREFCNT_dec(val);
1487     if (HeKLEN(entry) == HEf_SVKEY) {
1488         SvREFCNT_dec(HeKEY_sv(entry));
1489         Safefree(HeKEY_hek(entry));
1490     }
1491     else if (HvSHAREKEYS(hv))
1492         unshare_hek(HeKEY_hek(entry));
1493     else
1494         Safefree(HeKEY_hek(entry));
1495     del_HE(entry);
1496 }
1497
1498
1499 void
1500 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1501 {
1502     dVAR;
1503
1504     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1505
1506     if (!entry)
1507         return;
1508     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1509     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1510     if (HeKLEN(entry) == HEf_SVKEY) {
1511         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1512     }
1513     hv_free_ent(hv, entry);
1514 }
1515
1516 /*
1517 =for apidoc hv_clear
1518
1519 Clears a hash, making it empty.
1520
1521 =cut
1522 */
1523
1524 void
1525 Perl_hv_clear(pTHX_ HV *hv)
1526 {
1527     dVAR;
1528     register XPVHV* xhv;
1529     if (!hv)
1530         return;
1531
1532     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1533
1534     xhv = (XPVHV*)SvANY(hv);
1535
1536     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1537         /* restricted hash: convert all keys to placeholders */
1538         STRLEN i;
1539         for (i = 0; i <= xhv->xhv_max; i++) {
1540             HE *entry = (HvARRAY(hv))[i];
1541             for (; entry; entry = HeNEXT(entry)) {
1542                 /* not already placeholder */
1543                 if (HeVAL(entry) != &PL_sv_placeholder) {
1544                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1545                         SV* const keysv = hv_iterkeysv(entry);
1546                         Perl_croak(aTHX_
1547                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1548                                    (void*)keysv);
1549                     }
1550                     SvREFCNT_dec(HeVAL(entry));
1551                     HeVAL(entry) = &PL_sv_placeholder;
1552                     HvPLACEHOLDERS(hv)++;
1553                 }
1554             }
1555         }
1556         goto reset;
1557     }
1558
1559     hfreeentries(hv);
1560     HvPLACEHOLDERS_set(hv, 0);
1561     if (HvARRAY(hv))
1562         Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1563
1564     if (SvRMAGICAL(hv))
1565         mg_clear(MUTABLE_SV(hv));
1566
1567     HvHASKFLAGS_off(hv);
1568     HvREHASH_off(hv);
1569     reset:
1570     if (SvOOK(hv)) {
1571         if(HvENAME_get(hv))
1572             mro_isa_changed_in(hv);
1573         HvEITER_set(hv, NULL);
1574     }
1575 }
1576
1577 /*
1578 =for apidoc hv_clear_placeholders
1579
1580 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1581 marked as readonly and the key is subsequently deleted, the key is not actually
1582 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1583 it so it will be ignored by future operations such as iterating over the hash,
1584 but will still allow the hash to have a value reassigned to the key at some
1585 future point.  This function clears any such placeholder keys from the hash.
1586 See Hash::Util::lock_keys() for an example of its use.
1587
1588 =cut
1589 */
1590
1591 void
1592 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1593 {
1594     dVAR;
1595     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1596
1597     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1598
1599     if (items)
1600         clear_placeholders(hv, items);
1601 }
1602
1603 static void
1604 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1605 {
1606     dVAR;
1607     I32 i;
1608
1609     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1610
1611     if (items == 0)
1612         return;
1613
1614     i = HvMAX(hv);
1615     do {
1616         /* Loop down the linked list heads  */
1617         bool first = TRUE;
1618         HE **oentry = &(HvARRAY(hv))[i];
1619         HE *entry;
1620
1621         while ((entry = *oentry)) {
1622             if (HeVAL(entry) == &PL_sv_placeholder) {
1623                 *oentry = HeNEXT(entry);
1624                 if (entry == HvEITER_get(hv))
1625                     HvLAZYDEL_on(hv);
1626                 else
1627                     hv_free_ent(hv, entry);
1628
1629                 if (--items == 0) {
1630                     /* Finished.  */
1631                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1632                     if (HvKEYS(hv) == 0)
1633                         HvHASKFLAGS_off(hv);
1634                     HvPLACEHOLDERS_set(hv, 0);
1635                     return;
1636                 }
1637             } else {
1638                 oentry = &HeNEXT(entry);
1639                 first = FALSE;
1640             }
1641         }
1642     } while (--i >= 0);
1643     /* You can't get here, hence assertion should always fail.  */
1644     assert (items == 0);
1645     assert (0);
1646 }
1647
1648 STATIC void
1649 S_hfreeentries(pTHX_ HV *hv)
1650 {
1651     /* This is the array that we're going to restore  */
1652     HE **const orig_array = HvARRAY(hv);
1653     HEK *name;
1654     I32 name_count;
1655     int attempts = 100;
1656
1657     PERL_ARGS_ASSERT_HFREEENTRIES;
1658
1659     if (!orig_array)
1660         return;
1661
1662     if (SvOOK(hv)) {
1663         /* If the hash is actually a symbol table with a name, look after the
1664            name.  */
1665         struct xpvhv_aux *iter = HvAUX(hv);
1666
1667         name = iter->xhv_name;
1668         name_count = iter->xhv_name_count;
1669         iter->xhv_name = NULL;
1670     } else {
1671         name = NULL;
1672         name_count = 0;
1673     }
1674
1675     /* orig_array remains unchanged throughout the loop. If after freeing all
1676        the entries it turns out that one of the little blighters has triggered
1677        an action that has caused HvARRAY to be re-allocated, then we set
1678        array to the new HvARRAY, and try again.  */
1679
1680     while (1) {
1681         /* This is the one we're going to try to empty.  First time round
1682            it's the original array.  (Hopefully there will only be 1 time
1683            round) */
1684         HE ** const array = HvARRAY(hv);
1685         I32 i = HvMAX(hv);
1686
1687         /* Because we have taken xhv_name out, the only allocated pointer
1688            in the aux structure that might exist is the backreference array.
1689         */
1690
1691         if (SvOOK(hv)) {
1692             HE *entry;
1693             struct mro_meta *meta;
1694             struct xpvhv_aux *iter = HvAUX(hv);
1695             /* weak references: if called from sv_clear(), the backrefs
1696              * should already have been killed; if there are any left, its
1697              * because we're doing hv_clear() or hv_undef(), and the HV
1698              * will continue to live.
1699              * Because while freeing the entries we fake up a NULL HvARRAY
1700              * (and hence HvAUX), we need to store the backref array
1701              * somewhere else; but it still needs to be visible in case
1702              * any the things we free happen to call sv_del_backref().
1703              * We do this by storing it in magic instead.
1704              * If, during the entry freeing, a destructor happens to add
1705              * a new weak backref, then sv_add_backref will look in both
1706              * places (magic in HvAUX) for the AV, but will create a new
1707              * AV in HvAUX if it can't find one (if it finds it in magic,
1708              * it moves it back into HvAUX. So at the end of the iteration
1709              * we have to allow for this. */
1710
1711
1712             if (iter->xhv_backreferences) {
1713                 if (SvTYPE(iter->xhv_backreferences) == SVt_PVAV) {
1714                     /* The sv_magic will increase the reference count of the AV,
1715                        so we need to drop it first. */
1716                     SvREFCNT_dec(iter->xhv_backreferences);
1717                     if (AvFILLp(iter->xhv_backreferences) == -1) {
1718                         /* Turns out that the array is empty. Just free it.  */
1719                         SvREFCNT_dec(iter->xhv_backreferences);
1720
1721                     } else {
1722                         sv_magic(MUTABLE_SV(hv),
1723                                  MUTABLE_SV(iter->xhv_backreferences),
1724                                  PERL_MAGIC_backref, NULL, 0);
1725                     }
1726                 }
1727                 else {
1728                     MAGIC *mg;
1729                     sv_magic(MUTABLE_SV(hv), NULL, PERL_MAGIC_backref, NULL, 0);
1730                     mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_backref);
1731                     mg->mg_obj = (SV*)iter->xhv_backreferences;
1732                 }
1733                 iter->xhv_backreferences = NULL;
1734             }
1735
1736             entry = iter->xhv_eiter; /* HvEITER(hv) */
1737             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1738                 HvLAZYDEL_off(hv);
1739                 hv_free_ent(hv, entry);
1740             }
1741             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1742             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1743
1744             if((meta = iter->xhv_mro_meta)) {
1745                 if (meta->mro_linear_all) {
1746                     SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
1747                     meta->mro_linear_all = NULL;
1748                     /* This is just acting as a shortcut pointer.  */
1749                     meta->mro_linear_current = NULL;
1750                 } else if (meta->mro_linear_current) {
1751                     /* Only the current MRO is stored, so this owns the data.
1752                      */
1753                     SvREFCNT_dec(meta->mro_linear_current);
1754                     meta->mro_linear_current = NULL;
1755                 }
1756                 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1757                 SvREFCNT_dec(meta->isa);
1758                 Safefree(meta);
1759                 iter->xhv_mro_meta = NULL;
1760             }
1761
1762             /* There are now no allocated pointers in the aux structure.  */
1763
1764             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
1765             /* What aux structure?  */
1766         }
1767
1768         /* make everyone else think the array is empty, so that the destructors
1769          * called for freed entries can't recursively mess with us */
1770         HvARRAY(hv) = NULL;
1771         ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1772
1773
1774         do {
1775             /* Loop down the linked list heads  */
1776             HE *entry = array[i];
1777
1778             while (entry) {
1779                 register HE * const oentry = entry;
1780                 entry = HeNEXT(entry);
1781                 hv_free_ent(hv, oentry);
1782             }
1783         } while (--i >= 0);
1784
1785         /* As there are no allocated pointers in the aux structure, it's now
1786            safe to free the array we just cleaned up, if it's not the one we're
1787            going to put back.  */
1788         if (array != orig_array) {
1789             Safefree(array);
1790         }
1791
1792         if (!HvARRAY(hv)) {
1793             /* Good. No-one added anything this time round.  */
1794             break;
1795         }
1796
1797         if (SvOOK(hv)) {
1798             /* Someone attempted to iterate or set the hash name while we had
1799                the array set to 0.  We'll catch backferences on the next time
1800                round the while loop.  */
1801             assert(HvARRAY(hv));
1802
1803             if (HvAUX(hv)->xhv_name) {
1804                 if(HvAUX(hv)->xhv_name_count) {
1805                     HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
1806                     I32 const count = HvAUX(hv)->xhv_name_count;
1807                     HEK **hekp = name + (count < 0 ? -count : count);
1808                     while(hekp-- > name) 
1809                         unshare_hek_or_pvn(*hekp, 0, 0, 0);
1810                     Safefree(name);
1811                 }
1812                 else unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1813             }
1814         }
1815
1816         if (--attempts == 0) {
1817             Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1818         }
1819     }
1820         
1821     HvARRAY(hv) = orig_array;
1822
1823     /* If the hash was actually a symbol table, put the name back.  */
1824     if (name) {
1825         /* We have restored the original array.  If name is non-NULL, then
1826            the original array had an aux structure at the end. So this is
1827            valid:  */
1828         struct xpvhv_aux * const aux = HvAUX(hv);
1829         SvFLAGS(hv) |= SVf_OOK;
1830         aux->xhv_name = name;
1831         aux->xhv_name_count = name_count;
1832     }
1833 }
1834
1835 /*
1836 =for apidoc hv_undef
1837
1838 Undefines the hash.
1839
1840 =cut
1841 */
1842
1843 void
1844 Perl_hv_undef(pTHX_ HV *hv)
1845 {
1846     dVAR;
1847     register XPVHV* xhv;
1848     const char *name;
1849
1850     if (!hv)
1851         return;
1852     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1853     xhv = (XPVHV*)SvANY(hv);
1854
1855     if ((name = HvENAME_get(hv)) && !PL_dirty)
1856         mro_isa_changed_in(hv);
1857
1858     hfreeentries(hv);
1859     if (name || (name = HvNAME(hv))) {
1860         if (PL_stashcache)
1861             (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1862         hv_name_set(hv, NULL, 0, 0);
1863     }
1864     SvFLAGS(hv) &= ~SVf_OOK;
1865     Safefree(HvARRAY(hv));
1866     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1867     HvARRAY(hv) = 0;
1868     HvPLACEHOLDERS_set(hv, 0);
1869
1870     if (SvRMAGICAL(hv))
1871         mg_clear(MUTABLE_SV(hv));
1872 }
1873
1874 /*
1875 =for apidoc hv_fill
1876
1877 Returns the number of hash buckets that happen to be in use. This function is
1878 wrapped by the macro C<HvFILL>.
1879
1880 Previously this value was stored in the HV structure, rather than being
1881 calculated on demand.
1882
1883 =cut
1884 */
1885
1886 STRLEN
1887 Perl_hv_fill(pTHX_ HV const *const hv)
1888 {
1889     STRLEN count = 0;
1890     HE **ents = HvARRAY(hv);
1891
1892     PERL_ARGS_ASSERT_HV_FILL;
1893
1894     if (ents) {
1895         HE *const *const last = ents + HvMAX(hv);
1896         count = last + 1 - ents;
1897
1898         do {
1899             if (!*ents)
1900                 --count;
1901         } while (++ents <= last);
1902     }
1903     return count;
1904 }
1905
1906 static struct xpvhv_aux*
1907 S_hv_auxinit(HV *hv) {
1908     struct xpvhv_aux *iter;
1909     char *array;
1910
1911     PERL_ARGS_ASSERT_HV_AUXINIT;
1912
1913     if (!HvARRAY(hv)) {
1914         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1915             + sizeof(struct xpvhv_aux), char);
1916     } else {
1917         array = (char *) HvARRAY(hv);
1918         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1919               + sizeof(struct xpvhv_aux), char);
1920     }
1921     HvARRAY(hv) = (HE**) array;
1922     /* SvOOK_on(hv) attacks the IV flags.  */
1923     SvFLAGS(hv) |= SVf_OOK;
1924     iter = HvAUX(hv);
1925
1926     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1927     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1928     iter->xhv_name = 0;
1929     iter->xhv_name_count = 0;
1930     iter->xhv_backreferences = 0;
1931     iter->xhv_mro_meta = NULL;
1932     return iter;
1933 }
1934
1935 /*
1936 =for apidoc hv_iterinit
1937
1938 Prepares a starting point to traverse a hash table.  Returns the number of
1939 keys in the hash (i.e. the same as C<HvKEYS(hv)>).  The return value is
1940 currently only meaningful for hashes without tie magic.
1941
1942 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1943 hash buckets that happen to be in use.  If you still need that esoteric
1944 value, you can get it through the macro C<HvFILL(hv)>.
1945
1946
1947 =cut
1948 */
1949
1950 I32
1951 Perl_hv_iterinit(pTHX_ HV *hv)
1952 {
1953     PERL_ARGS_ASSERT_HV_ITERINIT;
1954
1955     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1956
1957     if (!hv)
1958         Perl_croak(aTHX_ "Bad hash");
1959
1960     if (SvOOK(hv)) {
1961         struct xpvhv_aux * const iter = HvAUX(hv);
1962         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1963         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1964             HvLAZYDEL_off(hv);
1965             hv_free_ent(hv, entry);
1966         }
1967         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1968         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1969     } else {
1970         hv_auxinit(hv);
1971     }
1972
1973     /* used to be xhv->xhv_fill before 5.004_65 */
1974     return HvTOTALKEYS(hv);
1975 }
1976
1977 I32 *
1978 Perl_hv_riter_p(pTHX_ HV *hv) {
1979     struct xpvhv_aux *iter;
1980
1981     PERL_ARGS_ASSERT_HV_RITER_P;
1982
1983     if (!hv)
1984         Perl_croak(aTHX_ "Bad hash");
1985
1986     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1987     return &(iter->xhv_riter);
1988 }
1989
1990 HE **
1991 Perl_hv_eiter_p(pTHX_ HV *hv) {
1992     struct xpvhv_aux *iter;
1993
1994     PERL_ARGS_ASSERT_HV_EITER_P;
1995
1996     if (!hv)
1997         Perl_croak(aTHX_ "Bad hash");
1998
1999     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2000     return &(iter->xhv_eiter);
2001 }
2002
2003 void
2004 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2005     struct xpvhv_aux *iter;
2006
2007     PERL_ARGS_ASSERT_HV_RITER_SET;
2008
2009     if (!hv)
2010         Perl_croak(aTHX_ "Bad hash");
2011
2012     if (SvOOK(hv)) {
2013         iter = HvAUX(hv);
2014     } else {
2015         if (riter == -1)
2016             return;
2017
2018         iter = hv_auxinit(hv);
2019     }
2020     iter->xhv_riter = riter;
2021 }
2022
2023 void
2024 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2025     struct xpvhv_aux *iter;
2026
2027     PERL_ARGS_ASSERT_HV_EITER_SET;
2028
2029     if (!hv)
2030         Perl_croak(aTHX_ "Bad hash");
2031
2032     if (SvOOK(hv)) {
2033         iter = HvAUX(hv);
2034     } else {
2035         /* 0 is the default so don't go malloc()ing a new structure just to
2036            hold 0.  */
2037         if (!eiter)
2038             return;
2039
2040         iter = hv_auxinit(hv);
2041     }
2042     iter->xhv_eiter = eiter;
2043 }
2044
2045 void
2046 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2047 {
2048     dVAR;
2049     struct xpvhv_aux *iter;
2050     U32 hash;
2051     HEK **spot;
2052
2053     PERL_ARGS_ASSERT_HV_NAME_SET;
2054     PERL_UNUSED_ARG(flags);
2055
2056     if (len > I32_MAX)
2057         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2058
2059     if (SvOOK(hv)) {
2060         iter = HvAUX(hv);
2061         if (iter->xhv_name) {
2062             if(iter->xhv_name_count) {
2063               if(!name) {
2064                 HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
2065                 HEK **hekp = name + (
2066                     iter->xhv_name_count < 0
2067                      ? -iter->xhv_name_count
2068                      :  iter->xhv_name_count
2069                    );
2070                 while(hekp-- > name+1) 
2071                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2072                 /* The first elem may be null. */
2073                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2074                 Safefree(name);
2075                 spot = &iter->xhv_name;
2076                 iter->xhv_name_count = 0;
2077               }
2078               else {
2079                 spot = (HEK **)iter->xhv_name;
2080                 if(iter->xhv_name_count > 0) {
2081                     /* shift some things over */
2082                     Renew(spot, iter->xhv_name_count, HEK *);
2083                     spot[iter->xhv_name_count++] = spot[1];
2084                     spot[1] = spot[0];
2085                 }
2086                 else if(*spot) {
2087                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2088                 }
2089               }
2090             }
2091             else {
2092                 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2093                 spot = &iter->xhv_name;
2094             }
2095         }
2096         else spot = &iter->xhv_name;
2097     } else {
2098         if (name == 0)
2099             return;
2100
2101         iter = hv_auxinit(hv);
2102         spot = &iter->xhv_name;
2103     }
2104     PERL_HASH(hash, name, len);
2105     *spot = name ? share_hek(name, len, hash) : NULL;
2106     iter->xhv_name_count = 0;
2107 }
2108
2109 void
2110 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len)
2111 {
2112     dVAR;
2113     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2114     U32 hash;
2115
2116     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2117
2118     if (len > I32_MAX)
2119         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2120
2121     PERL_HASH(hash, name, len);
2122
2123     if (aux->xhv_name_count) {
2124         HEK ** const xhv_name = (HEK **)aux->xhv_name;
2125         I32 count = aux->xhv_name_count;
2126         HEK **hekp = xhv_name + (count < 0 ? -count : count);
2127         while (hekp-- > xhv_name)
2128             if (
2129              HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
2130             ) {
2131                 if (hekp == xhv_name && count < 0)
2132                     aux->xhv_name_count = -count;
2133                 return;
2134             }
2135         if (count < 0) aux->xhv_name_count--, count = -count;
2136         else aux->xhv_name_count++;
2137         Renewc(aux->xhv_name, count + 1, HEK *, HEK);
2138         ((HEK **)aux->xhv_name)[count] = share_hek(name, len, hash);
2139     }
2140     else {
2141         HEK *existing_name = aux->xhv_name;
2142         if (
2143             existing_name && HEK_LEN(existing_name) == (I32)len
2144          && memEQ(HEK_KEY(existing_name), name, len)
2145         ) return;
2146         Newxc(aux->xhv_name, 2, HEK *, HEK);
2147         aux->xhv_name_count = existing_name ? 2 : -2;
2148         *(HEK **)aux->xhv_name = existing_name;
2149         ((HEK **)aux->xhv_name)[1] = share_hek(name, len, hash);
2150     }
2151 }
2152
2153 void
2154 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len)
2155 {
2156     dVAR;
2157     struct xpvhv_aux *aux;
2158
2159     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2160
2161     if (len > I32_MAX)
2162         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2163
2164     if (!SvOOK(hv)) return;
2165
2166     aux = HvAUX(hv);
2167     if (!aux->xhv_name) return;
2168
2169     if (aux->xhv_name_count) {
2170         HEK ** const namep = (HEK **)aux->xhv_name;
2171         I32 const count = aux->xhv_name_count;
2172         HEK **victim = namep + (count < 0 ? -count : count);
2173         while (victim-- > namep + 1)
2174             if (
2175                 HEK_LEN(*victim) == (I32)len
2176              && memEQ(HEK_KEY(*victim), name, len)
2177             ) {
2178                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2179                 if (count < 0) ++aux->xhv_name_count;
2180                 else --aux->xhv_name_count;
2181                 if (
2182                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2183                  && !*namep
2184                 ) {  /* if there are none left */
2185                     Safefree(namep);
2186                     aux->xhv_name = NULL;
2187                     aux->xhv_name_count = 0;
2188                 }
2189                 else {
2190                     /* Move the last one back to fill the empty slot. It
2191                        does not matter what order they are in. */
2192                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2193                 }
2194                 return;
2195             }
2196         if (
2197             count > 0 && HEK_LEN(*namep) == (I32)len
2198          && memEQ(HEK_KEY(*namep),name,len)
2199         ) {
2200             aux->xhv_name_count = -count;
2201         }
2202     }
2203     else if(
2204         HEK_LEN(aux->xhv_name) == (I32)len
2205      && memEQ(HEK_KEY(aux->xhv_name), name, len)
2206     ) {
2207         const HEK * const namehek = aux->xhv_name;
2208         Newxc(aux->xhv_name, 1, HEK *, HEK);
2209         *(const HEK **)aux->xhv_name = namehek;
2210         aux->xhv_name_count = -1;
2211     }
2212 }
2213
2214 AV **
2215 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2216     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2217
2218     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2219     PERL_UNUSED_CONTEXT;
2220
2221     return &(iter->xhv_backreferences);
2222 }
2223
2224 void
2225 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2226     AV *av;
2227
2228     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2229
2230     if (!SvOOK(hv))
2231         return;
2232
2233     av = HvAUX(hv)->xhv_backreferences;
2234
2235     if (av) {
2236         HvAUX(hv)->xhv_backreferences = 0;
2237         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2238         if (SvTYPE(av) == SVt_PVAV)
2239             SvREFCNT_dec(av);
2240     }
2241 }
2242
2243 /*
2244 hv_iternext is implemented as a macro in hv.h
2245
2246 =for apidoc hv_iternext
2247
2248 Returns entries from a hash iterator.  See C<hv_iterinit>.
2249
2250 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2251 iterator currently points to, without losing your place or invalidating your
2252 iterator.  Note that in this case the current entry is deleted from the hash
2253 with your iterator holding the last reference to it.  Your iterator is flagged
2254 to free the entry on the next call to C<hv_iternext>, so you must not discard
2255 your iterator immediately else the entry will leak - call C<hv_iternext> to
2256 trigger the resource deallocation.
2257
2258 =for apidoc hv_iternext_flags
2259
2260 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2261 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2262 set the placeholders keys (for restricted hashes) will be returned in addition
2263 to normal keys. By default placeholders are automatically skipped over.
2264 Currently a placeholder is implemented with a value that is
2265 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2266 restricted hashes may change, and the implementation currently is
2267 insufficiently abstracted for any change to be tidy.
2268
2269 =cut
2270 */
2271
2272 HE *
2273 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2274 {
2275     dVAR;
2276     register XPVHV* xhv;
2277     register HE *entry;
2278     HE *oldentry;
2279     MAGIC* mg;
2280     struct xpvhv_aux *iter;
2281
2282     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2283
2284     if (!hv)
2285         Perl_croak(aTHX_ "Bad hash");
2286
2287     xhv = (XPVHV*)SvANY(hv);
2288
2289     if (!SvOOK(hv)) {
2290         /* Too many things (well, pp_each at least) merrily assume that you can
2291            call iv_iternext without calling hv_iterinit, so we'll have to deal
2292            with it.  */
2293         hv_iterinit(hv);
2294     }
2295     iter = HvAUX(hv);
2296
2297     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2298     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2299         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2300             SV * const key = sv_newmortal();
2301             if (entry) {
2302                 sv_setsv(key, HeSVKEY_force(entry));
2303                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2304             }
2305             else {
2306                 char *k;
2307                 HEK *hek;
2308
2309                 /* one HE per MAGICAL hash */
2310                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2311                 Zero(entry, 1, HE);
2312                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2313                 hek = (HEK*)k;
2314                 HeKEY_hek(entry) = hek;
2315                 HeKLEN(entry) = HEf_SVKEY;
2316             }
2317             magic_nextpack(MUTABLE_SV(hv),mg,key);
2318             if (SvOK(key)) {
2319                 /* force key to stay around until next time */
2320                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2321                 return entry;               /* beware, hent_val is not set */
2322             }
2323             SvREFCNT_dec(HeVAL(entry));
2324             Safefree(HeKEY_hek(entry));
2325             del_HE(entry);
2326             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2327             return NULL;
2328         }
2329     }
2330 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2331     if (!entry && SvRMAGICAL((const SV *)hv)
2332         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2333         prime_env_iter();
2334 #ifdef VMS
2335         /* The prime_env_iter() on VMS just loaded up new hash values
2336          * so the iteration count needs to be reset back to the beginning
2337          */
2338         hv_iterinit(hv);
2339         iter = HvAUX(hv);
2340         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2341 #endif
2342     }
2343 #endif
2344
2345     /* hv_iterint now ensures this.  */
2346     assert (HvARRAY(hv));
2347
2348     /* At start of hash, entry is NULL.  */
2349     if (entry)
2350     {
2351         entry = HeNEXT(entry);
2352         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2353             /*
2354              * Skip past any placeholders -- don't want to include them in
2355              * any iteration.
2356              */
2357             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2358                 entry = HeNEXT(entry);
2359             }
2360         }
2361     }
2362
2363     /* Skip the entire loop if the hash is empty.   */
2364     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2365         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2366         while (!entry) {
2367             /* OK. Come to the end of the current list.  Grab the next one.  */
2368
2369             iter->xhv_riter++; /* HvRITER(hv)++ */
2370             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2371                 /* There is no next one.  End of the hash.  */
2372                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2373                 break;
2374             }
2375             entry = (HvARRAY(hv))[iter->xhv_riter];
2376
2377             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2378                 /* If we have an entry, but it's a placeholder, don't count it.
2379                    Try the next.  */
2380                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2381                     entry = HeNEXT(entry);
2382             }
2383             /* Will loop again if this linked list starts NULL
2384                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2385                or if we run through it and find only placeholders.  */
2386         }
2387     }
2388
2389     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2390         HvLAZYDEL_off(hv);
2391         hv_free_ent(hv, oldentry);
2392     }
2393
2394     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2395       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2396
2397     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2398     return entry;
2399 }
2400
2401 /*
2402 =for apidoc hv_iterkey
2403
2404 Returns the key from the current position of the hash iterator.  See
2405 C<hv_iterinit>.
2406
2407 =cut
2408 */
2409
2410 char *
2411 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2412 {
2413     PERL_ARGS_ASSERT_HV_ITERKEY;
2414
2415     if (HeKLEN(entry) == HEf_SVKEY) {
2416         STRLEN len;
2417         char * const p = SvPV(HeKEY_sv(entry), len);
2418         *retlen = len;
2419         return p;
2420     }
2421     else {
2422         *retlen = HeKLEN(entry);
2423         return HeKEY(entry);
2424     }
2425 }
2426
2427 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2428 /*
2429 =for apidoc hv_iterkeysv
2430
2431 Returns the key as an C<SV*> from the current position of the hash
2432 iterator.  The return value will always be a mortal copy of the key.  Also
2433 see C<hv_iterinit>.
2434
2435 =cut
2436 */
2437
2438 SV *
2439 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2440 {
2441     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2442
2443     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2444 }
2445
2446 /*
2447 =for apidoc hv_iterval
2448
2449 Returns the value from the current position of the hash iterator.  See
2450 C<hv_iterkey>.
2451
2452 =cut
2453 */
2454
2455 SV *
2456 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2457 {
2458     PERL_ARGS_ASSERT_HV_ITERVAL;
2459
2460     if (SvRMAGICAL(hv)) {
2461         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2462             SV* const sv = sv_newmortal();
2463             if (HeKLEN(entry) == HEf_SVKEY)
2464                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2465             else
2466                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2467             return sv;
2468         }
2469     }
2470     return HeVAL(entry);
2471 }
2472
2473 /*
2474 =for apidoc hv_iternextsv
2475
2476 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2477 operation.
2478
2479 =cut
2480 */
2481
2482 SV *
2483 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2484 {
2485     HE * const he = hv_iternext_flags(hv, 0);
2486
2487     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2488
2489     if (!he)
2490         return NULL;
2491     *key = hv_iterkey(he, retlen);
2492     return hv_iterval(hv, he);
2493 }
2494
2495 /*
2496
2497 Now a macro in hv.h
2498
2499 =for apidoc hv_magic
2500
2501 Adds magic to a hash.  See C<sv_magic>.
2502
2503 =cut
2504 */
2505
2506 /* possibly free a shared string if no one has access to it
2507  * len and hash must both be valid for str.
2508  */
2509 void
2510 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2511 {
2512     unshare_hek_or_pvn (NULL, str, len, hash);
2513 }
2514
2515
2516 void
2517 Perl_unshare_hek(pTHX_ HEK *hek)
2518 {
2519     assert(hek);
2520     unshare_hek_or_pvn(hek, NULL, 0, 0);
2521 }
2522
2523 /* possibly free a shared string if no one has access to it
2524    hek if non-NULL takes priority over the other 3, else str, len and hash
2525    are used.  If so, len and hash must both be valid for str.
2526  */
2527 STATIC void
2528 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2529 {
2530     dVAR;
2531     register XPVHV* xhv;
2532     HE *entry;
2533     register HE **oentry;
2534     HE **first;
2535     bool is_utf8 = FALSE;
2536     int k_flags = 0;
2537     const char * const save = str;
2538     struct shared_he *he = NULL;
2539
2540     if (hek) {
2541         /* Find the shared he which is just before us in memory.  */
2542         he = (struct shared_he *)(((char *)hek)
2543                                   - STRUCT_OFFSET(struct shared_he,
2544                                                   shared_he_hek));
2545
2546         /* Assert that the caller passed us a genuine (or at least consistent)
2547            shared hek  */
2548         assert (he->shared_he_he.hent_hek == hek);
2549
2550         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2551             --he->shared_he_he.he_valu.hent_refcount;
2552             return;
2553         }
2554
2555         hash = HEK_HASH(hek);
2556     } else if (len < 0) {
2557         STRLEN tmplen = -len;
2558         is_utf8 = TRUE;
2559         /* See the note in hv_fetch(). --jhi */
2560         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2561         len = tmplen;
2562         if (is_utf8)
2563             k_flags = HVhek_UTF8;
2564         if (str != save)
2565             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2566     }
2567
2568     /* what follows was the moral equivalent of:
2569     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2570         if (--*Svp == NULL)
2571             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2572     } */
2573     xhv = (XPVHV*)SvANY(PL_strtab);
2574     /* assert(xhv_array != 0) */
2575     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2576     if (he) {
2577         const HE *const he_he = &(he->shared_he_he);
2578         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2579             if (entry == he_he)
2580                 break;
2581         }
2582     } else {
2583         const int flags_masked = k_flags & HVhek_MASK;
2584         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2585             if (HeHASH(entry) != hash)          /* strings can't be equal */
2586                 continue;
2587             if (HeKLEN(entry) != len)
2588                 continue;
2589             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2590                 continue;
2591             if (HeKFLAGS(entry) != flags_masked)
2592                 continue;
2593             break;
2594         }
2595     }
2596
2597     if (entry) {
2598         if (--entry->he_valu.hent_refcount == 0) {
2599             *oentry = HeNEXT(entry);
2600             Safefree(entry);
2601             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2602         }
2603     }
2604
2605     if (!entry)
2606         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2607                          "Attempt to free non-existent shared string '%s'%s"
2608                          pTHX__FORMAT,
2609                          hek ? HEK_KEY(hek) : str,
2610                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2611     if (k_flags & HVhek_FREEKEY)
2612         Safefree(str);
2613 }
2614
2615 /* get a (constant) string ptr from the global string table
2616  * string will get added if it is not already there.
2617  * len and hash must both be valid for str.
2618  */
2619 HEK *
2620 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2621 {
2622     bool is_utf8 = FALSE;
2623     int flags = 0;
2624     const char * const save = str;
2625
2626     PERL_ARGS_ASSERT_SHARE_HEK;
2627
2628     if (len < 0) {
2629       STRLEN tmplen = -len;
2630       is_utf8 = TRUE;
2631       /* See the note in hv_fetch(). --jhi */
2632       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2633       len = tmplen;
2634       /* If we were able to downgrade here, then than means that we were passed
2635          in a key which only had chars 0-255, but was utf8 encoded.  */
2636       if (is_utf8)
2637           flags = HVhek_UTF8;
2638       /* If we found we were able to downgrade the string to bytes, then
2639          we should flag that it needs upgrading on keys or each.  Also flag
2640          that we need share_hek_flags to free the string.  */
2641       if (str != save)
2642           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2643     }
2644
2645     return share_hek_flags (str, len, hash, flags);
2646 }
2647
2648 STATIC HEK *
2649 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2650 {
2651     dVAR;
2652     register HE *entry;
2653     const int flags_masked = flags & HVhek_MASK;
2654     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2655     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2656
2657     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2658
2659     /* what follows is the moral equivalent of:
2660
2661     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2662         hv_store(PL_strtab, str, len, NULL, hash);
2663
2664         Can't rehash the shared string table, so not sure if it's worth
2665         counting the number of entries in the linked list
2666     */
2667
2668     /* assert(xhv_array != 0) */
2669     entry = (HvARRAY(PL_strtab))[hindex];
2670     for (;entry; entry = HeNEXT(entry)) {
2671         if (HeHASH(entry) != hash)              /* strings can't be equal */
2672             continue;
2673         if (HeKLEN(entry) != len)
2674             continue;
2675         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2676             continue;
2677         if (HeKFLAGS(entry) != flags_masked)
2678             continue;
2679         break;
2680     }
2681
2682     if (!entry) {
2683         /* What used to be head of the list.
2684            If this is NULL, then we're the first entry for this slot, which
2685            means we need to increate fill.  */
2686         struct shared_he *new_entry;
2687         HEK *hek;
2688         char *k;
2689         HE **const head = &HvARRAY(PL_strtab)[hindex];
2690         HE *const next = *head;
2691
2692         /* We don't actually store a HE from the arena and a regular HEK.
2693            Instead we allocate one chunk of memory big enough for both,
2694            and put the HEK straight after the HE. This way we can find the
2695            HEK directly from the HE.
2696         */
2697
2698         Newx(k, STRUCT_OFFSET(struct shared_he,
2699                                 shared_he_hek.hek_key[0]) + len + 2, char);
2700         new_entry = (struct shared_he *)k;
2701         entry = &(new_entry->shared_he_he);
2702         hek = &(new_entry->shared_he_hek);
2703
2704         Copy(str, HEK_KEY(hek), len, char);
2705         HEK_KEY(hek)[len] = 0;
2706         HEK_LEN(hek) = len;
2707         HEK_HASH(hek) = hash;
2708         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2709
2710         /* Still "point" to the HEK, so that other code need not know what
2711            we're up to.  */
2712         HeKEY_hek(entry) = hek;
2713         entry->he_valu.hent_refcount = 0;
2714         HeNEXT(entry) = next;
2715         *head = entry;
2716
2717         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2718         if (!next) {                    /* initial entry? */
2719         } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2720                 hsplit(PL_strtab);
2721         }
2722     }
2723
2724     ++entry->he_valu.hent_refcount;
2725
2726     if (flags & HVhek_FREEKEY)
2727         Safefree(str);
2728
2729     return HeKEY_hek(entry);
2730 }
2731
2732 I32 *
2733 Perl_hv_placeholders_p(pTHX_ HV *hv)
2734 {
2735     dVAR;
2736     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2737
2738     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2739
2740     if (!mg) {
2741         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2742
2743         if (!mg) {
2744             Perl_die(aTHX_ "panic: hv_placeholders_p");
2745         }
2746     }
2747     return &(mg->mg_len);
2748 }
2749
2750
2751 I32
2752 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2753 {
2754     dVAR;
2755     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2756
2757     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2758
2759     return mg ? mg->mg_len : 0;
2760 }
2761
2762 void
2763 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2764 {
2765     dVAR;
2766     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2767
2768     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2769
2770     if (mg) {
2771         mg->mg_len = ph;
2772     } else if (ph) {
2773         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2774             Perl_die(aTHX_ "panic: hv_placeholders_set");
2775     }
2776     /* else we don't need to add magic to record 0 placeholders.  */
2777 }
2778
2779 STATIC SV *
2780 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2781 {
2782     dVAR;
2783     SV *value;
2784
2785     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2786
2787     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2788     case HVrhek_undef:
2789         value = newSV(0);
2790         break;
2791     case HVrhek_delete:
2792         value = &PL_sv_placeholder;
2793         break;
2794     case HVrhek_IV:
2795         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2796         break;
2797     case HVrhek_UV:
2798         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2799         break;
2800     case HVrhek_PV:
2801     case HVrhek_PV_UTF8:
2802         /* Create a string SV that directly points to the bytes in our
2803            structure.  */
2804         value = newSV_type(SVt_PV);
2805         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2806         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2807         /* This stops anything trying to free it  */
2808         SvLEN_set(value, 0);
2809         SvPOK_on(value);
2810         SvREADONLY_on(value);
2811         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2812             SvUTF8_on(value);
2813         break;
2814     default:
2815         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2816                    (UV)he->refcounted_he_data[0]);
2817     }
2818     return value;
2819 }
2820
2821 /*
2822 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
2823
2824 Generates and returns a C<HV *> representing the content of a
2825 C<refcounted_he> chain.
2826 I<flags> is currently unused and must be zero.
2827
2828 =cut
2829 */
2830 HV *
2831 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
2832 {
2833     dVAR;
2834     HV *hv;
2835     U32 placeholders, max;
2836
2837     if (flags)
2838         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
2839             (UV)flags);
2840
2841     /* We could chase the chain once to get an idea of the number of keys,
2842        and call ksplit.  But for now we'll make a potentially inefficient
2843        hash with only 8 entries in its array.  */
2844     hv = newHV();
2845     max = HvMAX(hv);
2846     if (!HvARRAY(hv)) {
2847         char *array;
2848         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2849         HvARRAY(hv) = (HE**)array;
2850     }
2851
2852     placeholders = 0;
2853     while (chain) {
2854 #ifdef USE_ITHREADS
2855         U32 hash = chain->refcounted_he_hash;
2856 #else
2857         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2858 #endif
2859         HE **oentry = &((HvARRAY(hv))[hash & max]);
2860         HE *entry = *oentry;
2861         SV *value;
2862
2863         for (; entry; entry = HeNEXT(entry)) {
2864             if (HeHASH(entry) == hash) {
2865                 /* We might have a duplicate key here.  If so, entry is older
2866                    than the key we've already put in the hash, so if they are
2867                    the same, skip adding entry.  */
2868 #ifdef USE_ITHREADS
2869                 const STRLEN klen = HeKLEN(entry);
2870                 const char *const key = HeKEY(entry);
2871                 if (klen == chain->refcounted_he_keylen
2872                     && (!!HeKUTF8(entry)
2873                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2874                     && memEQ(key, REF_HE_KEY(chain), klen))
2875                     goto next_please;
2876 #else
2877                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2878                     goto next_please;
2879                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2880                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2881                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2882                              HeKLEN(entry)))
2883                     goto next_please;
2884 #endif
2885             }
2886         }
2887         assert (!entry);
2888         entry = new_HE();
2889
2890 #ifdef USE_ITHREADS
2891         HeKEY_hek(entry)
2892             = share_hek_flags(REF_HE_KEY(chain),
2893                               chain->refcounted_he_keylen,
2894                               chain->refcounted_he_hash,
2895                               (chain->refcounted_he_data[0]
2896                                & (HVhek_UTF8|HVhek_WASUTF8)));
2897 #else
2898         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2899 #endif
2900         value = refcounted_he_value(chain);
2901         if (value == &PL_sv_placeholder)
2902             placeholders++;
2903         HeVAL(entry) = value;
2904
2905         /* Link it into the chain.  */
2906         HeNEXT(entry) = *oentry;
2907         *oentry = entry;
2908
2909         HvTOTALKEYS(hv)++;
2910
2911     next_please:
2912         chain = chain->refcounted_he_next;
2913     }
2914
2915     if (placeholders) {
2916         clear_placeholders(hv, placeholders);
2917         HvTOTALKEYS(hv) -= placeholders;
2918     }
2919
2920     /* We could check in the loop to see if we encounter any keys with key
2921        flags, but it's probably not worth it, as this per-hash flag is only
2922        really meant as an optimisation for things like Storable.  */
2923     HvHASKFLAGS_on(hv);
2924     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2925
2926     return hv;
2927 }
2928
2929 /*
2930 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
2931
2932 Search along a C<refcounted_he> chain for an entry with the key specified
2933 by I<keypv> and I<keylen>.  If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
2934 bit set, the key octets are interpreted as UTF-8, otherwise they
2935 are interpreted as Latin-1.  I<hash> is a precomputed hash of the key
2936 string, or zero if it has not been precomputed.  Returns a mortal scalar
2937 representing the value associated with the key, or C<&PL_sv_placeholder>
2938 if there is no value associated with the key.
2939
2940 =cut
2941 */
2942
2943 SV *
2944 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
2945                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
2946 {
2947     dVAR;
2948     U8 utf8_flag;
2949     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
2950
2951     if (flags & ~REFCOUNTED_HE_KEY_UTF8)
2952         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
2953             (UV)flags);
2954     if (!chain)
2955         return &PL_sv_placeholder;
2956     if (flags & REFCOUNTED_HE_KEY_UTF8) {
2957         /* For searching purposes, canonicalise to Latin-1 where possible. */
2958         const char *keyend = keypv + keylen, *p;
2959         STRLEN nonascii_count = 0;
2960         for (p = keypv; p != keyend; p++) {
2961             U8 c = (U8)*p;
2962             if (c & 0x80) {
2963                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
2964                             (((U8)*p) & 0xc0) == 0x80))
2965                     goto canonicalised_key;
2966                 nonascii_count++;
2967             }
2968         }
2969         if (nonascii_count) {
2970             char *q;
2971             const char *p = keypv, *keyend = keypv + keylen;
2972             keylen -= nonascii_count;
2973             Newx(q, keylen, char);
2974             SAVEFREEPV(q);
2975             keypv = q;
2976             for (; p != keyend; p++, q++) {
2977                 U8 c = (U8)*p;
2978                 *q = (char)
2979                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
2980             }
2981         }
2982         flags &= ~REFCOUNTED_HE_KEY_UTF8;
2983         canonicalised_key: ;
2984     }
2985     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
2986     if (!hash)
2987         PERL_HASH(hash, keypv, keylen);
2988
2989     for (; chain; chain = chain->refcounted_he_next) {
2990         if (
2991 #ifdef USE_ITHREADS
2992             hash == chain->refcounted_he_hash &&
2993             keylen == chain->refcounted_he_keylen &&
2994             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
2995             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
2996 #else
2997             hash == HEK_HASH(chain->refcounted_he_hek) &&
2998             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
2999             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3000             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3001 #endif
3002         )
3003             return sv_2mortal(refcounted_he_value(chain));
3004     }
3005     return &PL_sv_placeholder;
3006 }
3007
3008 /*
3009 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3010
3011 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3012 instead of a string/length pair.
3013
3014 =cut
3015 */
3016
3017 SV *
3018 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3019                          const char *key, U32 hash, U32 flags)
3020 {
3021     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3022     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3023 }
3024
3025 /*
3026 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3027
3028 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3029 string/length pair.
3030
3031 =cut
3032 */
3033
3034 SV *
3035 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3036                          SV *key, U32 hash, U32 flags)
3037 {
3038     const char *keypv;
3039     STRLEN keylen;
3040     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3041     if (flags & REFCOUNTED_HE_KEY_UTF8)
3042         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3043             (UV)flags);
3044     keypv = SvPV_const(key, keylen);
3045     if (SvUTF8(key))
3046         flags |= REFCOUNTED_HE_KEY_UTF8;
3047     if (!hash && SvIsCOW_shared_hash(key))
3048         hash = SvSHARED_HASH(key);
3049     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3050 }
3051
3052 /*
3053 =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
3054
3055 Creates a new C<refcounted_he>.  This consists of a single key/value
3056 pair and a reference to an existing C<refcounted_he> chain (which may
3057 be empty), and thus forms a longer chain.  When using the longer chain,
3058 the new key/value pair takes precedence over any entry for the same key
3059 further along the chain.
3060
3061 The new key is specified by I<keypv> and I<keylen>.  If I<flags> has
3062 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3063 as UTF-8, otherwise they are interpreted as Latin-1.  I<hash> is
3064 a precomputed hash of the key string, or zero if it has not been
3065 precomputed.
3066
3067 I<value> is the scalar value to store for this key.  I<value> is copied
3068 by this function, which thus does not take ownership of any reference
3069 to it, and later changes to the scalar will not be reflected in the
3070 value visible in the C<refcounted_he>.  Complex types of scalar will not
3071 be stored with referential integrity, but will be coerced to strings.
3072 I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3073 value is to be associated with the key; this, as with any non-null value,
3074 takes precedence over the existence of a value for the key further along
3075 the chain.
3076
3077 I<parent> points to the rest of the C<refcounted_he> chain to be
3078 attached to the new C<refcounted_he>.  This function takes ownership
3079 of one reference to I<parent>, and returns one reference to the new
3080 C<refcounted_he>.
3081
3082 =cut
3083 */
3084
3085 struct refcounted_he *
3086 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3087         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3088 {
3089     dVAR;
3090     STRLEN value_len = 0;
3091     const char *value_p = NULL;
3092     bool is_pv;
3093     char value_type;
3094     char hekflags;
3095     STRLEN key_offset = 1;
3096     struct refcounted_he *he;
3097     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3098
3099     if (!value || value == &PL_sv_placeholder) {
3100         value_type = HVrhek_delete;
3101     } else if (SvPOK(value)) {
3102         value_type = HVrhek_PV;
3103     } else if (SvIOK(value)) {
3104         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3105     } else if (!SvOK(value)) {
3106         value_type = HVrhek_undef;
3107     } else {
3108         value_type = HVrhek_PV;
3109     }
3110     is_pv = value_type == HVrhek_PV;
3111     if (is_pv) {
3112         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3113            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3114         value_p = SvPV_const(value, value_len);
3115         if (SvUTF8(value))
3116             value_type = HVrhek_PV_UTF8;
3117         key_offset = value_len + 2;
3118     }
3119     hekflags = value_type;
3120
3121     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3122         /* Canonicalise to Latin-1 where possible. */
3123         const char *keyend = keypv + keylen, *p;
3124         STRLEN nonascii_count = 0;
3125         for (p = keypv; p != keyend; p++) {
3126             U8 c = (U8)*p;
3127             if (c & 0x80) {
3128                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3129                             (((U8)*p) & 0xc0) == 0x80))
3130                     goto canonicalised_key;
3131                 nonascii_count++;
3132             }
3133         }
3134         if (nonascii_count) {
3135             char *q;
3136             const char *p = keypv, *keyend = keypv + keylen;
3137             keylen -= nonascii_count;
3138             Newx(q, keylen, char);
3139             SAVEFREEPV(q);
3140             keypv = q;
3141             for (; p != keyend; p++, q++) {
3142                 U8 c = (U8)*p;
3143                 *q = (char)
3144                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3145             }
3146         }
3147         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3148         canonicalised_key: ;
3149     }
3150     if (flags & REFCOUNTED_HE_KEY_UTF8)
3151         hekflags |= HVhek_UTF8;
3152     if (!hash)
3153         PERL_HASH(hash, keypv, keylen);
3154
3155 #ifdef USE_ITHREADS
3156     he = (struct refcounted_he*)
3157         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3158                              + keylen
3159                              + key_offset);
3160 #else
3161     he = (struct refcounted_he*)
3162         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3163                              + key_offset);
3164 #endif
3165
3166     he->refcounted_he_next = parent;
3167
3168     if (is_pv) {
3169         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3170         he->refcounted_he_val.refcounted_he_u_len = value_len;
3171     } else if (value_type == HVrhek_IV) {
3172         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3173     } else if (value_type == HVrhek_UV) {
3174         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3175     }
3176
3177 #ifdef USE_ITHREADS
3178     he->refcounted_he_hash = hash;
3179     he->refcounted_he_keylen = keylen;
3180     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3181 #else
3182     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3183 #endif
3184
3185     he->refcounted_he_data[0] = hekflags;
3186     he->refcounted_he_refcnt = 1;
3187
3188     return he;
3189 }
3190
3191 /*
3192 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3193
3194 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3195 of a string/length pair.
3196
3197 =cut
3198 */
3199
3200 struct refcounted_he *
3201 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3202         const char *key, U32 hash, SV *value, U32 flags)
3203 {
3204     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3205     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3206 }
3207
3208 /*
3209 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3210
3211 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3212 string/length pair.
3213
3214 =cut
3215 */
3216
3217 struct refcounted_he *
3218 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3219         SV *key, U32 hash, SV *value, U32 flags)
3220 {
3221     const char *keypv;
3222     STRLEN keylen;
3223     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3224     if (flags & REFCOUNTED_HE_KEY_UTF8)
3225         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3226             (UV)flags);
3227     keypv = SvPV_const(key, keylen);
3228     if (SvUTF8(key))
3229         flags |= REFCOUNTED_HE_KEY_UTF8;
3230     if (!hash && SvIsCOW_shared_hash(key))
3231         hash = SvSHARED_HASH(key);
3232     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3233 }
3234
3235 /*
3236 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3237
3238 Decrements the reference count of a C<refcounted_he> by one.  If the
3239 reference count reaches zero the structure's memory is freed, which
3240 (recursively) causes a reduction of its parent C<refcounted_he>'s
3241 reference count.  It is safe to pass a null pointer to this function:
3242 no action occurs in this case.
3243
3244 =cut
3245 */
3246
3247 void
3248 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3249     dVAR;
3250     PERL_UNUSED_CONTEXT;
3251
3252     while (he) {
3253         struct refcounted_he *copy;
3254         U32 new_count;
3255
3256         HINTS_REFCNT_LOCK;
3257         new_count = --he->refcounted_he_refcnt;
3258         HINTS_REFCNT_UNLOCK;
3259         
3260         if (new_count) {
3261             return;
3262         }
3263
3264 #ifndef USE_ITHREADS
3265         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3266 #endif
3267         copy = he;
3268         he = he->refcounted_he_next;
3269         PerlMemShared_free(copy);
3270     }
3271 }
3272
3273 /*
3274 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3275
3276 Increment the reference count of a C<refcounted_he>.  The pointer to the
3277 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3278 to this function: no action occurs and a null pointer is returned.
3279
3280 =cut
3281 */
3282
3283 struct refcounted_he *
3284 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3285 {
3286     if (he) {
3287         HINTS_REFCNT_LOCK;
3288         he->refcounted_he_refcnt++;
3289         HINTS_REFCNT_UNLOCK;
3290     }
3291     return he;
3292 }
3293
3294 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3295    the linked list.  */
3296 const char *
3297 Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3298     struct refcounted_he *const chain = cop->cop_hints_hash;
3299
3300     PERL_ARGS_ASSERT_FETCH_COP_LABEL;
3301
3302     if (!chain)
3303         return NULL;
3304 #ifdef USE_ITHREADS
3305     if (chain->refcounted_he_keylen != 1)
3306         return NULL;
3307     if (*REF_HE_KEY(chain) != ':')
3308         return NULL;
3309 #else
3310     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3311         return NULL;
3312     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3313         return NULL;
3314 #endif
3315     /* Stop anyone trying to really mess us up by adding their own value for
3316        ':' into %^H  */
3317     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3318         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3319         return NULL;
3320
3321     if (len)
3322         *len = chain->refcounted_he_val.refcounted_he_u_len;
3323     if (flags) {
3324         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3325                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3326     }
3327     return chain->refcounted_he_data + 1;
3328 }
3329
3330 void
3331 Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3332                      U32 flags)
3333 {
3334     SV *labelsv;
3335     PERL_ARGS_ASSERT_STORE_COP_LABEL;
3336
3337     if (flags & ~(SVf_UTF8))
3338         Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
3339                    (UV)flags);
3340     labelsv = sv_2mortal(newSVpvn(label, len));
3341     if (flags & SVf_UTF8)
3342         SvUTF8_on(labelsv);
3343     cop->cop_hints_hash
3344         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3345 }
3346
3347 /*
3348 =for apidoc hv_assert
3349
3350 Check that a hash is in an internally consistent state.
3351
3352 =cut
3353 */
3354
3355 #ifdef DEBUGGING
3356
3357 void
3358 Perl_hv_assert(pTHX_ HV *hv)
3359 {
3360     dVAR;
3361     HE* entry;
3362     int withflags = 0;
3363     int placeholders = 0;
3364     int real = 0;
3365     int bad = 0;
3366     const I32 riter = HvRITER_get(hv);
3367     HE *eiter = HvEITER_get(hv);
3368
3369     PERL_ARGS_ASSERT_HV_ASSERT;
3370
3371     (void)hv_iterinit(hv);
3372
3373     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3374         /* sanity check the values */
3375         if (HeVAL(entry) == &PL_sv_placeholder)
3376             placeholders++;
3377         else
3378             real++;
3379         /* sanity check the keys */
3380         if (HeSVKEY(entry)) {
3381             NOOP;   /* Don't know what to check on SV keys.  */
3382         } else if (HeKUTF8(entry)) {
3383             withflags++;
3384             if (HeKWASUTF8(entry)) {
3385                 PerlIO_printf(Perl_debug_log,
3386                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3387                             (int) HeKLEN(entry),  HeKEY(entry));
3388                 bad = 1;
3389             }
3390         } else if (HeKWASUTF8(entry))
3391             withflags++;
3392     }
3393     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3394         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3395         const int nhashkeys = HvUSEDKEYS(hv);
3396         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3397
3398         if (nhashkeys != real) {
3399             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3400             bad = 1;
3401         }
3402         if (nhashplaceholders != placeholders) {
3403             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3404             bad = 1;
3405         }
3406     }
3407     if (withflags && ! HvHASKFLAGS(hv)) {
3408         PerlIO_printf(Perl_debug_log,
3409                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3410                     withflags);
3411         bad = 1;
3412     }
3413     if (bad) {
3414         sv_dump(MUTABLE_SV(hv));
3415     }
3416     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3417     HvEITER_set(hv, eiter);
3418 }
3419
3420 #endif
3421
3422 /*
3423  * Local variables:
3424  * c-indentation-style: bsd
3425  * c-basic-offset: 4
3426  * indent-tabs-mode: t
3427  * End:
3428  *
3429  * ex: set ts=8 sts=4 sw=4 noet:
3430  */