This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
da1f48786979af672df447d9cbd1f30e664d78aa
[perl5.git] / hv.c
1 /*    hv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 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 of all that I have seen."  --Bilbo
13  */
14
15 /* 
16 =head1 Hash Manipulation Functions
17 */
18
19 #include "EXTERN.h"
20 #define PERL_IN_HV_C
21 #define PERL_HASH_INTERNAL_ACCESS
22 #include "perl.h"
23
24 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
25
26 STATIC HE*
27 S_new_he(pTHX)
28 {
29     HE* he;
30     LOCK_SV_MUTEX;
31     if (!PL_he_root)
32         more_he();
33     he = PL_he_root;
34     PL_he_root = HeNEXT(he);
35     UNLOCK_SV_MUTEX;
36     return he;
37 }
38
39 STATIC void
40 S_del_he(pTHX_ HE *p)
41 {
42     LOCK_SV_MUTEX;
43     HeNEXT(p) = (HE*)PL_he_root;
44     PL_he_root = p;
45     UNLOCK_SV_MUTEX;
46 }
47
48 STATIC void
49 S_more_he(pTHX)
50 {
51     register HE* he;
52     register HE* heend;
53     XPV *ptr;
54     New(54, ptr, 1008/sizeof(XPV), XPV);
55     ptr->xpv_pv = (char*)PL_he_arenaroot;
56     PL_he_arenaroot = ptr;
57
58     he = (HE*)ptr;
59     heend = &he[1008 / sizeof(HE) - 1];
60     PL_he_root = ++he;
61     while (he < heend) {
62         HeNEXT(he) = (HE*)(he + 1);
63         he++;
64     }
65     HeNEXT(he) = 0;
66 }
67
68 #ifdef PURIFY
69
70 #define new_HE() (HE*)safemalloc(sizeof(HE))
71 #define del_HE(p) safefree((char*)p)
72
73 #else
74
75 #define new_HE() new_he()
76 #define del_HE(p) del_he(p)
77
78 #endif
79
80 STATIC HEK *
81 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
82 {
83     char *k;
84     register HEK *hek;
85
86     New(54, k, HEK_BASESIZE + len + 2, char);
87     hek = (HEK*)k;
88     Copy(str, HEK_KEY(hek), len, char);
89     HEK_KEY(hek)[len] = 0;
90     HEK_LEN(hek) = len;
91     HEK_HASH(hek) = hash;
92     HEK_FLAGS(hek) = (unsigned char)flags;
93     return hek;
94 }
95
96 /* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
97  * for tied hashes */
98
99 void
100 Perl_free_tied_hv_pool(pTHX)
101 {
102     HE *ohe;
103     HE *he = PL_hv_fetch_ent_mh;
104     while (he) {
105         Safefree(HeKEY_hek(he));
106         ohe = he;
107         he = HeNEXT(he);
108         del_HE(ohe);
109     }
110     PL_hv_fetch_ent_mh = Nullhe;
111 }
112
113 #if defined(USE_ITHREADS)
114 HE *
115 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
116 {
117     HE *ret;
118
119     if (!e)
120         return Nullhe;
121     /* look for it in the table first */
122     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
123     if (ret)
124         return ret;
125
126     /* create anew and remember what it is */
127     ret = new_HE();
128     ptr_table_store(PL_ptr_table, e, ret);
129
130     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
131     if (HeKLEN(e) == HEf_SVKEY) {
132         char *k;
133         New(54, k, HEK_BASESIZE + sizeof(SV*), char);
134         HeKEY_hek(ret) = (HEK*)k;
135         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
136     }
137     else if (shared)
138         HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
139                                          HeKFLAGS(e));
140     else
141         HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
142                                         HeKFLAGS(e));
143     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
144     return ret;
145 }
146 #endif  /* USE_ITHREADS */
147
148 static void
149 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
150                 const char *msg)
151 {
152     SV *sv = sv_newmortal(), *esv = sv_newmortal();
153     if (!(flags & HVhek_FREEKEY)) {
154         sv_setpvn(sv, key, klen);
155     }
156     else {
157         /* Need to free saved eventually assign to mortal SV */
158         /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
159         sv_usepvn(sv, (char *) key, klen);
160     }
161     if (flags & HVhek_UTF8) {
162         SvUTF8_on(sv);
163     }
164     Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
165     Perl_croak(aTHX_ SvPVX(esv), sv);
166 }
167
168 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
169  * contains an SV* */
170
171 /*
172 =for apidoc hv_fetch
173
174 Returns the SV which corresponds to the specified key in the hash.  The
175 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
176 part of a store.  Check that the return value is non-null before
177 dereferencing it to an C<SV*>.
178
179 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
180 information on how to use this function on tied hashes.
181
182 =cut
183 */
184
185 #define HV_FETCH_ISSTORE   0x01
186 #define HV_FETCH_ISEXISTS  0x02
187 #define HV_FETCH_LVALUE    0x04
188 #define HV_FETCH_JUST_SV   0x08
189
190 SV**
191 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
192 {
193     HE *hek;
194     STRLEN klen;
195     int flags;
196
197     if (klen_i32 < 0) {
198         klen = -klen_i32;
199         flags = HVhek_UTF8;
200     } else {
201         klen = klen_i32;
202         flags = 0;
203     }
204     hek = hv_fetch_common (hv, NULL, key, klen, flags,
205                            HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0),
206                            Nullsv, 0);
207     return hek ? &HeVAL(hek) : NULL;
208 }
209
210 /* returns an HE * structure with the all fields set */
211 /* note that hent_val will be a mortal sv for MAGICAL hashes */
212 /*
213 =for apidoc hv_fetch_ent
214
215 Returns the hash entry which corresponds to the specified key in the hash.
216 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
217 if you want the function to compute it.  IF C<lval> is set then the fetch
218 will be part of a store.  Make sure the return value is non-null before
219 accessing it.  The return value when C<tb> is a tied hash is a pointer to a
220 static location, so be sure to make a copy of the structure if you need to
221 store it somewhere.
222
223 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
224 information on how to use this function on tied hashes.
225
226 =cut
227 */
228
229 HE *
230 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
231 {
232     return hv_fetch_common(hv, keysv, NULL, 0, 0, 
233                            (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
234 }
235
236 HE *
237 S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
238                   int flags, int action, SV *val, register U32 hash)
239 {
240     XPVHV* xhv;
241     U32 n_links;
242     HE *entry;
243     HE **oentry;
244     SV *sv;
245     bool is_utf8;
246     int masked_flags;
247
248     if (!hv)
249         return 0;
250
251     if (keysv) {
252         key = SvPV(keysv, klen);
253         flags = 0;
254         is_utf8 = (SvUTF8(keysv) != 0);
255     } else {
256         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
257     }
258
259     xhv = (XPVHV*)SvANY(hv);
260     if (SvMAGICAL(hv)) {
261         if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
262           {
263             if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
264                 sv = sv_newmortal();
265
266                 /* XXX should be able to skimp on the HE/HEK here when
267                    HV_FETCH_JUST_SV is true.  */
268
269                 if (!keysv) {
270                     keysv = newSVpvn(key, klen);
271                     if (is_utf8) {
272                         SvUTF8_on(keysv);
273                     }
274                 } else {
275                     keysv = newSVsv(keysv);
276                 }
277                 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
278
279                 /* grab a fake HE/HEK pair from the pool or make a new one */
280                 entry = PL_hv_fetch_ent_mh;
281                 if (entry)
282                     PL_hv_fetch_ent_mh = HeNEXT(entry);
283                 else {
284                     char *k;
285                     entry = new_HE();
286                     New(54, k, HEK_BASESIZE + sizeof(SV*), char);
287                     HeKEY_hek(entry) = (HEK*)k;
288                 }
289                 HeNEXT(entry) = Nullhe;
290                 HeSVKEY_set(entry, keysv);
291                 HeVAL(entry) = sv;
292                 sv_upgrade(sv, SVt_PVLV);
293                 LvTYPE(sv) = 'T';
294                  /* so we can free entry when freeing sv */
295                 LvTARG(sv) = (SV*)entry;
296
297                 /* XXX remove at some point? */
298                 if (flags & HVhek_FREEKEY)
299                     Safefree(key);
300
301                 return entry;
302             }
303 #ifdef ENV_IS_CASELESS
304             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
305                 U32 i;
306                 for (i = 0; i < klen; ++i)
307                     if (isLOWER(key[i])) {
308                         const char *keysave = key;
309                         /* Will need to free this, so set FREEKEY flag
310                            on call to hv_fetch_common.  */
311                         key = savepvn(key,klen);
312                         key = (const char*)strupr((char*)key);
313
314                         if (flags & HVhek_FREEKEY)
315                             Safefree(keysave);
316
317                         /* This isn't strictly the same as the old hv_fetch
318                            magic, which made a call to hv_fetch, followed
319                            by a call to hv_store if that failed and lvalue
320                            was true.
321                            Which I believe could have been done by simply
322                            passing the lvalue through to the first hv_fetch.
323                            So I will do that here.  */
324                         return hv_fetch_common(hv, Nullsv, key, klen,
325                                                HVhek_FREEKEY,
326                                                action, Nullsv, 0);
327                     }
328             }
329 #endif
330         } /* ISFETCH */
331         else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
332             if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
333                 SV* svret;
334                 /* I don't understand why hv_exists_ent has svret and sv,
335                    whereas hv_exists only had one.  */
336                 svret = sv_newmortal();
337                 sv = sv_newmortal();
338
339                 if (keysv || is_utf8) {
340                     if (!keysv) {
341                         keysv = newSVpvn(key, klen);
342                         SvUTF8_on(keysv);
343                     } else {
344                         keysv = newSVsv(keysv);
345                     }
346                     mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
347                 } else {
348                     mg_copy((SV*)hv, sv, key, klen);
349                 }
350                 if (flags & HVhek_FREEKEY)
351                     Safefree(key);
352                 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
353                 /* This cast somewhat evil, but I'm merely using NULL/
354                    not NULL to return the boolean exists.
355                    And I know hv is not NULL.  */
356                 return SvTRUE(svret) ? (HE *)hv : NULL;
357                 }
358 #ifdef ENV_IS_CASELESS
359             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
360                 /* XXX This code isn't UTF8 clean.  */
361                 const char *keysave = key;
362                 /* Will need to free this, so set FREEKEY flag.  */
363                 key = savepvn(key,klen);
364                 key = (const char*)strupr((char*)key);
365                 is_utf8 = 0;
366                 hash = 0;
367
368                 if (flags & HVhek_FREEKEY) {
369                     Safefree(keysave);
370                 }
371                 flags |= HVhek_FREEKEY;
372             }
373 #endif
374         } /* ISEXISTS */
375         else if (action & HV_FETCH_ISSTORE) {
376             bool needs_copy;
377             bool needs_store;
378             hv_magic_check (hv, &needs_copy, &needs_store);
379             if (needs_copy) {
380                 bool save_taint = PL_tainted;   
381                 if (keysv || is_utf8) {
382                     if (!keysv) {
383                         keysv = newSVpvn(key, klen);
384                         SvUTF8_on(keysv);
385                     }
386                     if (PL_tainting)
387                         PL_tainted = SvTAINTED(keysv);
388                     keysv = sv_2mortal(newSVsv(keysv));
389                     mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
390                 } else {
391                     mg_copy((SV*)hv, val, key, klen);
392                 }
393
394                 TAINT_IF(save_taint);
395                 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) {
396                     if (flags & HVhek_FREEKEY)
397                         Safefree(key);
398                     return Nullhe;
399                 }
400 #ifdef ENV_IS_CASELESS
401                 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
402                     /* XXX This code isn't UTF8 clean.  */
403                     const char *keysave = key;
404                     /* Will need to free this, so set FREEKEY flag.  */
405                     key = savepvn(key,klen);
406                     key = (const char*)strupr((char*)key);
407                     is_utf8 = 0;
408                     hash = 0;
409
410                     if (flags & HVhek_FREEKEY) {
411                         Safefree(keysave);
412                     }
413                     flags |= HVhek_FREEKEY;
414                 }
415 #endif
416             }
417         } /* ISSTORE */
418     } /* SvMAGICAL */
419
420     if (!xhv->xhv_array /* !HvARRAY(hv) */) {
421         if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
422 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
423                  || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
424 #endif
425                                                                   )
426             Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
427                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
428                  char);
429 #ifdef DYNAMIC_ENV_FETCH
430         else if (action & HV_FETCH_ISEXISTS) {
431             /* for an %ENV exists, if we do an insert it's by a recursive
432                store call, so avoid creating HvARRAY(hv) right now.  */
433         }
434 #endif
435         else {
436             /* XXX remove at some point? */
437             if (flags & HVhek_FREEKEY)
438                 Safefree(key);
439
440             return 0;
441         }
442     }
443
444     if (is_utf8) {
445         const char *keysave = key;
446         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
447         if (is_utf8)
448             flags |= HVhek_UTF8;
449         else
450             flags &= ~HVhek_UTF8;
451         if (key != keysave) {
452             if (flags & HVhek_FREEKEY)
453                 Safefree(keysave);
454             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
455         }
456     }
457
458     if (HvREHASH(hv)) {
459         PERL_HASH_INTERNAL(hash, key, klen);
460         /* We don't have a pointer to the hv, so we have to replicate the
461            flag into every HEK, so that hv_iterkeysv can see it.  */
462         /* And yes, you do need this even though you are not "storing" because
463            you can flip the flags below if doing an lval lookup.  (And that
464            was put in to give the semantics Andreas was expecting.)  */
465         flags |= HVhek_REHASH;
466     } else if (!hash) {
467         if (keysv && (SvIsCOW_shared_hash(keysv))) {
468             hash = SvUVX(keysv);
469         } else {
470             PERL_HASH(hash, key, klen);
471         }
472     }
473
474     masked_flags = (flags & HVhek_MASK);
475     n_links = 0;
476
477 #ifdef DYNAMIC_ENV_FETCH
478     if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
479     else
480 #endif
481     {
482         /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
483         oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
484         entry = *oentry;
485     }
486     for (; entry; ++n_links, entry = HeNEXT(entry)) {
487         if (HeHASH(entry) != hash)              /* strings can't be equal */
488             continue;
489         if (HeKLEN(entry) != (I32)klen)
490             continue;
491         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
492             continue;
493         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
494             continue;
495
496         if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
497             if (HeKFLAGS(entry) != masked_flags) {
498                 /* We match if HVhek_UTF8 bit in our flags and hash key's
499                    match.  But if entry was set previously with HVhek_WASUTF8
500                    and key now doesn't (or vice versa) then we should change
501                    the key's flag, as this is assignment.  */
502                 if (HvSHAREKEYS(hv)) {
503                     /* Need to swap the key we have for a key with the flags we
504                        need. As keys are shared we can't just write to the
505                        flag, so we share the new one, unshare the old one.  */
506                     HEK *new_hek = share_hek_flags(key, klen, hash,
507                                                    masked_flags);
508                     unshare_hek (HeKEY_hek(entry));
509                     HeKEY_hek(entry) = new_hek;
510                 }
511                 else
512                     HeKFLAGS(entry) = masked_flags;
513                 if (masked_flags & HVhek_ENABLEHVKFLAGS)
514                     HvHASKFLAGS_on(hv);
515             }
516             if (HeVAL(entry) == &PL_sv_placeholder) {
517                 /* yes, can store into placeholder slot */
518                 if (action & HV_FETCH_LVALUE) {
519                     if (SvMAGICAL(hv)) {
520                         /* This preserves behaviour with the old hv_fetch
521                            implementation which at this point would bail out
522                            with a break; (at "if we find a placeholder, we
523                            pretend we haven't found anything")
524
525                            That break mean that if a placeholder were found, it
526                            caused a call into hv_store, which in turn would
527                            check magic, and if there is no magic end up pretty
528                            much back at this point (in hv_store's code).  */
529                         break;
530                     }
531                     /* LVAL fetch which actaully needs a store.  */
532                     val = NEWSV(61,0);
533                     xhv->xhv_placeholders--;
534                 } else {
535                     /* store */
536                     if (val != &PL_sv_placeholder)
537                         xhv->xhv_placeholders--;
538                 }
539                 HeVAL(entry) = val;
540             } else if (action & HV_FETCH_ISSTORE) {
541                 SvREFCNT_dec(HeVAL(entry));
542                 HeVAL(entry) = val;
543             }
544         } else if (HeVAL(entry) == &PL_sv_placeholder) {
545             /* if we find a placeholder, we pretend we haven't found
546                anything */
547             break;
548         }
549         if (flags & HVhek_FREEKEY)
550             Safefree(key);
551         return entry;
552     }
553 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
554     if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
555         unsigned long len;
556         char *env = PerlEnv_ENVgetenv_len(key,&len);
557         if (env) {
558             sv = newSVpvn(env,len);
559             SvTAINTED_on(sv);
560             return hv_fetch_common(hv,keysv,key,keylen,HV_FETCH_ISSTORE,sv,
561                                    hash);
562         }
563     }
564 #endif
565
566     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
567         S_hv_notallowed(aTHX_ flags, key, klen,
568                         "access disallowed key '%"SVf"' in"
569                         );
570     }
571     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
572         /* Not doing some form of store, so return failure.  */
573         if (flags & HVhek_FREEKEY)
574             Safefree(key);
575         return 0;
576     }
577     if (action & HV_FETCH_LVALUE) {
578         val = NEWSV(61,0);
579         if (SvMAGICAL(hv)) {
580             /* At this point the old hv_fetch code would call to hv_store,
581                which in turn might do some tied magic. So we need to make that
582                magic check happen.  */
583             /* gonna assign to this, so it better be there */
584             return hv_fetch_common(hv, keysv, key, klen, flags,
585                                    HV_FETCH_ISSTORE, val, hash);
586             /* XXX Surely that could leak if the fetch-was-store fails?
587                Just like the hv_fetch.  */
588         }
589     }
590
591     /* Welcome to hv_store...  */
592
593     if (!oentry) {
594         /* Not sure if we can get here.  I think the only case of oentry being
595            NULL is for %ENV with dynamic env fetch.  But that should disappear
596            with magic in the previous code.  */
597         Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
598              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
599              char);
600         oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
601     }
602
603     entry = new_HE();
604     /* share_hek_flags will do the free for us.  This might be considered
605        bad API design.  */
606     if (HvSHAREKEYS(hv))
607         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
608     else                                       /* gotta do the real thing */
609         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
610     HeVAL(entry) = val;
611     HeNEXT(entry) = *oentry;
612     *oentry = entry;
613
614     if (val == &PL_sv_placeholder)
615         xhv->xhv_placeholders++;
616     if (masked_flags & HVhek_ENABLEHVKFLAGS)
617         HvHASKFLAGS_on(hv);
618
619     xhv->xhv_keys++; /* HvKEYS(hv)++ */
620     if (!n_links) {                             /* initial entry? */
621         xhv->xhv_fill++; /* HvFILL(hv)++ */
622     } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
623                || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
624         /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
625            splits on a rehashed hash, as we're not going to split it again,
626            and if someone is lucky (evil) enough to get all the keys in one
627            list they could exhaust our memory as we repeatedly double the
628            number of buckets on every entry. Linear search feels a less worse
629            thing to do.  */
630         hsplit(hv);
631     }
632
633     return entry;
634 }
635
636 STATIC void
637 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
638 {
639     MAGIC *mg = SvMAGIC(hv);
640     *needs_copy = FALSE;
641     *needs_store = TRUE;
642     while (mg) {
643         if (isUPPER(mg->mg_type)) {
644             *needs_copy = TRUE;
645             switch (mg->mg_type) {
646             case PERL_MAGIC_tied:
647             case PERL_MAGIC_sig:
648                 *needs_store = FALSE;
649             }
650         }
651         mg = mg->mg_moremagic;
652     }
653 }
654
655 /*
656 =for apidoc hv_store
657
658 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
659 the length of the key.  The C<hash> parameter is the precomputed hash
660 value; if it is zero then Perl will compute it.  The return value will be
661 NULL if the operation failed or if the value did not need to be actually
662 stored within the hash (as in the case of tied hashes).  Otherwise it can
663 be dereferenced to get the original C<SV*>.  Note that the caller is
664 responsible for suitably incrementing the reference count of C<val> before
665 the call, and decrementing it if the function returned NULL.  Effectively
666 a successful hv_store takes ownership of one reference to C<val>.  This is
667 usually what you want; a newly created SV has a reference count of one, so
668 if all your code does is create SVs then store them in a hash, hv_store
669 will own the only reference to the new SV, and your code doesn't need to do
670 anything further to tidy up.  hv_store is not implemented as a call to
671 hv_store_ent, and does not create a temporary SV for the key, so if your
672 key data is not already in SV form then use hv_store in preference to
673 hv_store_ent.
674
675 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
676 information on how to use this function on tied hashes.
677
678 =cut
679 */
680
681 SV**
682 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
683 {
684     HE *hek;
685     STRLEN klen;
686     int flags;
687
688     if (klen_i32 < 0) {
689         klen = -klen_i32;
690         flags = HVhek_UTF8;
691     } else {
692         klen = klen_i32;
693         flags = 0;
694     }
695     hek = hv_fetch_common (hv, NULL, key, klen, flags,
696                            (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0);
697     return hek ? &HeVAL(hek) : NULL;
698 }
699
700 SV**
701 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
702                  register U32 hash, int flags)
703 {
704     HE *hek = hv_fetch_common (hv, NULL, key, klen, flags,
705                                (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
706     return hek ? &HeVAL(hek) : NULL;
707 }
708
709 /*
710 =for apidoc hv_store_ent
711
712 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
713 parameter is the precomputed hash value; if it is zero then Perl will
714 compute it.  The return value is the new hash entry so created.  It will be
715 NULL if the operation failed or if the value did not need to be actually
716 stored within the hash (as in the case of tied hashes).  Otherwise the
717 contents of the return value can be accessed using the C<He?> macros
718 described here.  Note that the caller is responsible for suitably
719 incrementing the reference count of C<val> before the call, and
720 decrementing it if the function returned NULL.  Effectively a successful
721 hv_store_ent takes ownership of one reference to C<val>.  This is
722 usually what you want; a newly created SV has a reference count of one, so
723 if all your code does is create SVs then store them in a hash, hv_store
724 will own the only reference to the new SV, and your code doesn't need to do
725 anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
726 unlike C<val> it does not take ownership of it, so maintaining the correct
727 reference count on C<key> is entirely the caller's responsibility.  hv_store
728 is not implemented as a call to hv_store_ent, and does not create a temporary
729 SV for the key, so if your key data is not already in SV form then use
730 hv_store in preference to hv_store_ent.
731
732 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
733 information on how to use this function on tied hashes.
734
735 =cut
736 */
737
738 HE *
739 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
740 {
741   return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
742 }
743
744 /*
745 =for apidoc hv_delete
746
747 Deletes a key/value pair in the hash.  The value SV is removed from the
748 hash and returned to the caller.  The C<klen> is the length of the key.
749 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
750 will be returned.
751
752 =cut
753 */
754
755 SV *
756 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
757 {
758     STRLEN klen;
759     int k_flags = 0;
760
761     if (klen_i32 < 0) {
762         klen = -klen_i32;
763         k_flags |= HVhek_UTF8;
764     } else {
765         klen = klen_i32;
766     }
767     return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
768 }
769
770 /*
771 =for apidoc hv_delete_ent
772
773 Deletes a key/value pair in the hash.  The value SV is removed from the
774 hash and returned to the caller.  The C<flags> value will normally be zero;
775 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
776 precomputed hash value, or 0 to ask for it to be computed.
777
778 =cut
779 */
780
781 SV *
782 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
783 {
784     return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
785 }
786
787 SV *
788 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
789                    int k_flags, I32 d_flags, U32 hash)
790 {
791     register XPVHV* xhv;
792     register I32 i;
793     register HE *entry;
794     register HE **oentry;
795     SV *sv;
796     bool is_utf8;
797     int masked_flags;
798
799     if (!hv)
800         return Nullsv;
801
802     if (keysv) {
803         key = SvPV(keysv, klen);
804         k_flags = 0;
805         is_utf8 = (SvUTF8(keysv) != 0);
806     } else {
807         is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
808     }
809
810     if (SvRMAGICAL(hv)) {
811         bool needs_copy;
812         bool needs_store;
813         hv_magic_check (hv, &needs_copy, &needs_store);
814
815         if (needs_copy) {
816             entry = hv_fetch_common(hv, keysv, key, klen,
817                                     k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
818                                     Nullsv, hash);
819             sv = entry ? HeVAL(entry) : NULL;
820             if (sv) {
821                 if (SvMAGICAL(sv)) {
822                     mg_clear(sv);
823                 }
824                 if (!needs_store) {
825                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
826                         /* No longer an element */
827                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
828                         return sv;
829                     }           
830                     return Nullsv;              /* element cannot be deleted */
831                 }
832             }
833 #ifdef ENV_IS_CASELESS
834             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
835                 /* XXX This code isn't UTF8 clean.  */
836                 keysv = sv_2mortal(newSVpvn(key,klen));
837                 key = strupr(SvPVX(keysv));
838
839                 if (k_flags & HVhek_FREEKEY) {
840                     Safefree(keysave);
841                 }
842
843                 is_utf8 = 0;
844                 k_flags = 0;
845                 hash = 0;
846             }
847 #endif
848         }
849     }
850     xhv = (XPVHV*)SvANY(hv);
851     if (!xhv->xhv_array /* !HvARRAY(hv) */)
852         return Nullsv;
853
854     if (is_utf8) {
855     const char *keysave = key;
856     key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
857
858         if (is_utf8)
859             k_flags |= HVhek_UTF8;
860         else
861             k_flags &= ~HVhek_UTF8;
862         if (key != keysave) {
863             if (k_flags & HVhek_FREEKEY) {
864                 /* This shouldn't happen if our caller does what we expect,
865                    but strictly the API allows it.  */
866                 Safefree(keysave);
867             }
868             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
869         }
870         HvHASKFLAGS_on((SV*)hv);
871     }
872
873     if (HvREHASH(hv)) {
874         PERL_HASH_INTERNAL(hash, key, klen);
875     } else if (!hash) {
876         if (keysv && (SvIsCOW_shared_hash(keysv))) {
877             hash = SvUVX(keysv);
878         } else {
879             PERL_HASH(hash, key, klen);
880         }
881         PERL_HASH(hash, key, klen);
882     }
883
884     masked_flags = (k_flags & HVhek_MASK);
885
886     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
887     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
888     entry = *oentry;
889     i = 1;
890     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
891         if (HeHASH(entry) != hash)              /* strings can't be equal */
892             continue;
893         if (HeKLEN(entry) != (I32)klen)
894             continue;
895         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
896             continue;
897         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
898             continue;
899         if (k_flags & HVhek_FREEKEY)
900             Safefree(key);
901
902         /* if placeholder is here, it's already been deleted.... */
903         if (HeVAL(entry) == &PL_sv_placeholder)
904         {
905             if (SvREADONLY(hv))
906                 return Nullsv; /* if still SvREADONLY, leave it deleted. */
907
908            /* okay, really delete the placeholder. */
909            *oentry = HeNEXT(entry);
910            if (i && !*oentry)
911                xhv->xhv_fill--; /* HvFILL(hv)-- */
912            if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
913                HvLAZYDEL_on(hv);
914            else
915                hv_free_ent(hv, entry);
916            xhv->xhv_keys--; /* HvKEYS(hv)-- */
917            if (xhv->xhv_keys == 0)
918                HvHASKFLAGS_off(hv);
919            xhv->xhv_placeholders--;
920            return Nullsv;
921         }
922         else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
923             S_hv_notallowed(aTHX_ k_flags, key, klen,
924                             "delete readonly key '%"SVf"' from"
925                             );
926         }
927
928         if (d_flags & G_DISCARD)
929             sv = Nullsv;
930         else {
931             sv = sv_2mortal(HeVAL(entry));
932             HeVAL(entry) = &PL_sv_placeholder;
933         }
934
935         /*
936          * If a restricted hash, rather than really deleting the entry, put
937          * a placeholder there. This marks the key as being "approved", so
938          * we can still access via not-really-existing key without raising
939          * an error.
940          */
941         if (SvREADONLY(hv)) {
942             HeVAL(entry) = &PL_sv_placeholder;
943             /* We'll be saving this slot, so the number of allocated keys
944              * doesn't go down, but the number placeholders goes up */
945             xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
946         } else {
947             *oentry = HeNEXT(entry);
948             if (i && !*oentry)
949                 xhv->xhv_fill--; /* HvFILL(hv)-- */
950             if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
951                 HvLAZYDEL_on(hv);
952             else
953                 hv_free_ent(hv, entry);
954             xhv->xhv_keys--; /* HvKEYS(hv)-- */
955             if (xhv->xhv_keys == 0)
956                 HvHASKFLAGS_off(hv);
957         }
958         return sv;
959     }
960     if (SvREADONLY(hv)) {
961         S_hv_notallowed(aTHX_ k_flags, key, klen,
962                         "delete disallowed key '%"SVf"' from"
963                         );
964     }
965
966     if (k_flags & HVhek_FREEKEY)
967         Safefree(key);
968     return Nullsv;
969 }
970
971 /*
972 =for apidoc hv_exists
973
974 Returns a boolean indicating whether the specified hash key exists.  The
975 C<klen> is the length of the key.
976
977 =cut
978 */
979
980 bool
981 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
982 {
983     STRLEN klen;
984     int flags;
985
986     if (klen_i32 < 0) {
987         klen = -klen_i32;
988         flags = HVhek_UTF8;
989     } else {
990         klen = klen_i32;
991         flags = 0;
992     }
993     return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
994         ? TRUE : FALSE;
995 }
996
997 /*
998 =for apidoc hv_exists_ent
999
1000 Returns a boolean indicating whether the specified hash key exists. C<hash>
1001 can be a valid precomputed hash value, or 0 to ask for it to be
1002 computed.
1003
1004 =cut
1005 */
1006
1007 bool
1008 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
1009 {
1010     return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
1011         ? TRUE : FALSE;
1012 }
1013
1014 STATIC void
1015 S_hsplit(pTHX_ HV *hv)
1016 {
1017     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1018     I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1019     register I32 newsize = oldsize * 2;
1020     register I32 i;
1021     register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1022     register HE **aep;
1023     register HE **bep;
1024     register HE *entry;
1025     register HE **oentry;
1026     int longest_chain = 0;
1027     int was_shared;
1028
1029     PL_nomemok = TRUE;
1030 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1031     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1032     if (!a) {
1033       PL_nomemok = FALSE;
1034       return;
1035     }
1036 #else
1037     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1038     if (!a) {
1039       PL_nomemok = FALSE;
1040       return;
1041     }
1042     Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1043     if (oldsize >= 64) {
1044         offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1045                         PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1046     }
1047     else
1048         Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1049 #endif
1050
1051     PL_nomemok = FALSE;
1052     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1053     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1054     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1055     aep = (HE**)a;
1056
1057     for (i=0; i<oldsize; i++,aep++) {
1058         int left_length = 0;
1059         int right_length = 0;
1060
1061         if (!*aep)                              /* non-existent */
1062             continue;
1063         bep = aep+oldsize;
1064         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1065             if ((HeHASH(entry) & newsize) != (U32)i) {
1066                 *oentry = HeNEXT(entry);
1067                 HeNEXT(entry) = *bep;
1068                 if (!*bep)
1069                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1070                 *bep = entry;
1071                 right_length++;
1072                 continue;
1073             }
1074             else {
1075                 oentry = &HeNEXT(entry);
1076                 left_length++;
1077             }
1078         }
1079         if (!*aep)                              /* everything moved */
1080             xhv->xhv_fill--; /* HvFILL(hv)-- */
1081         /* I think we don't actually need to keep track of the longest length,
1082            merely flag if anything is too long. But for the moment while
1083            developing this code I'll track it.  */
1084         if (left_length > longest_chain)
1085             longest_chain = left_length;
1086         if (right_length > longest_chain)
1087             longest_chain = right_length;
1088     }
1089
1090
1091     /* Pick your policy for "hashing isn't working" here:  */
1092     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1093         || HvREHASH(hv)) {
1094         return;
1095     }
1096
1097     if (hv == PL_strtab) {
1098         /* Urg. Someone is doing something nasty to the string table.
1099            Can't win.  */
1100         return;
1101     }
1102
1103     /* Awooga. Awooga. Pathological data.  */
1104     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1105       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1106
1107     ++newsize;
1108     Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1109     was_shared = HvSHAREKEYS(hv);
1110
1111     xhv->xhv_fill = 0;
1112     HvSHAREKEYS_off(hv);
1113     HvREHASH_on(hv);
1114
1115     aep = (HE **) xhv->xhv_array;
1116
1117     for (i=0; i<newsize; i++,aep++) {
1118         entry = *aep;
1119         while (entry) {
1120             /* We're going to trash this HE's next pointer when we chain it
1121                into the new hash below, so store where we go next.  */
1122             HE *next = HeNEXT(entry);
1123             UV hash;
1124
1125             /* Rehash it */
1126             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1127
1128             if (was_shared) {
1129                 /* Unshare it.  */
1130                 HEK *new_hek
1131                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1132                                      hash, HeKFLAGS(entry));
1133                 unshare_hek (HeKEY_hek(entry));
1134                 HeKEY_hek(entry) = new_hek;
1135             } else {
1136                 /* Not shared, so simply write the new hash in. */
1137                 HeHASH(entry) = hash;
1138             }
1139             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1140             HEK_REHASH_on(HeKEY_hek(entry));
1141             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1142
1143             /* Copy oentry to the correct new chain.  */
1144             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1145             if (!*bep)
1146                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1147             HeNEXT(entry) = *bep;
1148             *bep = entry;
1149
1150             entry = next;
1151         }
1152     }
1153     Safefree (xhv->xhv_array);
1154     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1155 }
1156
1157 void
1158 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1159 {
1160     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1161     I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1162     register I32 newsize;
1163     register I32 i;
1164     register I32 j;
1165     register char *a;
1166     register HE **aep;
1167     register HE *entry;
1168     register HE **oentry;
1169
1170     newsize = (I32) newmax;                     /* possible truncation here */
1171     if (newsize != newmax || newmax <= oldsize)
1172         return;
1173     while ((newsize & (1 + ~newsize)) != newsize) {
1174         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1175     }
1176     if (newsize < newmax)
1177         newsize *= 2;
1178     if (newsize < newmax)
1179         return;                                 /* overflow detection */
1180
1181     a = xhv->xhv_array; /* HvARRAY(hv) */
1182     if (a) {
1183         PL_nomemok = TRUE;
1184 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1185         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1186         if (!a) {
1187           PL_nomemok = FALSE;
1188           return;
1189         }
1190 #else
1191         New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1192         if (!a) {
1193           PL_nomemok = FALSE;
1194           return;
1195         }
1196         Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1197         if (oldsize >= 64) {
1198             offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1199                             PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1200         }
1201         else
1202             Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1203 #endif
1204         PL_nomemok = FALSE;
1205         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1206     }
1207     else {
1208         Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1209     }
1210     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1211     xhv->xhv_array = a;         /* HvARRAY(hv) = a */
1212     if (!xhv->xhv_fill /* !HvFILL(hv) */)       /* skip rest if no entries */
1213         return;
1214
1215     aep = (HE**)a;
1216     for (i=0; i<oldsize; i++,aep++) {
1217         if (!*aep)                              /* non-existent */
1218             continue;
1219         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1220             if ((j = (HeHASH(entry) & newsize)) != i) {
1221                 j -= i;
1222                 *oentry = HeNEXT(entry);
1223                 if (!(HeNEXT(entry) = aep[j]))
1224                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1225                 aep[j] = entry;
1226                 continue;
1227             }
1228             else
1229                 oentry = &HeNEXT(entry);
1230         }
1231         if (!*aep)                              /* everything moved */
1232             xhv->xhv_fill--; /* HvFILL(hv)-- */
1233     }
1234 }
1235
1236 /*
1237 =for apidoc newHV
1238
1239 Creates a new HV.  The reference count is set to 1.
1240
1241 =cut
1242 */
1243
1244 HV *
1245 Perl_newHV(pTHX)
1246 {
1247     register HV *hv;
1248     register XPVHV* xhv;
1249
1250     hv = (HV*)NEWSV(502,0);
1251     sv_upgrade((SV *)hv, SVt_PVHV);
1252     xhv = (XPVHV*)SvANY(hv);
1253     SvPOK_off(hv);
1254     SvNOK_off(hv);
1255 #ifndef NODEFAULT_SHAREKEYS
1256     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1257 #endif
1258
1259     xhv->xhv_max    = 7;        /* HvMAX(hv) = 7 (start with 8 buckets) */
1260     xhv->xhv_fill   = 0;        /* HvFILL(hv) = 0 */
1261     xhv->xhv_pmroot = 0;        /* HvPMROOT(hv) = 0 */
1262     (void)hv_iterinit(hv);      /* so each() will start off right */
1263     return hv;
1264 }
1265
1266 HV *
1267 Perl_newHVhv(pTHX_ HV *ohv)
1268 {
1269     HV *hv = newHV();
1270     STRLEN hv_max, hv_fill;
1271
1272     if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1273         return hv;
1274     hv_max = HvMAX(ohv);
1275
1276     if (!SvMAGICAL((SV *)ohv)) {
1277         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1278         STRLEN i;
1279         bool shared = !!HvSHAREKEYS(ohv);
1280         HE **ents, **oents = (HE **)HvARRAY(ohv);
1281         char *a;
1282         New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1283         ents = (HE**)a;
1284
1285         /* In each bucket... */
1286         for (i = 0; i <= hv_max; i++) {
1287             HE *prev = NULL, *ent = NULL, *oent = oents[i];
1288
1289             if (!oent) {
1290                 ents[i] = NULL;
1291                 continue;
1292             }
1293
1294             /* Copy the linked list of entries. */
1295             for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1296                 U32 hash   = HeHASH(oent);
1297                 char *key  = HeKEY(oent);
1298                 STRLEN len = HeKLEN(oent);
1299                 int flags  = HeKFLAGS(oent);
1300
1301                 ent = new_HE();
1302                 HeVAL(ent)     = newSVsv(HeVAL(oent));
1303                 HeKEY_hek(ent)
1304                     = shared ? share_hek_flags(key, len, hash, flags)
1305                              :  save_hek_flags(key, len, hash, flags);
1306                 if (prev)
1307                     HeNEXT(prev) = ent;
1308                 else
1309                     ents[i] = ent;
1310                 prev = ent;
1311                 HeNEXT(ent) = NULL;
1312             }
1313         }
1314
1315         HvMAX(hv)   = hv_max;
1316         HvFILL(hv)  = hv_fill;
1317         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1318         HvARRAY(hv) = ents;
1319     }
1320     else {
1321         /* Iterate over ohv, copying keys and values one at a time. */
1322         HE *entry;
1323         I32 riter = HvRITER(ohv);
1324         HE *eiter = HvEITER(ohv);
1325
1326         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1327         while (hv_max && hv_max + 1 >= hv_fill * 2)
1328             hv_max = hv_max / 2;
1329         HvMAX(hv) = hv_max;
1330
1331         hv_iterinit(ohv);
1332         while ((entry = hv_iternext_flags(ohv, 0))) {
1333             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1334                            newSVsv(HeVAL(entry)), HeHASH(entry),
1335                            HeKFLAGS(entry));
1336         }
1337         HvRITER(ohv) = riter;
1338         HvEITER(ohv) = eiter;
1339     }
1340
1341     return hv;
1342 }
1343
1344 void
1345 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1346 {
1347     SV *val;
1348
1349     if (!entry)
1350         return;
1351     val = HeVAL(entry);
1352     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1353         PL_sub_generation++;    /* may be deletion of method from stash */
1354     SvREFCNT_dec(val);
1355     if (HeKLEN(entry) == HEf_SVKEY) {
1356         SvREFCNT_dec(HeKEY_sv(entry));
1357         Safefree(HeKEY_hek(entry));
1358     }
1359     else if (HvSHAREKEYS(hv))
1360         unshare_hek(HeKEY_hek(entry));
1361     else
1362         Safefree(HeKEY_hek(entry));
1363     del_HE(entry);
1364 }
1365
1366 void
1367 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1368 {
1369     if (!entry)
1370         return;
1371     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1372         PL_sub_generation++;    /* may be deletion of method from stash */
1373     sv_2mortal(HeVAL(entry));   /* free between statements */
1374     if (HeKLEN(entry) == HEf_SVKEY) {
1375         sv_2mortal(HeKEY_sv(entry));
1376         Safefree(HeKEY_hek(entry));
1377     }
1378     else if (HvSHAREKEYS(hv))
1379         unshare_hek(HeKEY_hek(entry));
1380     else
1381         Safefree(HeKEY_hek(entry));
1382     del_HE(entry);
1383 }
1384
1385 /*
1386 =for apidoc hv_clear
1387
1388 Clears a hash, making it empty.
1389
1390 =cut
1391 */
1392
1393 void
1394 Perl_hv_clear(pTHX_ HV *hv)
1395 {
1396     register XPVHV* xhv;
1397     if (!hv)
1398         return;
1399
1400     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1401
1402     xhv = (XPVHV*)SvANY(hv);
1403
1404     if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
1405         /* restricted hash: convert all keys to placeholders */
1406         I32 i;
1407         HE* entry;
1408         for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1409             entry = ((HE**)xhv->xhv_array)[i];
1410             for (; entry; entry = HeNEXT(entry)) {
1411                 /* not already placeholder */
1412                 if (HeVAL(entry) != &PL_sv_placeholder) {
1413                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1414                         SV* keysv = hv_iterkeysv(entry);
1415                         Perl_croak(aTHX_
1416         "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1417                                    keysv);
1418                     }
1419                     SvREFCNT_dec(HeVAL(entry));
1420                     HeVAL(entry) = &PL_sv_placeholder;
1421                     xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1422                 }
1423             }
1424         }
1425         return;
1426     }
1427
1428     hfreeentries(hv);
1429     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1430     if (xhv->xhv_array /* HvARRAY(hv) */)
1431         (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1432                       (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1433
1434     if (SvRMAGICAL(hv))
1435         mg_clear((SV*)hv);
1436
1437     HvHASKFLAGS_off(hv);
1438     HvREHASH_off(hv);
1439 }
1440
1441 /*
1442 =for apidoc hv_clear_placeholders
1443
1444 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1445 marked as readonly and the key is subsequently deleted, the key is not actually
1446 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1447 it so it will be ignored by future operations such as iterating over the hash,
1448 but will still allow the hash to have a value reaasigned to the key at some
1449 future point.  This function clears any such placeholder keys from the hash.
1450 See Hash::Util::lock_keys() for an example of its use.
1451
1452 =cut
1453 */
1454
1455 void
1456 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1457 {
1458     I32 items;
1459     items = (I32)HvPLACEHOLDERS(hv);
1460     if (items) {
1461         HE *entry;
1462         I32 riter = HvRITER(hv);
1463         HE *eiter = HvEITER(hv);
1464         hv_iterinit(hv);
1465         /* This may look suboptimal with the items *after* the iternext, but
1466            it's quite deliberate. We only get here with items==0 if we've
1467            just deleted the last placeholder in the hash. If we've just done
1468            that then it means that the hash is in lazy delete mode, and the
1469            HE is now only referenced in our iterator. If we just quit the loop
1470            and discarded our iterator then the HE leaks. So we do the && the
1471            other way to ensure iternext is called just one more time, which
1472            has the side effect of triggering the lazy delete.  */
1473         while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1474             && items) {
1475             SV *val = hv_iterval(hv, entry);
1476
1477             if (val == &PL_sv_placeholder) {
1478
1479                 /* It seems that I have to go back in the front of the hash
1480                    API to delete a hash, even though I have a HE structure
1481                    pointing to the very entry I want to delete, and could hold
1482                    onto the previous HE that points to it. And it's easier to
1483                    go in with SVs as I can then specify the precomputed hash,
1484                    and don't have fun and games with utf8 keys.  */
1485                 SV *key = hv_iterkeysv(entry);
1486
1487                 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
1488                 items--;
1489             }
1490         }
1491         HvRITER(hv) = riter;
1492         HvEITER(hv) = eiter;
1493     }
1494 }
1495
1496 STATIC void
1497 S_hfreeentries(pTHX_ HV *hv)
1498 {
1499     register HE **array;
1500     register HE *entry;
1501     register HE *oentry = Null(HE*);
1502     I32 riter;
1503     I32 max;
1504
1505     if (!hv)
1506         return;
1507     if (!HvARRAY(hv))
1508         return;
1509
1510     riter = 0;
1511     max = HvMAX(hv);
1512     array = HvARRAY(hv);
1513     /* make everyone else think the array is empty, so that the destructors
1514      * called for freed entries can't recusively mess with us */
1515     HvARRAY(hv) = Null(HE**); 
1516     HvFILL(hv) = 0;
1517     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1518
1519     entry = array[0];
1520     for (;;) {
1521         if (entry) {
1522             oentry = entry;
1523             entry = HeNEXT(entry);
1524             hv_free_ent(hv, oentry);
1525         }
1526         if (!entry) {
1527             if (++riter > max)
1528                 break;
1529             entry = array[riter];
1530         }
1531     }
1532     HvARRAY(hv) = array;
1533     (void)hv_iterinit(hv);
1534 }
1535
1536 /*
1537 =for apidoc hv_undef
1538
1539 Undefines the hash.
1540
1541 =cut
1542 */
1543
1544 void
1545 Perl_hv_undef(pTHX_ HV *hv)
1546 {
1547     register XPVHV* xhv;
1548     if (!hv)
1549         return;
1550     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1551     xhv = (XPVHV*)SvANY(hv);
1552     hfreeentries(hv);
1553     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1554     if (HvNAME(hv)) {
1555         if(PL_stashcache)
1556             hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
1557         Safefree(HvNAME(hv));
1558         HvNAME(hv) = 0;
1559     }
1560     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1561     xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1562     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1563
1564     if (SvRMAGICAL(hv))
1565         mg_clear((SV*)hv);
1566 }
1567
1568 /*
1569 =for apidoc hv_iterinit
1570
1571 Prepares a starting point to traverse a hash table.  Returns the number of
1572 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1573 currently only meaningful for hashes without tie magic.
1574
1575 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1576 hash buckets that happen to be in use.  If you still need that esoteric
1577 value, you can get it through the macro C<HvFILL(tb)>.
1578
1579
1580 =cut
1581 */
1582
1583 I32
1584 Perl_hv_iterinit(pTHX_ HV *hv)
1585 {
1586     register XPVHV* xhv;
1587     HE *entry;
1588
1589     if (!hv)
1590         Perl_croak(aTHX_ "Bad hash");
1591     xhv = (XPVHV*)SvANY(hv);
1592     entry = xhv->xhv_eiter; /* HvEITER(hv) */
1593     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1594         HvLAZYDEL_off(hv);
1595         hv_free_ent(hv, entry);
1596     }
1597     xhv->xhv_riter = -1;        /* HvRITER(hv) = -1 */
1598     xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1599     /* used to be xhv->xhv_fill before 5.004_65 */
1600     return XHvTOTALKEYS(xhv);
1601 }
1602 /*
1603 =for apidoc hv_iternext
1604
1605 Returns entries from a hash iterator.  See C<hv_iterinit>.
1606
1607 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1608 iterator currently points to, without losing your place or invalidating your
1609 iterator.  Note that in this case the current entry is deleted from the hash
1610 with your iterator holding the last reference to it.  Your iterator is flagged
1611 to free the entry on the next call to C<hv_iternext>, so you must not discard
1612 your iterator immediately else the entry will leak - call C<hv_iternext> to
1613 trigger the resource deallocation.
1614
1615 =cut
1616 */
1617
1618 HE *
1619 Perl_hv_iternext(pTHX_ HV *hv)
1620 {
1621     return hv_iternext_flags(hv, 0);
1622 }
1623
1624 /*
1625 =for apidoc hv_iternext_flags
1626
1627 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1628 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1629 set the placeholders keys (for restricted hashes) will be returned in addition
1630 to normal keys. By default placeholders are automatically skipped over.
1631 Currently a placeholder is implemented with a value that is
1632 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1633 restricted hashes may change, and the implementation currently is
1634 insufficiently abstracted for any change to be tidy.
1635
1636 =cut
1637 */
1638
1639 HE *
1640 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1641 {
1642     register XPVHV* xhv;
1643     register HE *entry;
1644     HE *oldentry;
1645     MAGIC* mg;
1646
1647     if (!hv)
1648         Perl_croak(aTHX_ "Bad hash");
1649     xhv = (XPVHV*)SvANY(hv);
1650     oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1651
1652     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1653         SV *key = sv_newmortal();
1654         if (entry) {
1655             sv_setsv(key, HeSVKEY_force(entry));
1656             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1657         }
1658         else {
1659             char *k;
1660             HEK *hek;
1661
1662             /* one HE per MAGICAL hash */
1663             xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1664             Zero(entry, 1, HE);
1665             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1666             hek = (HEK*)k;
1667             HeKEY_hek(entry) = hek;
1668             HeKLEN(entry) = HEf_SVKEY;
1669         }
1670         magic_nextpack((SV*) hv,mg,key);
1671         if (SvOK(key)) {
1672             /* force key to stay around until next time */
1673             HeSVKEY_set(entry, SvREFCNT_inc(key));
1674             return entry;               /* beware, hent_val is not set */
1675         }
1676         if (HeVAL(entry))
1677             SvREFCNT_dec(HeVAL(entry));
1678         Safefree(HeKEY_hek(entry));
1679         del_HE(entry);
1680         xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1681         return Null(HE*);
1682     }
1683 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1684     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
1685         prime_env_iter();
1686 #endif
1687
1688     if (!xhv->xhv_array /* !HvARRAY(hv) */)
1689         Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1690              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1691              char);
1692     /* At start of hash, entry is NULL.  */
1693     if (entry)
1694     {
1695         entry = HeNEXT(entry);
1696         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1697             /*
1698              * Skip past any placeholders -- don't want to include them in
1699              * any iteration.
1700              */
1701             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1702                 entry = HeNEXT(entry);
1703             }
1704         }
1705     }
1706     while (!entry) {
1707         /* OK. Come to the end of the current list.  Grab the next one.  */
1708
1709         xhv->xhv_riter++; /* HvRITER(hv)++ */
1710         if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1711             /* There is no next one.  End of the hash.  */
1712             xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1713             break;
1714         }
1715         /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1716         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1717
1718         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1719             /* If we have an entry, but it's a placeholder, don't count it.
1720                Try the next.  */
1721             while (entry && HeVAL(entry) == &PL_sv_placeholder)
1722                 entry = HeNEXT(entry);
1723         }
1724         /* Will loop again if this linked list starts NULL
1725            (for HV_ITERNEXT_WANTPLACEHOLDERS)
1726            or if we run through it and find only placeholders.  */
1727     }
1728
1729     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1730         HvLAZYDEL_off(hv);
1731         hv_free_ent(hv, oldentry);
1732     }
1733
1734     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1735       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1736
1737     xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1738     return entry;
1739 }
1740
1741 /*
1742 =for apidoc hv_iterkey
1743
1744 Returns the key from the current position of the hash iterator.  See
1745 C<hv_iterinit>.
1746
1747 =cut
1748 */
1749
1750 char *
1751 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1752 {
1753     if (HeKLEN(entry) == HEf_SVKEY) {
1754         STRLEN len;
1755         char *p = SvPV(HeKEY_sv(entry), len);
1756         *retlen = len;
1757         return p;
1758     }
1759     else {
1760         *retlen = HeKLEN(entry);
1761         return HeKEY(entry);
1762     }
1763 }
1764
1765 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1766 /*
1767 =for apidoc hv_iterkeysv
1768
1769 Returns the key as an C<SV*> from the current position of the hash
1770 iterator.  The return value will always be a mortal copy of the key.  Also
1771 see C<hv_iterinit>.
1772
1773 =cut
1774 */
1775
1776 SV *
1777 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1778 {
1779     if (HeKLEN(entry) != HEf_SVKEY) {
1780         HEK *hek = HeKEY_hek(entry);
1781         int flags = HEK_FLAGS(hek);
1782         SV *sv;
1783
1784         if (flags & HVhek_WASUTF8) {
1785             /* Trouble :-)
1786                Andreas would like keys he put in as utf8 to come back as utf8
1787             */
1788             STRLEN utf8_len = HEK_LEN(hek);
1789             U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
1790
1791             sv = newSVpvn ((char*)as_utf8, utf8_len);
1792             SvUTF8_on (sv);
1793             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
1794         } else if (flags & HVhek_REHASH) {
1795             /* We don't have a pointer to the hv, so we have to replicate the
1796                flag into every HEK. This hv is using custom a hasing
1797                algorithm. Hence we can't return a shared string scalar, as
1798                that would contain the (wrong) hash value, and might get passed
1799                into an hv routine with a regular hash  */
1800
1801             sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
1802             if (HEK_UTF8(hek))
1803                 SvUTF8_on (sv);
1804         } else {
1805             sv = newSVpvn_share(HEK_KEY(hek),
1806                                 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1807                                 HEK_HASH(hek));
1808         }
1809         return sv_2mortal(sv);
1810     }
1811     return sv_mortalcopy(HeKEY_sv(entry));
1812 }
1813
1814 /*
1815 =for apidoc hv_iterval
1816
1817 Returns the value from the current position of the hash iterator.  See
1818 C<hv_iterkey>.
1819
1820 =cut
1821 */
1822
1823 SV *
1824 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1825 {
1826     if (SvRMAGICAL(hv)) {
1827         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1828             SV* sv = sv_newmortal();
1829             if (HeKLEN(entry) == HEf_SVKEY)
1830                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1831             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1832             return sv;
1833         }
1834     }
1835     return HeVAL(entry);
1836 }
1837
1838 /*
1839 =for apidoc hv_iternextsv
1840
1841 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1842 operation.
1843
1844 =cut
1845 */
1846
1847 SV *
1848 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1849 {
1850     HE *he;
1851     if ( (he = hv_iternext_flags(hv, 0)) == NULL)
1852         return NULL;
1853     *key = hv_iterkey(he, retlen);
1854     return hv_iterval(hv, he);
1855 }
1856
1857 /*
1858 =for apidoc hv_magic
1859
1860 Adds magic to a hash.  See C<sv_magic>.
1861
1862 =cut
1863 */
1864
1865 void
1866 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1867 {
1868     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1869 }
1870
1871 #if 0 /* use the macro from hv.h instead */
1872
1873 char*   
1874 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1875 {
1876     return HEK_KEY(share_hek(sv, len, hash));
1877 }
1878
1879 #endif
1880
1881 /* possibly free a shared string if no one has access to it
1882  * len and hash must both be valid for str.
1883  */
1884 void
1885 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1886 {
1887     unshare_hek_or_pvn (NULL, str, len, hash);
1888 }
1889
1890
1891 void
1892 Perl_unshare_hek(pTHX_ HEK *hek)
1893 {
1894     unshare_hek_or_pvn(hek, NULL, 0, 0);
1895 }
1896
1897 /* possibly free a shared string if no one has access to it
1898    hek if non-NULL takes priority over the other 3, else str, len and hash
1899    are used.  If so, len and hash must both be valid for str.
1900  */
1901 STATIC void
1902 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
1903 {
1904     register XPVHV* xhv;
1905     register HE *entry;
1906     register HE **oentry;
1907     register I32 i = 1;
1908     I32 found = 0;
1909     bool is_utf8 = FALSE;
1910     int k_flags = 0;
1911     const char *save = str;
1912
1913     if (hek) {
1914         hash = HEK_HASH(hek);
1915     } else if (len < 0) {
1916         STRLEN tmplen = -len;
1917         is_utf8 = TRUE;
1918         /* See the note in hv_fetch(). --jhi */
1919         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1920         len = tmplen;
1921         if (is_utf8)
1922             k_flags = HVhek_UTF8;
1923         if (str != save)
1924             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1925     }
1926
1927     /* what follows is the moral equivalent of:
1928     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1929         if (--*Svp == Nullsv)
1930             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1931     } */
1932     xhv = (XPVHV*)SvANY(PL_strtab);
1933     /* assert(xhv_array != 0) */
1934     LOCK_STRTAB_MUTEX;
1935     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1936     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1937     if (hek) {
1938         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1939             if (HeKEY_hek(entry) != hek)
1940                 continue;
1941             found = 1;
1942             break;
1943         }
1944     } else {
1945         int flags_masked = k_flags & HVhek_MASK;
1946         for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1947             if (HeHASH(entry) != hash)          /* strings can't be equal */
1948                 continue;
1949             if (HeKLEN(entry) != len)
1950                 continue;
1951             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
1952                 continue;
1953             if (HeKFLAGS(entry) != flags_masked)
1954                 continue;
1955             found = 1;
1956             break;
1957         }
1958     }
1959
1960     if (found) {
1961         if (--HeVAL(entry) == Nullsv) {
1962             *oentry = HeNEXT(entry);
1963             if (i && !*oentry)
1964                 xhv->xhv_fill--; /* HvFILL(hv)-- */
1965             Safefree(HeKEY_hek(entry));
1966             del_HE(entry);
1967             xhv->xhv_keys--; /* HvKEYS(hv)-- */
1968         }
1969     }
1970
1971     UNLOCK_STRTAB_MUTEX;
1972     if (!found && ckWARN_d(WARN_INTERNAL))
1973         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1974                     "Attempt to free non-existent shared string '%s'%s",
1975                     hek ? HEK_KEY(hek) : str,
1976                     (k_flags & HVhek_UTF8) ? " (utf8)" : "");
1977     if (k_flags & HVhek_FREEKEY)
1978         Safefree(str);
1979 }
1980
1981 /* get a (constant) string ptr from the global string table
1982  * string will get added if it is not already there.
1983  * len and hash must both be valid for str.
1984  */
1985 HEK *
1986 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1987 {
1988     bool is_utf8 = FALSE;
1989     int flags = 0;
1990     const char *save = str;
1991
1992     if (len < 0) {
1993       STRLEN tmplen = -len;
1994       is_utf8 = TRUE;
1995       /* See the note in hv_fetch(). --jhi */
1996       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1997       len = tmplen;
1998       /* If we were able to downgrade here, then than means that we were passed
1999          in a key which only had chars 0-255, but was utf8 encoded.  */
2000       if (is_utf8)
2001           flags = HVhek_UTF8;
2002       /* If we found we were able to downgrade the string to bytes, then
2003          we should flag that it needs upgrading on keys or each.  Also flag
2004          that we need share_hek_flags to free the string.  */
2005       if (str != save)
2006           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2007     }
2008
2009     return share_hek_flags (str, len, hash, flags);
2010 }
2011
2012 STATIC HEK *
2013 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2014 {
2015     register XPVHV* xhv;
2016     register HE *entry;
2017     register HE **oentry;
2018     register I32 i = 1;
2019     I32 found = 0;
2020     int flags_masked = flags & HVhek_MASK;
2021
2022     /* what follows is the moral equivalent of:
2023
2024     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2025         hv_store(PL_strtab, str, len, Nullsv, hash);
2026
2027         Can't rehash the shared string table, so not sure if it's worth
2028         counting the number of entries in the linked list
2029     */
2030     xhv = (XPVHV*)SvANY(PL_strtab);
2031     /* assert(xhv_array != 0) */
2032     LOCK_STRTAB_MUTEX;
2033     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2034     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2035     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
2036         if (HeHASH(entry) != hash)              /* strings can't be equal */
2037             continue;
2038         if (HeKLEN(entry) != len)
2039             continue;
2040         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2041             continue;
2042         if (HeKFLAGS(entry) != flags_masked)
2043             continue;
2044         found = 1;
2045         break;
2046     }
2047     if (!found) {
2048         entry = new_HE();
2049         HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
2050         HeVAL(entry) = Nullsv;
2051         HeNEXT(entry) = *oentry;
2052         *oentry = entry;
2053         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2054         if (i) {                                /* initial entry? */
2055             xhv->xhv_fill++; /* HvFILL(hv)++ */
2056         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2057                 hsplit(PL_strtab);
2058         }
2059     }
2060
2061     ++HeVAL(entry);                             /* use value slot as REFCNT */
2062     UNLOCK_STRTAB_MUTEX;
2063
2064     if (flags & HVhek_FREEKEY)
2065         Safefree(str);
2066
2067     return HeKEY_hek(entry);
2068 }
2069
2070
2071 /*
2072 =for apidoc hv_assert
2073
2074 Check that a hash is in an internally consistent state.
2075
2076 =cut
2077 */
2078
2079 void
2080 Perl_hv_assert(pTHX_ HV *hv)
2081 {
2082   HE* entry;
2083   int withflags = 0;
2084   int placeholders = 0;
2085   int real = 0;
2086   int bad = 0;
2087   I32 riter = HvRITER(hv);
2088   HE *eiter = HvEITER(hv);
2089
2090   (void)hv_iterinit(hv);
2091
2092   while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2093     /* sanity check the values */
2094     if (HeVAL(entry) == &PL_sv_placeholder) {
2095       placeholders++;
2096     } else {
2097       real++;
2098     }
2099     /* sanity check the keys */
2100     if (HeSVKEY(entry)) {
2101       /* Don't know what to check on SV keys.  */
2102     } else if (HeKUTF8(entry)) {
2103       withflags++;
2104        if (HeKWASUTF8(entry)) {
2105          PerlIO_printf(Perl_debug_log,
2106                        "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2107                        (int) HeKLEN(entry),  HeKEY(entry));
2108          bad = 1;
2109        }
2110     } else if (HeKWASUTF8(entry)) {
2111       withflags++;
2112     }
2113   }
2114   if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2115     if (HvUSEDKEYS(hv) != real) {
2116       PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2117                     (int) real, (int) HvUSEDKEYS(hv));
2118       bad = 1;
2119     }
2120     if (HvPLACEHOLDERS(hv) != placeholders) {
2121       PerlIO_printf(Perl_debug_log,
2122                     "Count %d placeholder(s), but hash reports %d\n",
2123                     (int) placeholders, (int) HvPLACEHOLDERS(hv));
2124       bad = 1;
2125     }
2126   }
2127   if (withflags && ! HvHASKFLAGS(hv)) {
2128     PerlIO_printf(Perl_debug_log,
2129                   "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2130                   withflags);
2131     bad = 1;
2132   }
2133   if (bad) {
2134     sv_dump((SV *)hv);
2135   }
2136   HvRITER(hv) = riter;          /* Restore hash iterator state */
2137   HvEITER(hv) = eiter;
2138 }