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