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