Remove &munge_c_files from embed.pl, as it has never been used.
[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<hv> 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     Safefree(HvARRAY(hv));
1109 #endif
1110
1111     PL_nomemok = FALSE;
1112     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1113     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1114     HvARRAY(hv) = (HE**) a;
1115     aep = (HE**)a;
1116
1117     for (i=0; i<oldsize; i++,aep++) {
1118         int left_length = 0;
1119         int right_length = 0;
1120         HE **oentry = aep;
1121         HE *entry = *aep;
1122         register HE **bep;
1123
1124         if (!entry)                             /* non-existent */
1125             continue;
1126         bep = aep+oldsize;
1127         do {
1128             if ((HeHASH(entry) & newsize) != (U32)i) {
1129                 *oentry = HeNEXT(entry);
1130                 HeNEXT(entry) = *bep;
1131                 *bep = entry;
1132                 right_length++;
1133             }
1134             else {
1135                 oentry = &HeNEXT(entry);
1136                 left_length++;
1137             }
1138             entry = *oentry;
1139         } while (entry);
1140         /* I think we don't actually need to keep track of the longest length,
1141            merely flag if anything is too long. But for the moment while
1142            developing this code I'll track it.  */
1143         if (left_length > longest_chain)
1144             longest_chain = left_length;
1145         if (right_length > longest_chain)
1146             longest_chain = right_length;
1147     }
1148
1149
1150     /* Pick your policy for "hashing isn't working" here:  */
1151     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1152         || HvREHASH(hv)) {
1153         return;
1154     }
1155
1156     if (hv == PL_strtab) {
1157         /* Urg. Someone is doing something nasty to the string table.
1158            Can't win.  */
1159         return;
1160     }
1161
1162     /* Awooga. Awooga. Pathological data.  */
1163     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
1164       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1165
1166     ++newsize;
1167     Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1168          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1169     if (SvOOK(hv)) {
1170         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1171     }
1172
1173     was_shared = HvSHAREKEYS(hv);
1174
1175     HvSHAREKEYS_off(hv);
1176     HvREHASH_on(hv);
1177
1178     aep = HvARRAY(hv);
1179
1180     for (i=0; i<newsize; i++,aep++) {
1181         register HE *entry = *aep;
1182         while (entry) {
1183             /* We're going to trash this HE's next pointer when we chain it
1184                into the new hash below, so store where we go next.  */
1185             HE * const next = HeNEXT(entry);
1186             UV hash;
1187             HE **bep;
1188
1189             /* Rehash it */
1190             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1191
1192             if (was_shared) {
1193                 /* Unshare it.  */
1194                 HEK * const new_hek
1195                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1196                                      hash, HeKFLAGS(entry));
1197                 unshare_hek (HeKEY_hek(entry));
1198                 HeKEY_hek(entry) = new_hek;
1199             } else {
1200                 /* Not shared, so simply write the new hash in. */
1201                 HeHASH(entry) = hash;
1202             }
1203             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1204             HEK_REHASH_on(HeKEY_hek(entry));
1205             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1206
1207             /* Copy oentry to the correct new chain.  */
1208             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1209             HeNEXT(entry) = *bep;
1210             *bep = entry;
1211
1212             entry = next;
1213         }
1214     }
1215     Safefree (HvARRAY(hv));
1216     HvARRAY(hv) = (HE **)a;
1217 }
1218
1219 void
1220 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1221 {
1222     dVAR;
1223     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1224     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1225     register I32 newsize;
1226     register I32 i;
1227     register char *a;
1228     register HE **aep;
1229
1230     PERL_ARGS_ASSERT_HV_KSPLIT;
1231
1232     newsize = (I32) newmax;                     /* possible truncation here */
1233     if (newsize != newmax || newmax <= oldsize)
1234         return;
1235     while ((newsize & (1 + ~newsize)) != newsize) {
1236         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1237     }
1238     if (newsize < newmax)
1239         newsize *= 2;
1240     if (newsize < newmax)
1241         return;                                 /* overflow detection */
1242
1243     a = (char *) HvARRAY(hv);
1244     if (a) {
1245         PL_nomemok = TRUE;
1246 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1247         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1248               + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1249         if (!a) {
1250           PL_nomemok = FALSE;
1251           return;
1252         }
1253         if (SvOOK(hv)) {
1254             Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1255         }
1256 #else
1257         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1258             + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1259         if (!a) {
1260           PL_nomemok = FALSE;
1261           return;
1262         }
1263         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1264         if (SvOOK(hv)) {
1265             Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1266         }
1267         Safefree(HvARRAY(hv));
1268 #endif
1269         PL_nomemok = FALSE;
1270         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1271     }
1272     else {
1273         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1274     }
1275     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1276     HvARRAY(hv) = (HE **) a;
1277     if (!xhv->xhv_keys /* !HvTOTALKEYS(hv) */)  /* skip rest if no entries */
1278         return;
1279
1280     aep = (HE**)a;
1281     for (i=0; i<oldsize; i++,aep++) {
1282         HE **oentry = aep;
1283         HE *entry = *aep;
1284
1285         if (!entry)                             /* non-existent */
1286             continue;
1287         do {
1288             register I32 j = (HeHASH(entry) & newsize);
1289
1290             if (j != i) {
1291                 j -= i;
1292                 *oentry = HeNEXT(entry);
1293                 HeNEXT(entry) = aep[j];
1294                 aep[j] = entry;
1295             }
1296             else
1297                 oentry = &HeNEXT(entry);
1298             entry = *oentry;
1299         } while (entry);
1300     }
1301 }
1302
1303 HV *
1304 Perl_newHVhv(pTHX_ HV *ohv)
1305 {
1306     dVAR;
1307     HV * const hv = newHV();
1308     STRLEN hv_max;
1309
1310     if (!ohv || !HvTOTALKEYS(ohv))
1311         return hv;
1312     hv_max = HvMAX(ohv);
1313
1314     if (!SvMAGICAL((const SV *)ohv)) {
1315         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1316         STRLEN i;
1317         const bool shared = !!HvSHAREKEYS(ohv);
1318         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1319         char *a;
1320         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1321         ents = (HE**)a;
1322
1323         /* In each bucket... */
1324         for (i = 0; i <= hv_max; i++) {
1325             HE *prev = NULL;
1326             HE *oent = oents[i];
1327
1328             if (!oent) {
1329                 ents[i] = NULL;
1330                 continue;
1331             }
1332
1333             /* Copy the linked list of entries. */
1334             for (; oent; oent = HeNEXT(oent)) {
1335                 const U32 hash   = HeHASH(oent);
1336                 const char * const key = HeKEY(oent);
1337                 const STRLEN len = HeKLEN(oent);
1338                 const int flags  = HeKFLAGS(oent);
1339                 HE * const ent   = new_HE();
1340                 SV *const val    = HeVAL(oent);
1341
1342                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1343                 HeKEY_hek(ent)
1344                     = shared ? share_hek_flags(key, len, hash, flags)
1345                              :  save_hek_flags(key, len, hash, flags);
1346                 if (prev)
1347                     HeNEXT(prev) = ent;
1348                 else
1349                     ents[i] = ent;
1350                 prev = ent;
1351                 HeNEXT(ent) = NULL;
1352             }
1353         }
1354
1355         HvMAX(hv)   = hv_max;
1356         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1357         HvARRAY(hv) = ents;
1358     } /* not magical */
1359     else {
1360         /* Iterate over ohv, copying keys and values one at a time. */
1361         HE *entry;
1362         const I32 riter = HvRITER_get(ohv);
1363         HE * const eiter = HvEITER_get(ohv);
1364         STRLEN hv_fill = HvFILL(ohv);
1365
1366         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1367         while (hv_max && hv_max + 1 >= hv_fill * 2)
1368             hv_max = hv_max / 2;
1369         HvMAX(hv) = hv_max;
1370
1371         hv_iterinit(ohv);
1372         while ((entry = hv_iternext_flags(ohv, 0))) {
1373             SV *const val = HeVAL(entry);
1374             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1375                                  SvIMMORTAL(val) ? val : newSVsv(val),
1376                                  HeHASH(entry), HeKFLAGS(entry));
1377         }
1378         HvRITER_set(ohv, riter);
1379         HvEITER_set(ohv, eiter);
1380     }
1381
1382     return hv;
1383 }
1384
1385 /*
1386 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1387
1388 A specialised version of L</newHVhv> for copying C<%^H>.  I<ohv> must be
1389 a pointer to a hash (which may have C<%^H> magic, but should be generally
1390 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1391 of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1392 added to it.  A pointer to the new hash is returned.
1393
1394 =cut
1395 */
1396
1397 HV *
1398 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1399 {
1400     HV * const hv = newHV();
1401
1402     if (ohv && HvTOTALKEYS(ohv)) {
1403         STRLEN hv_max = HvMAX(ohv);
1404         STRLEN hv_fill = HvFILL(ohv);
1405         HE *entry;
1406         const I32 riter = HvRITER_get(ohv);
1407         HE * const eiter = HvEITER_get(ohv);
1408
1409         while (hv_max && hv_max + 1 >= hv_fill * 2)
1410             hv_max = hv_max / 2;
1411         HvMAX(hv) = hv_max;
1412
1413         hv_iterinit(ohv);
1414         while ((entry = hv_iternext_flags(ohv, 0))) {
1415             SV *const sv = newSVsv(HeVAL(entry));
1416             SV *heksv = newSVhek(HeKEY_hek(entry));
1417             sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1418                      (char *)heksv, HEf_SVKEY);
1419             SvREFCNT_dec(heksv);
1420             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1421                                  sv, HeHASH(entry), HeKFLAGS(entry));
1422         }
1423         HvRITER_set(ohv, riter);
1424         HvEITER_set(ohv, eiter);
1425     }
1426     hv_magic(hv, NULL, PERL_MAGIC_hints);
1427     return hv;
1428 }
1429
1430 void
1431 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1432 {
1433     dVAR;
1434     SV *val;
1435
1436     PERL_ARGS_ASSERT_HV_FREE_ENT;
1437
1438     if (!entry)
1439         return;
1440     val = HeVAL(entry);
1441     if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv))
1442         mro_method_changed_in(hv);      /* deletion of method from stash */
1443     SvREFCNT_dec(val);
1444     if (HeKLEN(entry) == HEf_SVKEY) {
1445         SvREFCNT_dec(HeKEY_sv(entry));
1446         Safefree(HeKEY_hek(entry));
1447     }
1448     else if (HvSHAREKEYS(hv))
1449         unshare_hek(HeKEY_hek(entry));
1450     else
1451         Safefree(HeKEY_hek(entry));
1452     del_HE(entry);
1453 }
1454
1455
1456 void
1457 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1458 {
1459     dVAR;
1460
1461     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1462
1463     if (!entry)
1464         return;
1465     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1466     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1467     if (HeKLEN(entry) == HEf_SVKEY) {
1468         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1469     }
1470     hv_free_ent(hv, entry);
1471 }
1472
1473 /*
1474 =for apidoc hv_clear
1475
1476 Clears a hash, making it empty.
1477
1478 =cut
1479 */
1480
1481 void
1482 Perl_hv_clear(pTHX_ HV *hv)
1483 {
1484     dVAR;
1485     register XPVHV* xhv;
1486     if (!hv)
1487         return;
1488
1489     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1490
1491     xhv = (XPVHV*)SvANY(hv);
1492
1493     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1494         /* restricted hash: convert all keys to placeholders */
1495         STRLEN i;
1496         for (i = 0; i <= xhv->xhv_max; i++) {
1497             HE *entry = (HvARRAY(hv))[i];
1498             for (; entry; entry = HeNEXT(entry)) {
1499                 /* not already placeholder */
1500                 if (HeVAL(entry) != &PL_sv_placeholder) {
1501                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1502                         SV* const keysv = hv_iterkeysv(entry);
1503                         Perl_croak(aTHX_
1504                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1505                                    (void*)keysv);
1506                     }
1507                     SvREFCNT_dec(HeVAL(entry));
1508                     HeVAL(entry) = &PL_sv_placeholder;
1509                     HvPLACEHOLDERS(hv)++;
1510                 }
1511             }
1512         }
1513         goto reset;
1514     }
1515
1516     hfreeentries(hv);
1517     HvPLACEHOLDERS_set(hv, 0);
1518     if (HvARRAY(hv))
1519         Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1520
1521     if (SvRMAGICAL(hv))
1522         mg_clear(MUTABLE_SV(hv));
1523
1524     HvHASKFLAGS_off(hv);
1525     HvREHASH_off(hv);
1526     reset:
1527     if (SvOOK(hv)) {
1528         if(HvNAME_get(hv))
1529             mro_isa_changed_in(hv);
1530         HvEITER_set(hv, NULL);
1531     }
1532 }
1533
1534 /*
1535 =for apidoc hv_clear_placeholders
1536
1537 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1538 marked as readonly and the key is subsequently deleted, the key is not actually
1539 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1540 it so it will be ignored by future operations such as iterating over the hash,
1541 but will still allow the hash to have a value reassigned to the key at some
1542 future point.  This function clears any such placeholder keys from the hash.
1543 See Hash::Util::lock_keys() for an example of its use.
1544
1545 =cut
1546 */
1547
1548 void
1549 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1550 {
1551     dVAR;
1552     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1553
1554     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1555
1556     if (items)
1557         clear_placeholders(hv, items);
1558 }
1559
1560 static void
1561 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1562 {
1563     dVAR;
1564     I32 i;
1565
1566     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1567
1568     if (items == 0)
1569         return;
1570
1571     i = HvMAX(hv);
1572     do {
1573         /* Loop down the linked list heads  */
1574         bool first = TRUE;
1575         HE **oentry = &(HvARRAY(hv))[i];
1576         HE *entry;
1577
1578         while ((entry = *oentry)) {
1579             if (HeVAL(entry) == &PL_sv_placeholder) {
1580                 *oentry = HeNEXT(entry);
1581                 if (entry == HvEITER_get(hv))
1582                     HvLAZYDEL_on(hv);
1583                 else
1584                     hv_free_ent(hv, entry);
1585
1586                 if (--items == 0) {
1587                     /* Finished.  */
1588                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1589                     if (HvKEYS(hv) == 0)
1590                         HvHASKFLAGS_off(hv);
1591                     HvPLACEHOLDERS_set(hv, 0);
1592                     return;
1593                 }
1594             } else {
1595                 oentry = &HeNEXT(entry);
1596                 first = FALSE;
1597             }
1598         }
1599     } while (--i >= 0);
1600     /* You can't get here, hence assertion should always fail.  */
1601     assert (items == 0);
1602     assert (0);
1603 }
1604
1605 STATIC void
1606 S_hfreeentries(pTHX_ HV *hv)
1607 {
1608     /* This is the array that we're going to restore  */
1609     HE **const orig_array = HvARRAY(hv);
1610     HEK *name;
1611     int attempts = 100;
1612
1613     PERL_ARGS_ASSERT_HFREEENTRIES;
1614
1615     if (!orig_array)
1616         return;
1617
1618     if (SvOOK(hv)) {
1619         /* If the hash is actually a symbol table with a name, look after the
1620            name.  */
1621         struct xpvhv_aux *iter = HvAUX(hv);
1622
1623         name = iter->xhv_name;
1624         iter->xhv_name = NULL;
1625     } else {
1626         name = NULL;
1627     }
1628
1629     /* orig_array remains unchanged throughout the loop. If after freeing all
1630        the entries it turns out that one of the little blighters has triggered
1631        an action that has caused HvARRAY to be re-allocated, then we set
1632        array to the new HvARRAY, and try again.  */
1633
1634     while (1) {
1635         /* This is the one we're going to try to empty.  First time round
1636            it's the original array.  (Hopefully there will only be 1 time
1637            round) */
1638         HE ** const array = HvARRAY(hv);
1639         I32 i = HvMAX(hv);
1640
1641         /* Because we have taken xhv_name out, the only allocated pointer
1642            in the aux structure that might exist is the backreference array.
1643         */
1644
1645         if (SvOOK(hv)) {
1646             HE *entry;
1647             struct mro_meta *meta;
1648             struct xpvhv_aux *iter = HvAUX(hv);
1649             /* weak references: if called from sv_clear(), the backrefs
1650              * should already have been killed; if there are any left, its
1651              * because we're doing hv_clear() or hv_undef(), and the HV
1652              * will continue to live.
1653              * Because while freeing the entries we fake up a NULL HvARRAY
1654              * (and hence HvAUX), we need to store the backref array
1655              * somewhere else; but it still needs to be visible in case
1656              * any the things we free happen to call sv_del_backref().
1657              * We do this by storing it in magic instead.
1658              * If, during the entry freeing, a destructor happens to add
1659              * a new weak backref, then sv_add_backref will look in both
1660              * places (magic in HvAUX) for the AV, but will create a new
1661              * AV in HvAUX if it can't find one (if it finds it in magic,
1662              * it moves it back into HvAUX. So at the end of the iteration
1663              * we have to allow for this. */
1664
1665
1666             if (iter->xhv_backreferences) {
1667                 if (SvTYPE(iter->xhv_backreferences) == SVt_PVAV) {
1668                     /* The sv_magic will increase the reference count of the AV,
1669                        so we need to drop it first. */
1670                     SvREFCNT_dec(iter->xhv_backreferences);
1671                     if (AvFILLp(iter->xhv_backreferences) == -1) {
1672                         /* Turns out that the array is empty. Just free it.  */
1673                         SvREFCNT_dec(iter->xhv_backreferences);
1674
1675                     } else {
1676                         sv_magic(MUTABLE_SV(hv),
1677                                  MUTABLE_SV(iter->xhv_backreferences),
1678                                  PERL_MAGIC_backref, NULL, 0);
1679                     }
1680                 }
1681                 else {
1682                     MAGIC *mg;
1683                     sv_magic(MUTABLE_SV(hv), NULL, PERL_MAGIC_backref, NULL, 0);
1684                     mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_backref);
1685                     mg->mg_obj = (SV*)iter->xhv_backreferences;
1686                 }
1687                 iter->xhv_backreferences = NULL;
1688             }
1689
1690             entry = iter->xhv_eiter; /* HvEITER(hv) */
1691             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1692                 HvLAZYDEL_off(hv);
1693                 hv_free_ent(hv, entry);
1694             }
1695             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1696             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1697
1698             if((meta = iter->xhv_mro_meta)) {
1699                 if (meta->mro_linear_all) {
1700                     SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
1701                     meta->mro_linear_all = NULL;
1702                     /* This is just acting as a shortcut pointer.  */
1703                     meta->mro_linear_current = NULL;
1704                 } else if (meta->mro_linear_current) {
1705                     /* Only the current MRO is stored, so this owns the data.
1706                      */
1707                     SvREFCNT_dec(meta->mro_linear_current);
1708                     meta->mro_linear_current = NULL;
1709                 }
1710                 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1711                 SvREFCNT_dec(meta->isa);
1712                 Safefree(meta);
1713                 iter->xhv_mro_meta = NULL;
1714             }
1715
1716             /* There are now no allocated pointers in the aux structure.  */
1717
1718             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
1719             /* What aux structure?  */
1720         }
1721
1722         /* make everyone else think the array is empty, so that the destructors
1723          * called for freed entries can't recursively mess with us */
1724         HvARRAY(hv) = NULL;
1725         ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1726
1727
1728         do {
1729             /* Loop down the linked list heads  */
1730             HE *entry = array[i];
1731
1732             while (entry) {
1733                 register HE * const oentry = entry;
1734                 entry = HeNEXT(entry);
1735                 hv_free_ent(hv, oentry);
1736             }
1737         } while (--i >= 0);
1738
1739         /* As there are no allocated pointers in the aux structure, it's now
1740            safe to free the array we just cleaned up, if it's not the one we're
1741            going to put back.  */
1742         if (array != orig_array) {
1743             Safefree(array);
1744         }
1745
1746         if (!HvARRAY(hv)) {
1747             /* Good. No-one added anything this time round.  */
1748             break;
1749         }
1750
1751         if (SvOOK(hv)) {
1752             /* Someone attempted to iterate or set the hash name while we had
1753                the array set to 0.  We'll catch backferences on the next time
1754                round the while loop.  */
1755             assert(HvARRAY(hv));
1756
1757             if (HvAUX(hv)->xhv_name) {
1758                 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1759             }
1760         }
1761
1762         if (--attempts == 0) {
1763             Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1764         }
1765     }
1766         
1767     HvARRAY(hv) = orig_array;
1768
1769     /* If the hash was actually a symbol table, put the name back.  */
1770     if (name) {
1771         /* We have restored the original array.  If name is non-NULL, then
1772            the original array had an aux structure at the end. So this is
1773            valid:  */
1774         SvFLAGS(hv) |= SVf_OOK;
1775         HvAUX(hv)->xhv_name = name;
1776     }
1777 }
1778
1779 /*
1780 =for apidoc hv_undef
1781
1782 Undefines the hash.
1783
1784 =cut
1785 */
1786
1787 void
1788 Perl_hv_undef(pTHX_ HV *hv)
1789 {
1790     dVAR;
1791     register XPVHV* xhv;
1792     const char *name;
1793
1794     if (!hv)
1795         return;
1796     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1797     xhv = (XPVHV*)SvANY(hv);
1798
1799     if ((name = HvNAME_get(hv)) && !PL_dirty)
1800         mro_isa_changed_in(hv);
1801
1802     hfreeentries(hv);
1803     if (name) {
1804         if (PL_stashcache)
1805             (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1806         hv_name_set(hv, NULL, 0, 0);
1807     }
1808     SvFLAGS(hv) &= ~SVf_OOK;
1809     Safefree(HvARRAY(hv));
1810     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1811     HvARRAY(hv) = 0;
1812     HvPLACEHOLDERS_set(hv, 0);
1813
1814     if (SvRMAGICAL(hv))
1815         mg_clear(MUTABLE_SV(hv));
1816 }
1817
1818 /*
1819 =for apidoc hv_fill
1820
1821 Returns the number of hash buckets that happen to be in use. This function is
1822 wrapped by the macro C<HvFILL>.
1823
1824 Previously this value was stored in the HV structure, rather than being
1825 calculated on demand.
1826
1827 =cut
1828 */
1829
1830 STRLEN
1831 Perl_hv_fill(pTHX_ HV const *const hv)
1832 {
1833     STRLEN count = 0;
1834     HE **ents = HvARRAY(hv);
1835
1836     PERL_ARGS_ASSERT_HV_FILL;
1837
1838     if (ents) {
1839         HE *const *const last = ents + HvMAX(hv);
1840         count = last + 1 - ents;
1841
1842         do {
1843             if (!*ents)
1844                 --count;
1845         } while (++ents <= last);
1846     }
1847     return count;
1848 }
1849
1850 static struct xpvhv_aux*
1851 S_hv_auxinit(HV *hv) {
1852     struct xpvhv_aux *iter;
1853     char *array;
1854
1855     PERL_ARGS_ASSERT_HV_AUXINIT;
1856
1857     if (!HvARRAY(hv)) {
1858         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1859             + sizeof(struct xpvhv_aux), char);
1860     } else {
1861         array = (char *) HvARRAY(hv);
1862         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1863               + sizeof(struct xpvhv_aux), char);
1864     }
1865     HvARRAY(hv) = (HE**) array;
1866     /* SvOOK_on(hv) attacks the IV flags.  */
1867     SvFLAGS(hv) |= SVf_OOK;
1868     iter = HvAUX(hv);
1869
1870     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1871     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1872     iter->xhv_name = 0;
1873     iter->xhv_backreferences = 0;
1874     iter->xhv_mro_meta = NULL;
1875     return iter;
1876 }
1877
1878 /*
1879 =for apidoc hv_iterinit
1880
1881 Prepares a starting point to traverse a hash table.  Returns the number of
1882 keys in the hash (i.e. the same as C<HvKEYS(hv)>).  The return value is
1883 currently only meaningful for hashes without tie magic.
1884
1885 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1886 hash buckets that happen to be in use.  If you still need that esoteric
1887 value, you can get it through the macro C<HvFILL(hv)>.
1888
1889
1890 =cut
1891 */
1892
1893 I32
1894 Perl_hv_iterinit(pTHX_ HV *hv)
1895 {
1896     PERL_ARGS_ASSERT_HV_ITERINIT;
1897
1898     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1899
1900     if (!hv)
1901         Perl_croak(aTHX_ "Bad hash");
1902
1903     if (SvOOK(hv)) {
1904         struct xpvhv_aux * const iter = HvAUX(hv);
1905         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1906         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1907             HvLAZYDEL_off(hv);
1908             hv_free_ent(hv, entry);
1909         }
1910         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1911         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1912     } else {
1913         hv_auxinit(hv);
1914     }
1915
1916     /* used to be xhv->xhv_fill before 5.004_65 */
1917     return HvTOTALKEYS(hv);
1918 }
1919
1920 I32 *
1921 Perl_hv_riter_p(pTHX_ HV *hv) {
1922     struct xpvhv_aux *iter;
1923
1924     PERL_ARGS_ASSERT_HV_RITER_P;
1925
1926     if (!hv)
1927         Perl_croak(aTHX_ "Bad hash");
1928
1929     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1930     return &(iter->xhv_riter);
1931 }
1932
1933 HE **
1934 Perl_hv_eiter_p(pTHX_ HV *hv) {
1935     struct xpvhv_aux *iter;
1936
1937     PERL_ARGS_ASSERT_HV_EITER_P;
1938
1939     if (!hv)
1940         Perl_croak(aTHX_ "Bad hash");
1941
1942     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1943     return &(iter->xhv_eiter);
1944 }
1945
1946 void
1947 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1948     struct xpvhv_aux *iter;
1949
1950     PERL_ARGS_ASSERT_HV_RITER_SET;
1951
1952     if (!hv)
1953         Perl_croak(aTHX_ "Bad hash");
1954
1955     if (SvOOK(hv)) {
1956         iter = HvAUX(hv);
1957     } else {
1958         if (riter == -1)
1959             return;
1960
1961         iter = hv_auxinit(hv);
1962     }
1963     iter->xhv_riter = riter;
1964 }
1965
1966 void
1967 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1968     struct xpvhv_aux *iter;
1969
1970     PERL_ARGS_ASSERT_HV_EITER_SET;
1971
1972     if (!hv)
1973         Perl_croak(aTHX_ "Bad hash");
1974
1975     if (SvOOK(hv)) {
1976         iter = HvAUX(hv);
1977     } else {
1978         /* 0 is the default so don't go malloc()ing a new structure just to
1979            hold 0.  */
1980         if (!eiter)
1981             return;
1982
1983         iter = hv_auxinit(hv);
1984     }
1985     iter->xhv_eiter = eiter;
1986 }
1987
1988 void
1989 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
1990 {
1991     dVAR;
1992     struct xpvhv_aux *iter;
1993     U32 hash;
1994
1995     PERL_ARGS_ASSERT_HV_NAME_SET;
1996     PERL_UNUSED_ARG(flags);
1997
1998     if (len > I32_MAX)
1999         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2000
2001     if (SvOOK(hv)) {
2002         iter = HvAUX(hv);
2003         if (iter->xhv_name) {
2004             unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2005         }
2006     } else {
2007         if (name == 0)
2008             return;
2009
2010         iter = hv_auxinit(hv);
2011     }
2012     PERL_HASH(hash, name, len);
2013     iter->xhv_name = name ? share_hek(name, len, hash) : NULL;
2014 }
2015
2016 AV **
2017 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2018     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2019
2020     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2021     PERL_UNUSED_CONTEXT;
2022
2023     return &(iter->xhv_backreferences);
2024 }
2025
2026 void
2027 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2028     AV *av;
2029
2030     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2031
2032     if (!SvOOK(hv))
2033         return;
2034
2035     av = HvAUX(hv)->xhv_backreferences;
2036
2037     if (av) {
2038         HvAUX(hv)->xhv_backreferences = 0;
2039         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2040         if (SvTYPE(av) == SVt_PVAV)
2041             SvREFCNT_dec(av);
2042     }
2043 }
2044
2045 /*
2046 hv_iternext is implemented as a macro in hv.h
2047
2048 =for apidoc hv_iternext
2049
2050 Returns entries from a hash iterator.  See C<hv_iterinit>.
2051
2052 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2053 iterator currently points to, without losing your place or invalidating your
2054 iterator.  Note that in this case the current entry is deleted from the hash
2055 with your iterator holding the last reference to it.  Your iterator is flagged
2056 to free the entry on the next call to C<hv_iternext>, so you must not discard
2057 your iterator immediately else the entry will leak - call C<hv_iternext> to
2058 trigger the resource deallocation.
2059
2060 =for apidoc hv_iternext_flags
2061
2062 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2063 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2064 set the placeholders keys (for restricted hashes) will be returned in addition
2065 to normal keys. By default placeholders are automatically skipped over.
2066 Currently a placeholder is implemented with a value that is
2067 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2068 restricted hashes may change, and the implementation currently is
2069 insufficiently abstracted for any change to be tidy.
2070
2071 =cut
2072 */
2073
2074 HE *
2075 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2076 {
2077     dVAR;
2078     register XPVHV* xhv;
2079     register HE *entry;
2080     HE *oldentry;
2081     MAGIC* mg;
2082     struct xpvhv_aux *iter;
2083
2084     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2085
2086     if (!hv)
2087         Perl_croak(aTHX_ "Bad hash");
2088
2089     xhv = (XPVHV*)SvANY(hv);
2090
2091     if (!SvOOK(hv)) {
2092         /* Too many things (well, pp_each at least) merrily assume that you can
2093            call iv_iternext without calling hv_iterinit, so we'll have to deal
2094            with it.  */
2095         hv_iterinit(hv);
2096     }
2097     iter = HvAUX(hv);
2098
2099     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2100     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2101         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2102             SV * const key = sv_newmortal();
2103             if (entry) {
2104                 sv_setsv(key, HeSVKEY_force(entry));
2105                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2106             }
2107             else {
2108                 char *k;
2109                 HEK *hek;
2110
2111                 /* one HE per MAGICAL hash */
2112                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2113                 Zero(entry, 1, HE);
2114                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2115                 hek = (HEK*)k;
2116                 HeKEY_hek(entry) = hek;
2117                 HeKLEN(entry) = HEf_SVKEY;
2118             }
2119             magic_nextpack(MUTABLE_SV(hv),mg,key);
2120             if (SvOK(key)) {
2121                 /* force key to stay around until next time */
2122                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2123                 return entry;               /* beware, hent_val is not set */
2124             }
2125             SvREFCNT_dec(HeVAL(entry));
2126             Safefree(HeKEY_hek(entry));
2127             del_HE(entry);
2128             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2129             return NULL;
2130         }
2131     }
2132 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2133     if (!entry && SvRMAGICAL((const SV *)hv)
2134         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2135         prime_env_iter();
2136 #ifdef VMS
2137         /* The prime_env_iter() on VMS just loaded up new hash values
2138          * so the iteration count needs to be reset back to the beginning
2139          */
2140         hv_iterinit(hv);
2141         iter = HvAUX(hv);
2142         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2143 #endif
2144     }
2145 #endif
2146
2147     /* hv_iterint now ensures this.  */
2148     assert (HvARRAY(hv));
2149
2150     /* At start of hash, entry is NULL.  */
2151     if (entry)
2152     {
2153         entry = HeNEXT(entry);
2154         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2155             /*
2156              * Skip past any placeholders -- don't want to include them in
2157              * any iteration.
2158              */
2159             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2160                 entry = HeNEXT(entry);
2161             }
2162         }
2163     }
2164
2165     /* Skip the entire loop if the hash is empty.   */
2166     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2167         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2168         while (!entry) {
2169             /* OK. Come to the end of the current list.  Grab the next one.  */
2170
2171             iter->xhv_riter++; /* HvRITER(hv)++ */
2172             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2173                 /* There is no next one.  End of the hash.  */
2174                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2175                 break;
2176             }
2177             entry = (HvARRAY(hv))[iter->xhv_riter];
2178
2179             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2180                 /* If we have an entry, but it's a placeholder, don't count it.
2181                    Try the next.  */
2182                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2183                     entry = HeNEXT(entry);
2184             }
2185             /* Will loop again if this linked list starts NULL
2186                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2187                or if we run through it and find only placeholders.  */
2188         }
2189     }
2190
2191     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2192         HvLAZYDEL_off(hv);
2193         hv_free_ent(hv, oldentry);
2194     }
2195
2196     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2197       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2198
2199     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2200     return entry;
2201 }
2202
2203 /*
2204 =for apidoc hv_iterkey
2205
2206 Returns the key from the current position of the hash iterator.  See
2207 C<hv_iterinit>.
2208
2209 =cut
2210 */
2211
2212 char *
2213 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2214 {
2215     PERL_ARGS_ASSERT_HV_ITERKEY;
2216
2217     if (HeKLEN(entry) == HEf_SVKEY) {
2218         STRLEN len;
2219         char * const p = SvPV(HeKEY_sv(entry), len);
2220         *retlen = len;
2221         return p;
2222     }
2223     else {
2224         *retlen = HeKLEN(entry);
2225         return HeKEY(entry);
2226     }
2227 }
2228
2229 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2230 /*
2231 =for apidoc hv_iterkeysv
2232
2233 Returns the key as an C<SV*> from the current position of the hash
2234 iterator.  The return value will always be a mortal copy of the key.  Also
2235 see C<hv_iterinit>.
2236
2237 =cut
2238 */
2239
2240 SV *
2241 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2242 {
2243     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2244
2245     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2246 }
2247
2248 /*
2249 =for apidoc hv_iterval
2250
2251 Returns the value from the current position of the hash iterator.  See
2252 C<hv_iterkey>.
2253
2254 =cut
2255 */
2256
2257 SV *
2258 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2259 {
2260     PERL_ARGS_ASSERT_HV_ITERVAL;
2261
2262     if (SvRMAGICAL(hv)) {
2263         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2264             SV* const sv = sv_newmortal();
2265             if (HeKLEN(entry) == HEf_SVKEY)
2266                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2267             else
2268                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2269             return sv;
2270         }
2271     }
2272     return HeVAL(entry);
2273 }
2274
2275 /*
2276 =for apidoc hv_iternextsv
2277
2278 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2279 operation.
2280
2281 =cut
2282 */
2283
2284 SV *
2285 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2286 {
2287     HE * const he = hv_iternext_flags(hv, 0);
2288
2289     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2290
2291     if (!he)
2292         return NULL;
2293     *key = hv_iterkey(he, retlen);
2294     return hv_iterval(hv, he);
2295 }
2296
2297 /*
2298
2299 Now a macro in hv.h
2300
2301 =for apidoc hv_magic
2302
2303 Adds magic to a hash.  See C<sv_magic>.
2304
2305 =cut
2306 */
2307
2308 /* possibly free a shared string if no one has access to it
2309  * len and hash must both be valid for str.
2310  */
2311 void
2312 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2313 {
2314     unshare_hek_or_pvn (NULL, str, len, hash);
2315 }
2316
2317
2318 void
2319 Perl_unshare_hek(pTHX_ HEK *hek)
2320 {
2321     assert(hek);
2322     unshare_hek_or_pvn(hek, NULL, 0, 0);
2323 }
2324
2325 /* possibly free a shared string if no one has access to it
2326    hek if non-NULL takes priority over the other 3, else str, len and hash
2327    are used.  If so, len and hash must both be valid for str.
2328  */
2329 STATIC void
2330 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2331 {
2332     dVAR;
2333     register XPVHV* xhv;
2334     HE *entry;
2335     register HE **oentry;
2336     HE **first;
2337     bool is_utf8 = FALSE;
2338     int k_flags = 0;
2339     const char * const save = str;
2340     struct shared_he *he = NULL;
2341
2342     if (hek) {
2343         /* Find the shared he which is just before us in memory.  */
2344         he = (struct shared_he *)(((char *)hek)
2345                                   - STRUCT_OFFSET(struct shared_he,
2346                                                   shared_he_hek));
2347
2348         /* Assert that the caller passed us a genuine (or at least consistent)
2349            shared hek  */
2350         assert (he->shared_he_he.hent_hek == hek);
2351
2352         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2353             --he->shared_he_he.he_valu.hent_refcount;
2354             return;
2355         }
2356
2357         hash = HEK_HASH(hek);
2358     } else if (len < 0) {
2359         STRLEN tmplen = -len;
2360         is_utf8 = TRUE;
2361         /* See the note in hv_fetch(). --jhi */
2362         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2363         len = tmplen;
2364         if (is_utf8)
2365             k_flags = HVhek_UTF8;
2366         if (str != save)
2367             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2368     }
2369
2370     /* what follows was the moral equivalent of:
2371     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2372         if (--*Svp == NULL)
2373             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2374     } */
2375     xhv = (XPVHV*)SvANY(PL_strtab);
2376     /* assert(xhv_array != 0) */
2377     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2378     if (he) {
2379         const HE *const he_he = &(he->shared_he_he);
2380         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2381             if (entry == he_he)
2382                 break;
2383         }
2384     } else {
2385         const int flags_masked = k_flags & HVhek_MASK;
2386         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2387             if (HeHASH(entry) != hash)          /* strings can't be equal */
2388                 continue;
2389             if (HeKLEN(entry) != len)
2390                 continue;
2391             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2392                 continue;
2393             if (HeKFLAGS(entry) != flags_masked)
2394                 continue;
2395             break;
2396         }
2397     }
2398
2399     if (entry) {
2400         if (--entry->he_valu.hent_refcount == 0) {
2401             *oentry = HeNEXT(entry);
2402             Safefree(entry);
2403             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2404         }
2405     }
2406
2407     if (!entry)
2408         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2409                          "Attempt to free non-existent shared string '%s'%s"
2410                          pTHX__FORMAT,
2411                          hek ? HEK_KEY(hek) : str,
2412                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2413     if (k_flags & HVhek_FREEKEY)
2414         Safefree(str);
2415 }
2416
2417 /* get a (constant) string ptr from the global string table
2418  * string will get added if it is not already there.
2419  * len and hash must both be valid for str.
2420  */
2421 HEK *
2422 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2423 {
2424     bool is_utf8 = FALSE;
2425     int flags = 0;
2426     const char * const save = str;
2427
2428     PERL_ARGS_ASSERT_SHARE_HEK;
2429
2430     if (len < 0) {
2431       STRLEN tmplen = -len;
2432       is_utf8 = TRUE;
2433       /* See the note in hv_fetch(). --jhi */
2434       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2435       len = tmplen;
2436       /* If we were able to downgrade here, then than means that we were passed
2437          in a key which only had chars 0-255, but was utf8 encoded.  */
2438       if (is_utf8)
2439           flags = HVhek_UTF8;
2440       /* If we found we were able to downgrade the string to bytes, then
2441          we should flag that it needs upgrading on keys or each.  Also flag
2442          that we need share_hek_flags to free the string.  */
2443       if (str != save)
2444           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2445     }
2446
2447     return share_hek_flags (str, len, hash, flags);
2448 }
2449
2450 STATIC HEK *
2451 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2452 {
2453     dVAR;
2454     register HE *entry;
2455     const int flags_masked = flags & HVhek_MASK;
2456     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2457     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2458
2459     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2460
2461     /* what follows is the moral equivalent of:
2462
2463     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2464         hv_store(PL_strtab, str, len, NULL, hash);
2465
2466         Can't rehash the shared string table, so not sure if it's worth
2467         counting the number of entries in the linked list
2468     */
2469
2470     /* assert(xhv_array != 0) */
2471     entry = (HvARRAY(PL_strtab))[hindex];
2472     for (;entry; entry = HeNEXT(entry)) {
2473         if (HeHASH(entry) != hash)              /* strings can't be equal */
2474             continue;
2475         if (HeKLEN(entry) != len)
2476             continue;
2477         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2478             continue;
2479         if (HeKFLAGS(entry) != flags_masked)
2480             continue;
2481         break;
2482     }
2483
2484     if (!entry) {
2485         /* What used to be head of the list.
2486            If this is NULL, then we're the first entry for this slot, which
2487            means we need to increate fill.  */
2488         struct shared_he *new_entry;
2489         HEK *hek;
2490         char *k;
2491         HE **const head = &HvARRAY(PL_strtab)[hindex];
2492         HE *const next = *head;
2493
2494         /* We don't actually store a HE from the arena and a regular HEK.
2495            Instead we allocate one chunk of memory big enough for both,
2496            and put the HEK straight after the HE. This way we can find the
2497            HEK directly from the HE.
2498         */
2499
2500         Newx(k, STRUCT_OFFSET(struct shared_he,
2501                                 shared_he_hek.hek_key[0]) + len + 2, char);
2502         new_entry = (struct shared_he *)k;
2503         entry = &(new_entry->shared_he_he);
2504         hek = &(new_entry->shared_he_hek);
2505
2506         Copy(str, HEK_KEY(hek), len, char);
2507         HEK_KEY(hek)[len] = 0;
2508         HEK_LEN(hek) = len;
2509         HEK_HASH(hek) = hash;
2510         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2511
2512         /* Still "point" to the HEK, so that other code need not know what
2513            we're up to.  */
2514         HeKEY_hek(entry) = hek;
2515         entry->he_valu.hent_refcount = 0;
2516         HeNEXT(entry) = next;
2517         *head = entry;
2518
2519         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2520         if (!next) {                    /* initial entry? */
2521         } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2522                 hsplit(PL_strtab);
2523         }
2524     }
2525
2526     ++entry->he_valu.hent_refcount;
2527
2528     if (flags & HVhek_FREEKEY)
2529         Safefree(str);
2530
2531     return HeKEY_hek(entry);
2532 }
2533
2534 I32 *
2535 Perl_hv_placeholders_p(pTHX_ HV *hv)
2536 {
2537     dVAR;
2538     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2539
2540     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2541
2542     if (!mg) {
2543         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2544
2545         if (!mg) {
2546             Perl_die(aTHX_ "panic: hv_placeholders_p");
2547         }
2548     }
2549     return &(mg->mg_len);
2550 }
2551
2552
2553 I32
2554 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2555 {
2556     dVAR;
2557     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2558
2559     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2560
2561     return mg ? mg->mg_len : 0;
2562 }
2563
2564 void
2565 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2566 {
2567     dVAR;
2568     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2569
2570     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2571
2572     if (mg) {
2573         mg->mg_len = ph;
2574     } else if (ph) {
2575         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2576             Perl_die(aTHX_ "panic: hv_placeholders_set");
2577     }
2578     /* else we don't need to add magic to record 0 placeholders.  */
2579 }
2580
2581 STATIC SV *
2582 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2583 {
2584     dVAR;
2585     SV *value;
2586
2587     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2588
2589     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2590     case HVrhek_undef:
2591         value = newSV(0);
2592         break;
2593     case HVrhek_delete:
2594         value = &PL_sv_placeholder;
2595         break;
2596     case HVrhek_IV:
2597         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2598         break;
2599     case HVrhek_UV:
2600         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2601         break;
2602     case HVrhek_PV:
2603     case HVrhek_PV_UTF8:
2604         /* Create a string SV that directly points to the bytes in our
2605            structure.  */
2606         value = newSV_type(SVt_PV);
2607         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2608         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2609         /* This stops anything trying to free it  */
2610         SvLEN_set(value, 0);
2611         SvPOK_on(value);
2612         SvREADONLY_on(value);
2613         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2614             SvUTF8_on(value);
2615         break;
2616     default:
2617         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2618                    he->refcounted_he_data[0]);
2619     }
2620     return value;
2621 }
2622
2623 /*
2624 =for apidoc cop_hints_2hv
2625
2626 Generates and returns a C<HV *> from the hinthash in the provided
2627 C<COP>. Returns C<NULL> if there isn't one there.
2628
2629 =cut
2630 */
2631 HV *
2632 Perl_cop_hints_2hv(pTHX_ const COP *cop)
2633 {
2634     PERL_ARGS_ASSERT_COP_HINTS_2HV;
2635
2636     if (!cop->cop_hints_hash)
2637         return NULL;
2638
2639     return Perl_refcounted_he_chain_2hv(aTHX_ cop->cop_hints_hash);
2640 }
2641
2642 /*
2643 =for apidoc cop_hints_fetchsv
2644
2645 Fetches an entry from the hinthash in the provided C<COP>. Returns NULL
2646 if the entry isn't there.
2647
2648 =for apidoc cop_hints_fetchpvn
2649
2650 See L</cop_hints_fetchsv>. If C<flags> includes C<HVhek_UTF8>, C<key> is
2651 in UTF-8.
2652
2653 =for apidoc cop_hints_fetchpvs
2654
2655 See L</cop_hints_fetchpvn>. This is a macro that takes a constant string
2656 for its argument, which is assumed to be ASCII (rather than UTF-8).
2657
2658 =cut
2659 */
2660 SV *
2661 Perl_cop_hints_fetchpvn(pTHX_ const COP *cop, const char *key, STRLEN klen,
2662                             int flags, U32 hash)
2663 {
2664     PERL_ARGS_ASSERT_COP_HINTS_FETCHPVN;
2665
2666     /* refcounted_he_fetch takes more flags than we do. Make sure
2667      * noone's depending on being able to pass them here. */
2668     flags &= ~HVhek_UTF8;
2669
2670     return Perl_refcounted_he_fetch(aTHX_ cop->cop_hints_hash, NULL,
2671         key, klen, flags, hash);
2672 }
2673
2674 /*
2675 =for apidoc refcounted_he_chain_2hv
2676
2677 Generates and returns a C<HV *> by walking up the tree starting at the passed
2678 in C<struct refcounted_he *>.
2679
2680 =cut
2681 */
2682 HV *
2683 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2684 {
2685     dVAR;
2686     HV *hv = newHV();
2687     U32 placeholders = 0;
2688     /* We could chase the chain once to get an idea of the number of keys,
2689        and call ksplit.  But for now we'll make a potentially inefficient
2690        hash with only 8 entries in its array.  */
2691     const U32 max = HvMAX(hv);
2692
2693     if (!HvARRAY(hv)) {
2694         char *array;
2695         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2696         HvARRAY(hv) = (HE**)array;
2697     }
2698
2699     while (chain) {
2700 #ifdef USE_ITHREADS
2701         U32 hash = chain->refcounted_he_hash;
2702 #else
2703         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2704 #endif
2705         HE **oentry = &((HvARRAY(hv))[hash & max]);
2706         HE *entry = *oentry;
2707         SV *value;
2708
2709         for (; entry; entry = HeNEXT(entry)) {
2710             if (HeHASH(entry) == hash) {
2711                 /* We might have a duplicate key here.  If so, entry is older
2712                    than the key we've already put in the hash, so if they are
2713                    the same, skip adding entry.  */
2714 #ifdef USE_ITHREADS
2715                 const STRLEN klen = HeKLEN(entry);
2716                 const char *const key = HeKEY(entry);
2717                 if (klen == chain->refcounted_he_keylen
2718                     && (!!HeKUTF8(entry)
2719                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2720                     && memEQ(key, REF_HE_KEY(chain), klen))
2721                     goto next_please;
2722 #else
2723                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2724                     goto next_please;
2725                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2726                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2727                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2728                              HeKLEN(entry)))
2729                     goto next_please;
2730 #endif
2731             }
2732         }
2733         assert (!entry);
2734         entry = new_HE();
2735
2736 #ifdef USE_ITHREADS
2737         HeKEY_hek(entry)
2738             = share_hek_flags(REF_HE_KEY(chain),
2739                               chain->refcounted_he_keylen,
2740                               chain->refcounted_he_hash,
2741                               (chain->refcounted_he_data[0]
2742                                & (HVhek_UTF8|HVhek_WASUTF8)));
2743 #else
2744         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2745 #endif
2746         value = refcounted_he_value(chain);
2747         if (value == &PL_sv_placeholder)
2748             placeholders++;
2749         HeVAL(entry) = value;
2750
2751         /* Link it into the chain.  */
2752         HeNEXT(entry) = *oentry;
2753         *oentry = entry;
2754
2755         HvTOTALKEYS(hv)++;
2756
2757     next_please:
2758         chain = chain->refcounted_he_next;
2759     }
2760
2761     if (placeholders) {
2762         clear_placeholders(hv, placeholders);
2763         HvTOTALKEYS(hv) -= placeholders;
2764     }
2765
2766     /* We could check in the loop to see if we encounter any keys with key
2767        flags, but it's probably not worth it, as this per-hash flag is only
2768        really meant as an optimisation for things like Storable.  */
2769     HvHASKFLAGS_on(hv);
2770     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2771
2772     return hv;
2773 }
2774
2775 SV *
2776 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2777                          const char *key, STRLEN klen, int flags, U32 hash)
2778 {
2779     dVAR;
2780     /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2781        of your key has to exactly match that which is stored.  */
2782     SV *value = &PL_sv_placeholder;
2783
2784     if (chain) {
2785         /* No point in doing any of this if there's nothing to find.  */
2786         bool is_utf8;
2787
2788         if (keysv) {
2789             if (flags & HVhek_FREEKEY)
2790                 Safefree(key);
2791             key = SvPV_const(keysv, klen);
2792             flags = 0;
2793             is_utf8 = (SvUTF8(keysv) != 0);
2794         } else {
2795             is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
2796         }
2797
2798         if (!hash) {
2799             if (keysv && (SvIsCOW_shared_hash(keysv))) {
2800                 hash = SvSHARED_HASH(keysv);
2801             } else {
2802                 PERL_HASH(hash, key, klen);
2803             }
2804         }
2805
2806         for (; chain; chain = chain->refcounted_he_next) {
2807 #ifdef USE_ITHREADS
2808             if (hash != chain->refcounted_he_hash)
2809                 continue;
2810             if (klen != chain->refcounted_he_keylen)
2811                 continue;
2812             if (memNE(REF_HE_KEY(chain),key,klen))
2813                 continue;
2814             if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2815                 continue;
2816 #else
2817             if (hash != HEK_HASH(chain->refcounted_he_hek))
2818                 continue;
2819             if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
2820                 continue;
2821             if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2822                 continue;
2823             if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2824                 continue;
2825 #endif
2826
2827             value = sv_2mortal(refcounted_he_value(chain));
2828             break;
2829         }
2830     }
2831
2832     if (flags & HVhek_FREEKEY)
2833         Safefree(key);
2834
2835     return value;
2836 }
2837
2838 /*
2839 =for apidoc refcounted_he_new
2840
2841 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2842 stored in a compact form, all references remain the property of the caller.
2843 The C<struct refcounted_he> is returned with a reference count of 1.
2844
2845 =cut
2846 */
2847
2848 struct refcounted_he *
2849 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2850                        SV *const key, SV *const value) {
2851     dVAR;
2852     STRLEN key_len;
2853     const char *key_p = SvPV_const(key, key_len);
2854     STRLEN value_len = 0;
2855     const char *value_p = NULL;
2856     char value_type;
2857     char flags;
2858     bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
2859
2860     if (SvPOK(value)) {
2861         value_type = HVrhek_PV;
2862     } else if (SvIOK(value)) {
2863         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
2864     } else if (value == &PL_sv_placeholder) {
2865         value_type = HVrhek_delete;
2866     } else if (!SvOK(value)) {
2867         value_type = HVrhek_undef;
2868     } else {
2869         value_type = HVrhek_PV;
2870     }
2871
2872     if (value_type == HVrhek_PV) {
2873         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
2874            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
2875         value_p = SvPV_const(value, value_len);
2876         if (SvUTF8(value))
2877             value_type = HVrhek_PV_UTF8;
2878     }
2879     flags = value_type;
2880
2881     if (is_utf8) {
2882         /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2883            As we're going to be building hash keys from this value in future,
2884            normalise it now.  */
2885         key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2886         flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2887     }
2888
2889     return refcounted_he_new_common(parent, key_p, key_len, flags, value_type,
2890                                     ((value_type == HVrhek_PV
2891                                       || value_type == HVrhek_PV_UTF8) ?
2892                                      (void *)value_p : (void *)value),
2893                                     value_len);
2894 }
2895
2896 static struct refcounted_he *
2897 S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent,
2898                            const char *const key_p, const STRLEN key_len,
2899                            const char flags, char value_type,
2900                            const void *value, const STRLEN value_len) {
2901     dVAR;
2902     struct refcounted_he *he;
2903     U32 hash;
2904     const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8;
2905     STRLEN key_offset = is_pv ? value_len + 2 : 1;
2906
2907     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON;
2908
2909 #ifdef USE_ITHREADS
2910     he = (struct refcounted_he*)
2911         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2912                              + key_len
2913                              + key_offset);
2914 #else
2915     he = (struct refcounted_he*)
2916         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2917                              + key_offset);
2918 #endif
2919
2920     he->refcounted_he_next = parent;
2921
2922     if (is_pv) {
2923         Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char);
2924         he->refcounted_he_val.refcounted_he_u_len = value_len;
2925     } else if (value_type == HVrhek_IV) {
2926         he->refcounted_he_val.refcounted_he_u_iv = SvIVX((const SV *)value);
2927     } else if (value_type == HVrhek_UV) {
2928         he->refcounted_he_val.refcounted_he_u_uv = SvUVX((const SV *)value);
2929     }
2930
2931     PERL_HASH(hash, key_p, key_len);
2932
2933 #ifdef USE_ITHREADS
2934     he->refcounted_he_hash = hash;
2935     he->refcounted_he_keylen = key_len;
2936     Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
2937 #else
2938     he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
2939 #endif
2940
2941     if (flags & HVhek_WASUTF8) {
2942         /* If it was downgraded from UTF-8, then the pointer returned from
2943            bytes_from_utf8 is an allocated pointer that we must free.  */
2944         Safefree(key_p);
2945     }
2946
2947     he->refcounted_he_data[0] = flags;
2948     he->refcounted_he_refcnt = 1;
2949
2950     return he;
2951 }
2952
2953 /*
2954 =for apidoc refcounted_he_free
2955
2956 Decrements the reference count of the passed in C<struct refcounted_he *>
2957 by one. If the reference count reaches zero the structure's memory is freed,
2958 and C<refcounted_he_free> iterates onto the parent node.
2959
2960 =cut
2961 */
2962
2963 void
2964 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
2965     dVAR;
2966     PERL_UNUSED_CONTEXT;
2967
2968     while (he) {
2969         struct refcounted_he *copy;
2970         U32 new_count;
2971
2972         HINTS_REFCNT_LOCK;
2973         new_count = --he->refcounted_he_refcnt;
2974         HINTS_REFCNT_UNLOCK;
2975         
2976         if (new_count) {
2977             return;
2978         }
2979
2980 #ifndef USE_ITHREADS
2981         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
2982 #endif
2983         copy = he;
2984         he = he->refcounted_he_next;
2985         PerlMemShared_free(copy);
2986     }
2987 }
2988
2989 /* pp_entereval is aware that labels are stored with a key ':' at the top of
2990    the linked list.  */
2991 const char *
2992 Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
2993     struct refcounted_he *const chain = cop->cop_hints_hash;
2994
2995     PERL_ARGS_ASSERT_FETCH_COP_LABEL;
2996
2997     if (!chain)
2998         return NULL;
2999 #ifdef USE_ITHREADS
3000     if (chain->refcounted_he_keylen != 1)
3001         return NULL;
3002     if (*REF_HE_KEY(chain) != ':')
3003         return NULL;
3004 #else
3005     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3006         return NULL;
3007     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3008         return NULL;
3009 #endif
3010     /* Stop anyone trying to really mess us up by adding their own value for
3011        ':' into %^H  */
3012     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3013         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3014         return NULL;
3015
3016     if (len)
3017         *len = chain->refcounted_he_val.refcounted_he_u_len;
3018     if (flags) {
3019         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3020                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3021     }
3022     return chain->refcounted_he_data + 1;
3023 }
3024
3025 void
3026 Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3027                      U32 flags)
3028 {
3029     PERL_ARGS_ASSERT_STORE_COP_LABEL;
3030
3031     if (flags & ~(SVf_UTF8))
3032         Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
3033                    (UV)flags);
3034
3035     cop->cop_hints_hash
3036         = refcounted_he_new_common(cop->cop_hints_hash, ":", 1, HVrhek_PV,
3037                                    flags & SVf_UTF8 ? HVrhek_PV_UTF8 : HVrhek_PV,
3038                                    label, len);
3039 }
3040
3041 /*
3042 =for apidoc hv_assert
3043
3044 Check that a hash is in an internally consistent state.
3045
3046 =cut
3047 */
3048
3049 #ifdef DEBUGGING
3050
3051 void
3052 Perl_hv_assert(pTHX_ HV *hv)
3053 {
3054     dVAR;
3055     HE* entry;
3056     int withflags = 0;
3057     int placeholders = 0;
3058     int real = 0;
3059     int bad = 0;
3060     const I32 riter = HvRITER_get(hv);
3061     HE *eiter = HvEITER_get(hv);
3062
3063     PERL_ARGS_ASSERT_HV_ASSERT;
3064
3065     (void)hv_iterinit(hv);
3066
3067     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3068         /* sanity check the values */
3069         if (HeVAL(entry) == &PL_sv_placeholder)
3070             placeholders++;
3071         else
3072             real++;
3073         /* sanity check the keys */
3074         if (HeSVKEY(entry)) {
3075             NOOP;   /* Don't know what to check on SV keys.  */
3076         } else if (HeKUTF8(entry)) {
3077             withflags++;
3078             if (HeKWASUTF8(entry)) {
3079                 PerlIO_printf(Perl_debug_log,
3080                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3081                             (int) HeKLEN(entry),  HeKEY(entry));
3082                 bad = 1;
3083             }
3084         } else if (HeKWASUTF8(entry))
3085             withflags++;
3086     }
3087     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3088         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3089         const int nhashkeys = HvUSEDKEYS(hv);
3090         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3091
3092         if (nhashkeys != real) {
3093             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3094             bad = 1;
3095         }
3096         if (nhashplaceholders != placeholders) {
3097             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3098             bad = 1;
3099         }
3100     }
3101     if (withflags && ! HvHASKFLAGS(hv)) {
3102         PerlIO_printf(Perl_debug_log,
3103                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3104                     withflags);
3105         bad = 1;
3106     }
3107     if (bad) {
3108         sv_dump(MUTABLE_SV(hv));
3109     }
3110     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3111     HvEITER_set(hv, eiter);
3112 }
3113
3114 #endif
3115
3116 /*
3117  * Local variables:
3118  * c-indentation-style: bsd
3119  * c-basic-offset: 4
3120  * indent-tabs-mode: t
3121  * End:
3122  *
3123  * ex: set ts=8 sts=4 sw=4 noet:
3124  */