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