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