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