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