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