This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
01b073df2654b8a3dbc44d5a46125923deeeaf4e
[perl5.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) == (svtype)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) || (!hash && !(keysv && (SvIsCOW_shared_hash(keysv)))))
608         PERL_HASH_INTERNAL_(hash, key, klen, HvREHASH(hv));
609     else if (!hash)
610         hash = SvSHARED_HASH(keysv);
611
612     /* We don't have a pointer to the hv, so we have to replicate the
613        flag into every HEK, so that hv_iterkeysv can see it.
614        And yes, you do need this even though you are not "storing" because
615        you can flip the flags below if doing an lval lookup.  (And that
616        was put in to give the semantics Andreas was expecting.)  */
617     if (HvREHASH(hv))
618         flags |= HVhek_REHASH;
619
620     masked_flags = (flags & HVhek_MASK);
621
622 #ifdef DYNAMIC_ENV_FETCH
623     if (!HvARRAY(hv)) entry = NULL;
624     else
625 #endif
626     {
627         entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
628     }
629     for (; entry; entry = HeNEXT(entry)) {
630         if (HeHASH(entry) != hash)              /* strings can't be equal */
631             continue;
632         if (HeKLEN(entry) != (I32)klen)
633             continue;
634         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
635             continue;
636         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
637             continue;
638
639         if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
640             if (HeKFLAGS(entry) != masked_flags) {
641                 /* We match if HVhek_UTF8 bit in our flags and hash key's
642                    match.  But if entry was set previously with HVhek_WASUTF8
643                    and key now doesn't (or vice versa) then we should change
644                    the key's flag, as this is assignment.  */
645                 if (HvSHAREKEYS(hv)) {
646                     /* Need to swap the key we have for a key with the flags we
647                        need. As keys are shared we can't just write to the
648                        flag, so we share the new one, unshare the old one.  */
649                     HEK * const new_hek = share_hek_flags(key, klen, hash,
650                                                    masked_flags);
651                     unshare_hek (HeKEY_hek(entry));
652                     HeKEY_hek(entry) = new_hek;
653                 }
654                 else if (hv == PL_strtab) {
655                     /* PL_strtab is usually the only hash without HvSHAREKEYS,
656                        so putting this test here is cheap  */
657                     if (flags & HVhek_FREEKEY)
658                         Safefree(key);
659                     Perl_croak(aTHX_ S_strtab_error,
660                                action & HV_FETCH_LVALUE ? "fetch" : "store");
661                 }
662                 else
663                     HeKFLAGS(entry) = masked_flags;
664                 if (masked_flags & HVhek_ENABLEHVKFLAGS)
665                     HvHASKFLAGS_on(hv);
666             }
667             if (HeVAL(entry) == &PL_sv_placeholder) {
668                 /* yes, can store into placeholder slot */
669                 if (action & HV_FETCH_LVALUE) {
670                     if (SvMAGICAL(hv)) {
671                         /* This preserves behaviour with the old hv_fetch
672                            implementation which at this point would bail out
673                            with a break; (at "if we find a placeholder, we
674                            pretend we haven't found anything")
675
676                            That break mean that if a placeholder were found, it
677                            caused a call into hv_store, which in turn would
678                            check magic, and if there is no magic end up pretty
679                            much back at this point (in hv_store's code).  */
680                         break;
681                     }
682                     /* LVAL fetch which actually needs a store.  */
683                     val = newSV(0);
684                     HvPLACEHOLDERS(hv)--;
685                 } else {
686                     /* store */
687                     if (val != &PL_sv_placeholder)
688                         HvPLACEHOLDERS(hv)--;
689                 }
690                 HeVAL(entry) = val;
691             } else if (action & HV_FETCH_ISSTORE) {
692                 SvREFCNT_dec(HeVAL(entry));
693                 HeVAL(entry) = val;
694             }
695         } else if (HeVAL(entry) == &PL_sv_placeholder) {
696             /* if we find a placeholder, we pretend we haven't found
697                anything */
698             break;
699         }
700         if (flags & HVhek_FREEKEY)
701             Safefree(key);
702         if (return_svp) {
703             return entry ? (void *) &HeVAL(entry) : NULL;
704         }
705         return entry;
706     }
707 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
708     if (!(action & HV_FETCH_ISSTORE) 
709         && SvRMAGICAL((const SV *)hv)
710         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
711         unsigned long len;
712         const char * const env = PerlEnv_ENVgetenv_len(key,&len);
713         if (env) {
714             sv = newSVpvn(env,len);
715             SvTAINTED_on(sv);
716             return hv_common(hv, keysv, key, klen, flags,
717                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
718                              sv, hash);
719         }
720     }
721 #endif
722
723     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
724         hv_notallowed(flags, key, klen,
725                         "Attempt to access disallowed key '%"SVf"' in"
726                         " a restricted hash");
727     }
728     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
729         /* Not doing some form of store, so return failure.  */
730         if (flags & HVhek_FREEKEY)
731             Safefree(key);
732         return NULL;
733     }
734     if (action & HV_FETCH_LVALUE) {
735         val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0);
736         if (SvMAGICAL(hv)) {
737             /* At this point the old hv_fetch code would call to hv_store,
738                which in turn might do some tied magic. So we need to make that
739                magic check happen.  */
740             /* gonna assign to this, so it better be there */
741             /* If a fetch-as-store fails on the fetch, then the action is to
742                recurse once into "hv_store". If we didn't do this, then that
743                recursive call would call the key conversion routine again.
744                However, as we replace the original key with the converted
745                key, this would result in a double conversion, which would show
746                up as a bug if the conversion routine is not idempotent.  */
747             return hv_common(hv, keysv, key, klen, flags,
748                              HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
749                              val, hash);
750             /* XXX Surely that could leak if the fetch-was-store fails?
751                Just like the hv_fetch.  */
752         }
753     }
754
755     /* Welcome to hv_store...  */
756
757     if (!HvARRAY(hv)) {
758         /* Not sure if we can get here.  I think the only case of oentry being
759            NULL is for %ENV with dynamic env fetch.  But that should disappear
760            with magic in the previous code.  */
761         char *array;
762         Newxz(array,
763              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
764              char);
765         HvARRAY(hv) = (HE**)array;
766     }
767
768     oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
769
770     entry = new_HE();
771     /* share_hek_flags will do the free for us.  This might be considered
772        bad API design.  */
773     if (HvSHAREKEYS(hv))
774         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
775     else if (hv == PL_strtab) {
776         /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
777            this test here is cheap  */
778         if (flags & HVhek_FREEKEY)
779             Safefree(key);
780         Perl_croak(aTHX_ S_strtab_error,
781                    action & HV_FETCH_LVALUE ? "fetch" : "store");
782     }
783     else                                       /* gotta do the real thing */
784         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
785     HeVAL(entry) = val;
786     HeNEXT(entry) = *oentry;
787     *oentry = entry;
788
789     if (val == &PL_sv_placeholder)
790         HvPLACEHOLDERS(hv)++;
791     if (masked_flags & HVhek_ENABLEHVKFLAGS)
792         HvHASKFLAGS_on(hv);
793
794     {
795         const HE *counter = HeNEXT(entry);
796
797         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
798         if (!counter) {                         /* initial entry? */
799         } else if (xhv->xhv_keys > xhv->xhv_max) {
800                 /* Use only the old HvUSEDKEYS(hv) > HvMAX(hv) condition to limit
801                    bucket splits on a rehashed hash, as we're not going to
802                    split it again, and if someone is lucky (evil) enough to
803                    get all the keys in one list they could exhaust our memory
804                    as we repeatedly double the number of buckets on every
805                    entry. Linear search feels a less worse thing to do.  */
806             hsplit(hv);
807         } else if(!HvREHASH(hv)) {
808             U32 n_links = 1;
809
810             while ((counter = HeNEXT(counter)))
811                 n_links++;
812
813             if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
814                 hsplit(hv);
815             }
816         }
817     }
818
819     if (return_svp) {
820         return entry ? (void *) &HeVAL(entry) : NULL;
821     }
822     return (void *) entry;
823 }
824
825 STATIC void
826 S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
827 {
828     const MAGIC *mg = SvMAGIC(hv);
829
830     PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
831
832     *needs_copy = FALSE;
833     *needs_store = TRUE;
834     while (mg) {
835         if (isUPPER(mg->mg_type)) {
836             *needs_copy = TRUE;
837             if (mg->mg_type == PERL_MAGIC_tied) {
838                 *needs_store = FALSE;
839                 return; /* We've set all there is to set. */
840             }
841         }
842         mg = mg->mg_moremagic;
843     }
844 }
845
846 /*
847 =for apidoc hv_scalar
848
849 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
850
851 =cut
852 */
853
854 SV *
855 Perl_hv_scalar(pTHX_ HV *hv)
856 {
857     SV *sv;
858
859     PERL_ARGS_ASSERT_HV_SCALAR;
860
861     if (SvRMAGICAL(hv)) {
862         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
863         if (mg)
864             return magic_scalarpack(hv, mg);
865     }
866
867     sv = sv_newmortal();
868     if (HvTOTALKEYS((const HV *)hv)) 
869         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
870                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
871     else
872         sv_setiv(sv, 0);
873     
874     return sv;
875 }
876
877 /*
878 =for apidoc hv_delete
879
880 Deletes a key/value pair in the hash.  The value's SV is removed from the
881 hash, made mortal, and returned to the caller.  The C<klen> is the length of
882 the key.  The C<flags> value will normally be zero; if set to G_DISCARD then
883 NULL will be returned.  NULL will also be returned if the key is not found.
884
885 =for apidoc hv_delete_ent
886
887 Deletes a key/value pair in the hash.  The value SV is removed from the hash,
888 made mortal, and returned to the caller.  The C<flags> value will normally be
889 zero; if set to G_DISCARD then NULL will be returned.  NULL will also be
890 returned if the key is not found.  C<hash> can be a valid precomputed hash
891 value, or 0 to ask for it to be computed.
892
893 =cut
894 */
895
896 STATIC SV *
897 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
898                    int k_flags, I32 d_flags, U32 hash)
899 {
900     dVAR;
901     register XPVHV* xhv;
902     register HE *entry;
903     register HE **oentry;
904     bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
905     int masked_flags;
906
907     if (SvRMAGICAL(hv)) {
908         bool needs_copy;
909         bool needs_store;
910         hv_magic_check (hv, &needs_copy, &needs_store);
911
912         if (needs_copy) {
913             SV *sv;
914             entry = (HE *) hv_common(hv, keysv, key, klen,
915                                      k_flags & ~HVhek_FREEKEY,
916                                      HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
917                                      NULL, hash);
918             sv = entry ? HeVAL(entry) : NULL;
919             if (sv) {
920                 if (SvMAGICAL(sv)) {
921                     mg_clear(sv);
922                 }
923                 if (!needs_store) {
924                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
925                         /* No longer an element */
926                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
927                         return sv;
928                     }           
929                     return NULL;                /* element cannot be deleted */
930                 }
931 #ifdef ENV_IS_CASELESS
932                 else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
933                     /* XXX This code isn't UTF8 clean.  */
934                     keysv = newSVpvn_flags(key, klen, SVs_TEMP);
935                     if (k_flags & HVhek_FREEKEY) {
936                         Safefree(key);
937                     }
938                     key = strupr(SvPVX(keysv));
939                     is_utf8 = 0;
940                     k_flags = 0;
941                     hash = 0;
942                 }
943 #endif
944             }
945         }
946     }
947     xhv = (XPVHV*)SvANY(hv);
948     if (!HvARRAY(hv))
949         return NULL;
950
951     if (is_utf8) {
952         const char * const keysave = key;
953         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
954
955         if (is_utf8)
956             k_flags |= HVhek_UTF8;
957         else
958             k_flags &= ~HVhek_UTF8;
959         if (key != keysave) {
960             if (k_flags & HVhek_FREEKEY) {
961                 /* This shouldn't happen if our caller does what we expect,
962                    but strictly the API allows it.  */
963                 Safefree(keysave);
964             }
965             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
966         }
967         HvHASKFLAGS_on(MUTABLE_SV(hv));
968     }
969
970     if (HvREHASH(hv) || (!hash && !(keysv && (SvIsCOW_shared_hash(keysv)))))
971         PERL_HASH_INTERNAL_(hash, key, klen, HvREHASH(hv));
972     else if (!hash)
973         hash = SvSHARED_HASH(keysv);
974
975     masked_flags = (k_flags & HVhek_MASK);
976
977     oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
978     entry = *oentry;
979     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
980         SV *sv;
981         U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
982         GV *gv = NULL;
983         HV *stash = NULL;
984
985         if (HeHASH(entry) != hash)              /* strings can't be equal */
986             continue;
987         if (HeKLEN(entry) != (I32)klen)
988             continue;
989         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
990             continue;
991         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
992             continue;
993
994         if (hv == PL_strtab) {
995             if (k_flags & HVhek_FREEKEY)
996                 Safefree(key);
997             Perl_croak(aTHX_ S_strtab_error, "delete");
998         }
999
1000         /* if placeholder is here, it's already been deleted.... */
1001         if (HeVAL(entry) == &PL_sv_placeholder) {
1002             if (k_flags & HVhek_FREEKEY)
1003                 Safefree(key);
1004             return NULL;
1005         }
1006         if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))
1007          && !SvIsCOW(HeVAL(entry))) {
1008             hv_notallowed(k_flags, key, klen,
1009                             "Attempt to delete readonly key '%"SVf"' from"
1010                             " a restricted hash");
1011         }
1012         if (k_flags & HVhek_FREEKEY)
1013             Safefree(key);
1014
1015         /* If this is a stash and the key ends with ::, then someone is 
1016          * deleting a package.
1017          */
1018         if (HeVAL(entry) && HvENAME_get(hv)) {
1019                 gv = (GV *)HeVAL(entry);
1020                 if (keysv) key = SvPV(keysv, klen);
1021                 if ((
1022                      (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
1023                       ||
1024                      (klen == 1 && key[0] == ':')
1025                     )
1026                  && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
1027                  && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
1028                  && HvENAME_get(stash)) {
1029                         /* A previous version of this code checked that the
1030                          * GV was still in the symbol table by fetching the
1031                          * GV with its name. That is not necessary (and
1032                          * sometimes incorrect), as HvENAME cannot be set
1033                          * on hv if it is not in the symtab. */
1034                         mro_changes = 2;
1035                         /* Hang on to it for a bit. */
1036                         SvREFCNT_inc_simple_void_NN(
1037                          sv_2mortal((SV *)gv)
1038                         );
1039                 }
1040                 else if (klen == 3 && strnEQ(key, "ISA", 3))
1041                     mro_changes = 1;
1042         }
1043
1044         if (d_flags & G_DISCARD) {
1045             sv = HeVAL(entry);
1046             HeVAL(entry) = &PL_sv_placeholder;
1047             if (sv) {
1048                 /* deletion of method from stash */
1049                 if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
1050                  && HvENAME_get(hv))
1051                     mro_method_changed_in(hv);
1052                 SvREFCNT_dec(sv);
1053                 sv = NULL;
1054             }
1055         }
1056         else {
1057             sv = sv_2mortal(HeVAL(entry));
1058             HeVAL(entry) = &PL_sv_placeholder;
1059         }
1060
1061         /*
1062          * If a restricted hash, rather than really deleting the entry, put
1063          * a placeholder there. This marks the key as being "approved", so
1064          * we can still access via not-really-existing key without raising
1065          * an error.
1066          */
1067         if (SvREADONLY(hv))
1068             /* We'll be saving this slot, so the number of allocated keys
1069              * doesn't go down, but the number placeholders goes up */
1070             HvPLACEHOLDERS(hv)++;
1071         else {
1072             *oentry = HeNEXT(entry);
1073             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1074                 HvLAZYDEL_on(hv);
1075             else {
1076                 if (SvOOK(hv) && HvLAZYDEL(hv) &&
1077                     entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1078                     HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1079                 hv_free_ent(hv, entry);
1080             }
1081             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1082             if (xhv->xhv_keys == 0)
1083                 HvHASKFLAGS_off(hv);
1084         }
1085
1086         if (mro_changes == 1) mro_isa_changed_in(hv);
1087         else if (mro_changes == 2)
1088             mro_package_moved(NULL, stash, gv, 1);
1089
1090         return sv;
1091     }
1092     if (SvREADONLY(hv)) {
1093         hv_notallowed(k_flags, key, klen,
1094                         "Attempt to delete disallowed key '%"SVf"' from"
1095                         " a restricted hash");
1096     }
1097
1098     if (k_flags & HVhek_FREEKEY)
1099         Safefree(key);
1100     return NULL;
1101 }
1102
1103 STATIC void
1104 S_hsplit(pTHX_ HV *hv)
1105 {
1106     dVAR;
1107     register XPVHV* const xhv = (XPVHV*)SvANY(hv);
1108     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1109     register I32 newsize = oldsize * 2;
1110     register I32 i;
1111     char *a = (char*) HvARRAY(hv);
1112     register HE **aep;
1113     int longest_chain = 0;
1114     int was_shared;
1115
1116     PERL_ARGS_ASSERT_HSPLIT;
1117
1118     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1119       (void*)hv, (int) oldsize);*/
1120
1121     if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1122       /* Can make this clear any placeholders first for non-restricted hashes,
1123          even though Storable rebuilds restricted hashes by putting in all the
1124          placeholders (first) before turning on the readonly flag, because
1125          Storable always pre-splits the hash.  */
1126       hv_clear_placeholders(hv);
1127     }
1128                
1129     PL_nomemok = TRUE;
1130 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1131     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1132           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1133     if (!a) {
1134       PL_nomemok = FALSE;
1135       return;
1136     }
1137     if (SvOOK(hv)) {
1138         Move(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1139     }
1140 #else
1141     Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1142         + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1143     if (!a) {
1144       PL_nomemok = FALSE;
1145       return;
1146     }
1147     Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1148     if (SvOOK(hv)) {
1149         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1150     }
1151     Safefree(HvARRAY(hv));
1152 #endif
1153
1154     PL_nomemok = FALSE;
1155     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1156     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1157     HvARRAY(hv) = (HE**) a;
1158     aep = (HE**)a;
1159
1160     for (i=0; i<oldsize; i++,aep++) {
1161         int left_length = 0;
1162         int right_length = 0;
1163         HE **oentry = aep;
1164         HE *entry = *aep;
1165         register HE **bep;
1166
1167         if (!entry)                             /* non-existent */
1168             continue;
1169         bep = aep+oldsize;
1170         do {
1171             if ((HeHASH(entry) & newsize) != (U32)i) {
1172                 *oentry = HeNEXT(entry);
1173                 HeNEXT(entry) = *bep;
1174                 *bep = entry;
1175                 right_length++;
1176             }
1177             else {
1178                 oentry = &HeNEXT(entry);
1179                 left_length++;
1180             }
1181             entry = *oentry;
1182         } while (entry);
1183         /* I think we don't actually need to keep track of the longest length,
1184            merely flag if anything is too long. But for the moment while
1185            developing this code I'll track it.  */
1186         if (left_length > longest_chain)
1187             longest_chain = left_length;
1188         if (right_length > longest_chain)
1189             longest_chain = right_length;
1190     }
1191
1192
1193     /* Pick your policy for "hashing isn't working" here:  */
1194     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1195         || HvREHASH(hv)) {
1196         return;
1197     }
1198
1199     if (hv == PL_strtab) {
1200         /* Urg. Someone is doing something nasty to the string table.
1201            Can't win.  */
1202         return;
1203     }
1204
1205     /* Awooga. Awooga. Pathological data.  */
1206     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
1207       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1208
1209     ++newsize;
1210     Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1211          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1212     if (SvOOK(hv)) {
1213         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1214     }
1215
1216     was_shared = HvSHAREKEYS(hv);
1217
1218     HvSHAREKEYS_off(hv);
1219     HvREHASH_on(hv);
1220
1221     aep = HvARRAY(hv);
1222
1223     for (i=0; i<newsize; i++,aep++) {
1224         register HE *entry = *aep;
1225         while (entry) {
1226             /* We're going to trash this HE's next pointer when we chain it
1227                into the new hash below, so store where we go next.  */
1228             HE * const next = HeNEXT(entry);
1229             UV hash;
1230             HE **bep;
1231
1232             /* Rehash it */
1233             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1234
1235             if (was_shared) {
1236                 /* Unshare it.  */
1237                 HEK * const new_hek
1238                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1239                                      hash, HeKFLAGS(entry));
1240                 unshare_hek (HeKEY_hek(entry));
1241                 HeKEY_hek(entry) = new_hek;
1242             } else {
1243                 /* Not shared, so simply write the new hash in. */
1244                 HeHASH(entry) = hash;
1245             }
1246             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1247             HEK_REHASH_on(HeKEY_hek(entry));
1248             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1249
1250             /* Copy oentry to the correct new chain.  */
1251             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1252             HeNEXT(entry) = *bep;
1253             *bep = entry;
1254
1255             entry = next;
1256         }
1257     }
1258     Safefree (HvARRAY(hv));
1259     HvARRAY(hv) = (HE **)a;
1260 }
1261
1262 void
1263 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1264 {
1265     dVAR;
1266     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1267     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1268     register I32 newsize;
1269     register I32 i;
1270     register char *a;
1271     register HE **aep;
1272
1273     PERL_ARGS_ASSERT_HV_KSPLIT;
1274
1275     newsize = (I32) newmax;                     /* possible truncation here */
1276     if (newsize != newmax || newmax <= oldsize)
1277         return;
1278     while ((newsize & (1 + ~newsize)) != newsize) {
1279         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1280     }
1281     if (newsize < newmax)
1282         newsize *= 2;
1283     if (newsize < newmax)
1284         return;                                 /* overflow detection */
1285
1286     a = (char *) HvARRAY(hv);
1287     if (a) {
1288         PL_nomemok = TRUE;
1289 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1290         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1291               + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1292         if (!a) {
1293           PL_nomemok = FALSE;
1294           return;
1295         }
1296         if (SvOOK(hv)) {
1297             Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1298         }
1299 #else
1300         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1301             + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1302         if (!a) {
1303           PL_nomemok = FALSE;
1304           return;
1305         }
1306         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1307         if (SvOOK(hv)) {
1308             Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1309         }
1310         Safefree(HvARRAY(hv));
1311 #endif
1312         PL_nomemok = FALSE;
1313         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1314     }
1315     else {
1316         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1317     }
1318     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1319     HvARRAY(hv) = (HE **) a;
1320     if (!xhv->xhv_keys /* !HvTOTALKEYS(hv) */)  /* skip rest if no entries */
1321         return;
1322
1323     aep = (HE**)a;
1324     for (i=0; i<oldsize; i++,aep++) {
1325         HE **oentry = aep;
1326         HE *entry = *aep;
1327
1328         if (!entry)                             /* non-existent */
1329             continue;
1330         do {
1331             register I32 j = (HeHASH(entry) & newsize);
1332
1333             if (j != i) {
1334                 j -= i;
1335                 *oentry = HeNEXT(entry);
1336                 HeNEXT(entry) = aep[j];
1337                 aep[j] = entry;
1338             }
1339             else
1340                 oentry = &HeNEXT(entry);
1341             entry = *oentry;
1342         } while (entry);
1343     }
1344 }
1345
1346 HV *
1347 Perl_newHVhv(pTHX_ HV *ohv)
1348 {
1349     dVAR;
1350     HV * const hv = newHV();
1351     STRLEN hv_max;
1352
1353     if (!ohv || !HvTOTALKEYS(ohv))
1354         return hv;
1355     hv_max = HvMAX(ohv);
1356
1357     if (!SvMAGICAL((const SV *)ohv)) {
1358         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1359         STRLEN i;
1360         const bool shared = !!HvSHAREKEYS(ohv);
1361         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1362         char *a;
1363         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1364         ents = (HE**)a;
1365
1366         /* In each bucket... */
1367         for (i = 0; i <= hv_max; i++) {
1368             HE *prev = NULL;
1369             HE *oent = oents[i];
1370
1371             if (!oent) {
1372                 ents[i] = NULL;
1373                 continue;
1374             }
1375
1376             /* Copy the linked list of entries. */
1377             for (; oent; oent = HeNEXT(oent)) {
1378                 const U32 hash   = HeHASH(oent);
1379                 const char * const key = HeKEY(oent);
1380                 const STRLEN len = HeKLEN(oent);
1381                 const int flags  = HeKFLAGS(oent);
1382                 HE * const ent   = new_HE();
1383                 SV *const val    = HeVAL(oent);
1384
1385                 HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
1386                 HeKEY_hek(ent)
1387                     = shared ? share_hek_flags(key, len, hash, flags)
1388                              :  save_hek_flags(key, len, hash, flags);
1389                 if (prev)
1390                     HeNEXT(prev) = ent;
1391                 else
1392                     ents[i] = ent;
1393                 prev = ent;
1394                 HeNEXT(ent) = NULL;
1395             }
1396         }
1397
1398         HvMAX(hv)   = hv_max;
1399         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1400         HvARRAY(hv) = ents;
1401     } /* not magical */
1402     else {
1403         /* Iterate over ohv, copying keys and values one at a time. */
1404         HE *entry;
1405         const I32 riter = HvRITER_get(ohv);
1406         HE * const eiter = HvEITER_get(ohv);
1407         STRLEN hv_fill = HvFILL(ohv);
1408
1409         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1410         while (hv_max && hv_max + 1 >= hv_fill * 2)
1411             hv_max = hv_max / 2;
1412         HvMAX(hv) = hv_max;
1413
1414         hv_iterinit(ohv);
1415         while ((entry = hv_iternext_flags(ohv, 0))) {
1416             SV *const val = HeVAL(entry);
1417             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1418                                  SvIMMORTAL(val) ? val : newSVsv(val),
1419                                  HeHASH(entry), HeKFLAGS(entry));
1420         }
1421         HvRITER_set(ohv, riter);
1422         HvEITER_set(ohv, eiter);
1423     }
1424
1425     return hv;
1426 }
1427
1428 /*
1429 =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1430
1431 A specialised version of L</newHVhv> for copying C<%^H>.  I<ohv> must be
1432 a pointer to a hash (which may have C<%^H> magic, but should be generally
1433 non-magical), or C<NULL> (interpreted as an empty hash).  The content
1434 of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
1435 added to it.  A pointer to the new hash is returned.
1436
1437 =cut
1438 */
1439
1440 HV *
1441 Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1442 {
1443     HV * const hv = newHV();
1444
1445     if (ohv && HvTOTALKEYS(ohv)) {
1446         STRLEN hv_max = HvMAX(ohv);
1447         STRLEN hv_fill = HvFILL(ohv);
1448         HE *entry;
1449         const I32 riter = HvRITER_get(ohv);
1450         HE * const eiter = HvEITER_get(ohv);
1451
1452         while (hv_max && hv_max + 1 >= hv_fill * 2)
1453             hv_max = hv_max / 2;
1454         HvMAX(hv) = hv_max;
1455
1456         hv_iterinit(ohv);
1457         while ((entry = hv_iternext_flags(ohv, 0))) {
1458             SV *const sv = newSVsv(HeVAL(entry));
1459             SV *heksv = newSVhek(HeKEY_hek(entry));
1460             sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1461                      (char *)heksv, HEf_SVKEY);
1462             SvREFCNT_dec(heksv);
1463             (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1464                                  sv, HeHASH(entry), HeKFLAGS(entry));
1465         }
1466         HvRITER_set(ohv, riter);
1467         HvEITER_set(ohv, eiter);
1468     }
1469     hv_magic(hv, NULL, PERL_MAGIC_hints);
1470     return hv;
1471 }
1472
1473 /* like hv_free_ent, but returns the SV rather than freeing it */
1474 STATIC SV*
1475 S_hv_free_ent_ret(pTHX_ HV *hv, register HE *entry)
1476 {
1477     dVAR;
1478     SV *val;
1479
1480     PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1481
1482     if (!entry)
1483         return NULL;
1484     val = HeVAL(entry);
1485     if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvENAME(hv))
1486         mro_method_changed_in(hv);      /* deletion of method from stash */
1487     if (HeKLEN(entry) == HEf_SVKEY) {
1488         SvREFCNT_dec(HeKEY_sv(entry));
1489         Safefree(HeKEY_hek(entry));
1490     }
1491     else if (HvSHAREKEYS(hv))
1492         unshare_hek(HeKEY_hek(entry));
1493     else
1494         Safefree(HeKEY_hek(entry));
1495     del_HE(entry);
1496     return val;
1497 }
1498
1499
1500 void
1501 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1502 {
1503     dVAR;
1504     SV *val;
1505
1506     PERL_ARGS_ASSERT_HV_FREE_ENT;
1507
1508     if (!entry)
1509         return;
1510     val = hv_free_ent_ret(hv, entry);
1511     SvREFCNT_dec(val);
1512 }
1513
1514
1515 void
1516 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1517 {
1518     dVAR;
1519
1520     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1521
1522     if (!entry)
1523         return;
1524     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1525     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1526     if (HeKLEN(entry) == HEf_SVKEY) {
1527         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1528     }
1529     hv_free_ent(hv, entry);
1530 }
1531
1532 /*
1533 =for apidoc hv_clear
1534
1535 Frees the all the elements of a hash, leaving it empty.
1536 The XS equivalent of %hash = (). See also L</hv_undef>.
1537
1538 =cut
1539 */
1540
1541 void
1542 Perl_hv_clear(pTHX_ HV *hv)
1543 {
1544     dVAR;
1545     register XPVHV* xhv;
1546     if (!hv)
1547         return;
1548
1549     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1550
1551     xhv = (XPVHV*)SvANY(hv);
1552
1553     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1554         /* restricted hash: convert all keys to placeholders */
1555         STRLEN i;
1556         for (i = 0; i <= xhv->xhv_max; i++) {
1557             HE *entry = (HvARRAY(hv))[i];
1558             for (; entry; entry = HeNEXT(entry)) {
1559                 /* not already placeholder */
1560                 if (HeVAL(entry) != &PL_sv_placeholder) {
1561                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))
1562                      && !SvIsCOW(HeVAL(entry))) {
1563                         SV* const keysv = hv_iterkeysv(entry);
1564                         Perl_croak(aTHX_
1565                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1566                                    (void*)keysv);
1567                     }
1568                     SvREFCNT_dec(HeVAL(entry));
1569                     HeVAL(entry) = &PL_sv_placeholder;
1570                     HvPLACEHOLDERS(hv)++;
1571                 }
1572             }
1573         }
1574     }
1575     else {
1576         hfreeentries(hv);
1577         HvPLACEHOLDERS_set(hv, 0);
1578
1579         if (SvRMAGICAL(hv))
1580             mg_clear(MUTABLE_SV(hv));
1581
1582         HvHASKFLAGS_off(hv);
1583         HvREHASH_off(hv);
1584     }
1585     if (SvOOK(hv)) {
1586         if(HvENAME_get(hv))
1587             mro_isa_changed_in(hv);
1588         HvEITER_set(hv, NULL);
1589     }
1590 }
1591
1592 /*
1593 =for apidoc hv_clear_placeholders
1594
1595 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1596 marked as readonly and the key is subsequently deleted, the key is not actually
1597 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1598 it so it will be ignored by future operations such as iterating over the hash,
1599 but will still allow the hash to have a value reassigned to the key at some
1600 future point.  This function clears any such placeholder keys from the hash.
1601 See Hash::Util::lock_keys() for an example of its use.
1602
1603 =cut
1604 */
1605
1606 void
1607 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1608 {
1609     dVAR;
1610     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1611
1612     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1613
1614     if (items)
1615         clear_placeholders(hv, items);
1616 }
1617
1618 static void
1619 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1620 {
1621     dVAR;
1622     I32 i;
1623
1624     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1625
1626     if (items == 0)
1627         return;
1628
1629     i = HvMAX(hv);
1630     do {
1631         /* Loop down the linked list heads  */
1632         HE **oentry = &(HvARRAY(hv))[i];
1633         HE *entry;
1634
1635         while ((entry = *oentry)) {
1636             if (HeVAL(entry) == &PL_sv_placeholder) {
1637                 *oentry = HeNEXT(entry);
1638                 if (entry == HvEITER_get(hv))
1639                     HvLAZYDEL_on(hv);
1640                 else {
1641                     if (SvOOK(hv) && HvLAZYDEL(hv) &&
1642                         entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1643                         HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1644                     hv_free_ent(hv, entry);
1645                 }
1646
1647                 if (--items == 0) {
1648                     /* Finished.  */
1649                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1650                     if (HvUSEDKEYS(hv) == 0)
1651                         HvHASKFLAGS_off(hv);
1652                     HvPLACEHOLDERS_set(hv, 0);
1653                     return;
1654                 }
1655             } else {
1656                 oentry = &HeNEXT(entry);
1657             }
1658         }
1659     } while (--i >= 0);
1660     /* You can't get here, hence assertion should always fail.  */
1661     assert (items == 0);
1662     assert (0);
1663 }
1664
1665 STATIC void
1666 S_hfreeentries(pTHX_ HV *hv)
1667 {
1668     STRLEN index = 0;
1669     XPVHV * const xhv = (XPVHV*)SvANY(hv);
1670     SV *sv;
1671
1672     PERL_ARGS_ASSERT_HFREEENTRIES;
1673
1674     while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
1675         SvREFCNT_dec(sv);
1676     }
1677 }
1678
1679
1680 /* hfree_next_entry()
1681  * For use only by S_hfreeentries() and sv_clear().
1682  * Delete the next available HE from hv and return the associated SV.
1683  * Returns null on empty hash. Nevertheless null is not a reliable
1684  * indicator that the hash is empty, as the deleted entry may have a
1685  * null value.
1686  * indexp is a pointer to the current index into HvARRAY. The index should
1687  * initially be set to 0. hfree_next_entry() may update it.  */
1688
1689 SV*
1690 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1691 {
1692     struct xpvhv_aux *iter;
1693     HE *entry;
1694     HE ** array;
1695 #ifdef DEBUGGING
1696     STRLEN orig_index = *indexp;
1697 #endif
1698
1699     PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1700
1701     if (SvOOK(hv) && ((iter = HvAUX(hv)))
1702         && ((entry = iter->xhv_eiter)) )
1703     {
1704         /* the iterator may get resurrected after each
1705          * destructor call, so check each time */
1706         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1707             HvLAZYDEL_off(hv);
1708             hv_free_ent(hv, entry);
1709             /* warning: at this point HvARRAY may have been
1710              * re-allocated, HvMAX changed etc */
1711         }
1712         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1713         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1714     }
1715
1716     if (!((XPVHV*)SvANY(hv))->xhv_keys)
1717         return NULL;
1718
1719     array = HvARRAY(hv);
1720     assert(array);
1721     while ( ! ((entry = array[*indexp])) ) {
1722         if ((*indexp)++ >= HvMAX(hv))
1723             *indexp = 0;
1724         assert(*indexp != orig_index);
1725     }
1726     array[*indexp] = HeNEXT(entry);
1727     ((XPVHV*) SvANY(hv))->xhv_keys--;
1728
1729     if (   PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
1730         && HeVAL(entry) && isGV(HeVAL(entry))
1731         && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
1732     ) {
1733         STRLEN klen;
1734         const char * const key = HePV(entry,klen);
1735         if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
1736          || (klen == 1 && key[0] == ':')) {
1737             mro_package_moved(
1738              NULL, GvHV(HeVAL(entry)),
1739              (GV *)HeVAL(entry), 0
1740             );
1741         }
1742     }
1743     return hv_free_ent_ret(hv, entry);
1744 }
1745
1746
1747 /*
1748 =for apidoc hv_undef
1749
1750 Undefines the hash.  The XS equivalent of undef(%hash).
1751
1752 As well as freeing all the elements of the hash (like hv_clear()), this
1753 also frees any auxiliary data and storage associated with the hash.
1754 See also L</hv_clear>.
1755
1756 =cut
1757 */
1758
1759 void
1760 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1761 {
1762     dVAR;
1763     register XPVHV* xhv;
1764     const char *name;
1765
1766     if (!hv)
1767         return;
1768     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1769     xhv = (XPVHV*)SvANY(hv);
1770
1771     /* The name must be deleted before the call to hfreeeeentries so that
1772        CVs are anonymised properly. But the effective name must be pre-
1773        served until after that call (and only deleted afterwards if the
1774        call originated from sv_clear). For stashes with one name that is
1775        both the canonical name and the effective name, hv_name_set has to
1776        allocate an array for storing the effective name. We can skip that
1777        during global destruction, as it does not matter where the CVs point
1778        if they will be freed anyway. */
1779     /* note that the code following prior to hfreeentries is duplicated
1780      * in sv_clear(), and changes here should be done there too */
1781     if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
1782         if (PL_stashcache)
1783             (void)hv_delete(PL_stashcache, name,
1784                             HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
1785                             G_DISCARD
1786                            );
1787         hv_name_set(hv, NULL, 0, 0);
1788     }
1789     hfreeentries(hv);
1790     if (SvOOK(hv)) {
1791       struct xpvhv_aux * const aux = HvAUX(hv);
1792       struct mro_meta *meta;
1793
1794       if ((name = HvENAME_get(hv))) {
1795         if (PL_phase != PERL_PHASE_DESTRUCT)
1796             mro_isa_changed_in(hv);
1797         if (PL_stashcache)
1798             (void)hv_delete(
1799                     PL_stashcache, name,
1800                     HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
1801                     G_DISCARD
1802                   );
1803       }
1804
1805       /* If this call originated from sv_clear, then we must check for
1806        * effective names that need freeing, as well as the usual name. */
1807       name = HvNAME(hv);
1808       if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
1809         if (name && PL_stashcache)
1810             (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
1811         hv_name_set(hv, NULL, 0, flags);
1812       }
1813       if((meta = aux->xhv_mro_meta)) {
1814         if (meta->mro_linear_all) {
1815             SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
1816             meta->mro_linear_all = NULL;
1817             /* This is just acting as a shortcut pointer.  */
1818             meta->mro_linear_current = NULL;
1819         } else if (meta->mro_linear_current) {
1820             /* Only the current MRO is stored, so this owns the data.
1821              */
1822             SvREFCNT_dec(meta->mro_linear_current);
1823             meta->mro_linear_current = NULL;
1824         }
1825         SvREFCNT_dec(meta->mro_nextmethod);
1826         SvREFCNT_dec(meta->isa);
1827         Safefree(meta);
1828         aux->xhv_mro_meta = NULL;
1829       }
1830       if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
1831         SvFLAGS(hv) &= ~SVf_OOK;
1832     }
1833     if (!SvOOK(hv)) {
1834         Safefree(HvARRAY(hv));
1835         xhv->xhv_max   = 7;     /* HvMAX(hv) = 7 (it's a normal hash) */
1836         HvARRAY(hv) = 0;
1837     }
1838     HvPLACEHOLDERS_set(hv, 0);
1839
1840     if (SvRMAGICAL(hv))
1841         mg_clear(MUTABLE_SV(hv));
1842 }
1843
1844 /*
1845 =for apidoc hv_fill
1846
1847 Returns the number of hash buckets that happen to be in use. This function is
1848 wrapped by the macro C<HvFILL>.
1849
1850 Previously this value was stored in the HV structure, rather than being
1851 calculated on demand.
1852
1853 =cut
1854 */
1855
1856 STRLEN
1857 Perl_hv_fill(pTHX_ HV const *const hv)
1858 {
1859     STRLEN count = 0;
1860     HE **ents = HvARRAY(hv);
1861
1862     PERL_ARGS_ASSERT_HV_FILL;
1863
1864     if (ents) {
1865         HE *const *const last = ents + HvMAX(hv);
1866         count = last + 1 - ents;
1867
1868         do {
1869             if (!*ents)
1870                 --count;
1871         } while (++ents <= last);
1872     }
1873     return count;
1874 }
1875
1876 static struct xpvhv_aux*
1877 S_hv_auxinit(HV *hv) {
1878     struct xpvhv_aux *iter;
1879     char *array;
1880
1881     PERL_ARGS_ASSERT_HV_AUXINIT;
1882
1883     if (!HvARRAY(hv)) {
1884         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1885             + sizeof(struct xpvhv_aux), char);
1886     } else {
1887         array = (char *) HvARRAY(hv);
1888         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1889               + sizeof(struct xpvhv_aux), char);
1890     }
1891     HvARRAY(hv) = (HE**) array;
1892     /* SvOOK_on(hv) attacks the IV flags.  */
1893     SvFLAGS(hv) |= SVf_OOK;
1894     iter = HvAUX(hv);
1895
1896     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1897     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1898     iter->xhv_name_u.xhvnameu_name = 0;
1899     iter->xhv_name_count = 0;
1900     iter->xhv_backreferences = 0;
1901     iter->xhv_mro_meta = NULL;
1902     return iter;
1903 }
1904
1905 /*
1906 =for apidoc hv_iterinit
1907
1908 Prepares a starting point to traverse a hash table.  Returns the number of
1909 keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>).  The return value is
1910 currently only meaningful for hashes without tie magic.
1911
1912 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1913 hash buckets that happen to be in use.  If you still need that esoteric
1914 value, you can get it through the macro C<HvFILL(hv)>.
1915
1916
1917 =cut
1918 */
1919
1920 I32
1921 Perl_hv_iterinit(pTHX_ HV *hv)
1922 {
1923     PERL_ARGS_ASSERT_HV_ITERINIT;
1924
1925     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1926
1927     if (!hv)
1928         Perl_croak(aTHX_ "Bad hash");
1929
1930     if (SvOOK(hv)) {
1931         struct xpvhv_aux * const iter = HvAUX(hv);
1932         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1933         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1934             HvLAZYDEL_off(hv);
1935             hv_free_ent(hv, entry);
1936         }
1937         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1938         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1939     } else {
1940         hv_auxinit(hv);
1941     }
1942
1943     /* used to be xhv->xhv_fill before 5.004_65 */
1944     return HvTOTALKEYS(hv);
1945 }
1946
1947 I32 *
1948 Perl_hv_riter_p(pTHX_ HV *hv) {
1949     struct xpvhv_aux *iter;
1950
1951     PERL_ARGS_ASSERT_HV_RITER_P;
1952
1953     if (!hv)
1954         Perl_croak(aTHX_ "Bad hash");
1955
1956     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1957     return &(iter->xhv_riter);
1958 }
1959
1960 HE **
1961 Perl_hv_eiter_p(pTHX_ HV *hv) {
1962     struct xpvhv_aux *iter;
1963
1964     PERL_ARGS_ASSERT_HV_EITER_P;
1965
1966     if (!hv)
1967         Perl_croak(aTHX_ "Bad hash");
1968
1969     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1970     return &(iter->xhv_eiter);
1971 }
1972
1973 void
1974 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1975     struct xpvhv_aux *iter;
1976
1977     PERL_ARGS_ASSERT_HV_RITER_SET;
1978
1979     if (!hv)
1980         Perl_croak(aTHX_ "Bad hash");
1981
1982     if (SvOOK(hv)) {
1983         iter = HvAUX(hv);
1984     } else {
1985         if (riter == -1)
1986             return;
1987
1988         iter = hv_auxinit(hv);
1989     }
1990     iter->xhv_riter = riter;
1991 }
1992
1993 void
1994 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1995     struct xpvhv_aux *iter;
1996
1997     PERL_ARGS_ASSERT_HV_EITER_SET;
1998
1999     if (!hv)
2000         Perl_croak(aTHX_ "Bad hash");
2001
2002     if (SvOOK(hv)) {
2003         iter = HvAUX(hv);
2004     } else {
2005         /* 0 is the default so don't go malloc()ing a new structure just to
2006            hold 0.  */
2007         if (!eiter)
2008             return;
2009
2010         iter = hv_auxinit(hv);
2011     }
2012     iter->xhv_eiter = eiter;
2013 }
2014
2015 void
2016 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2017 {
2018     dVAR;
2019     struct xpvhv_aux *iter;
2020     U32 hash;
2021     HEK **spot;
2022
2023     PERL_ARGS_ASSERT_HV_NAME_SET;
2024
2025     if (len > I32_MAX)
2026         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2027
2028     if (SvOOK(hv)) {
2029         iter = HvAUX(hv);
2030         if (iter->xhv_name_u.xhvnameu_name) {
2031             if(iter->xhv_name_count) {
2032               if(flags & HV_NAME_SETALL) {
2033                 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2034                 HEK **hekp = name + (
2035                     iter->xhv_name_count < 0
2036                      ? -iter->xhv_name_count
2037                      :  iter->xhv_name_count
2038                    );
2039                 while(hekp-- > name+1) 
2040                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2041                 /* The first elem may be null. */
2042                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2043                 Safefree(name);
2044                 spot = &iter->xhv_name_u.xhvnameu_name;
2045                 iter->xhv_name_count = 0;
2046               }
2047               else {
2048                 if(iter->xhv_name_count > 0) {
2049                     /* shift some things over */
2050                     Renew(
2051                      iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2052                     );
2053                     spot = iter->xhv_name_u.xhvnameu_names;
2054                     spot[iter->xhv_name_count] = spot[1];
2055                     spot[1] = spot[0];
2056                     iter->xhv_name_count = -(iter->xhv_name_count + 1);
2057                 }
2058                 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2059                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2060                 }
2061               }
2062             }
2063             else if (flags & HV_NAME_SETALL) {
2064                 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2065                 spot = &iter->xhv_name_u.xhvnameu_name;
2066             }
2067             else {
2068                 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2069                 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2070                 iter->xhv_name_count = -2;
2071                 spot = iter->xhv_name_u.xhvnameu_names;
2072                 spot[1] = existing_name;
2073             }
2074         }
2075         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2076     } else {
2077         if (name == 0)
2078             return;
2079
2080         iter = hv_auxinit(hv);
2081         spot = &iter->xhv_name_u.xhvnameu_name;
2082     }
2083     PERL_HASH(hash, name, len);
2084     *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2085 }
2086
2087 /*
2088 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2089 and bytes checking.
2090 */
2091
2092 STATIC I32
2093 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2094     if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2095         if (flags & SVf_UTF8)
2096             return (bytes_cmp_utf8(
2097                         (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2098                         (const U8*)pv, pvlen) == 0);
2099         else
2100             return (bytes_cmp_utf8(
2101                         (const U8*)pv, pvlen,
2102                         (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2103     }
2104     else
2105         return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2106                     || memEQ(HEK_KEY(hek), pv, pvlen));
2107 }
2108
2109 /*
2110 =for apidoc hv_ename_add
2111
2112 Adds a name to a stash's internal list of effective names. See
2113 C<hv_ename_delete>.
2114
2115 This is called when a stash is assigned to a new location in the symbol
2116 table.
2117
2118 =cut
2119 */
2120
2121 void
2122 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2123 {
2124     dVAR;
2125     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2126     U32 hash;
2127
2128     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2129
2130     if (len > I32_MAX)
2131         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2132
2133     PERL_HASH(hash, name, len);
2134
2135     if (aux->xhv_name_count) {
2136         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
2137         I32 count = aux->xhv_name_count;
2138         HEK **hekp = xhv_name + (count < 0 ? -count : count);
2139         while (hekp-- > xhv_name)
2140             if (
2141                  (HEK_UTF8(*hekp) || (flags & SVf_UTF8)) 
2142                     ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2143                     : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2144                ) {
2145                 if (hekp == xhv_name && count < 0)
2146                     aux->xhv_name_count = -count;
2147                 return;
2148             }
2149         if (count < 0) aux->xhv_name_count--, count = -count;
2150         else aux->xhv_name_count++;
2151         Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2152         (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2153     }
2154     else {
2155         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2156         if (
2157             existing_name && (
2158              (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2159                 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2160                 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2161             )
2162         ) return;
2163         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2164         aux->xhv_name_count = existing_name ? 2 : -2;
2165         *aux->xhv_name_u.xhvnameu_names = existing_name;
2166         (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2167     }
2168 }
2169
2170 /*
2171 =for apidoc hv_ename_delete
2172
2173 Removes a name from a stash's internal list of effective names. If this is
2174 the name returned by C<HvENAME>, then another name in the list will take
2175 its place (C<HvENAME> will use it).
2176
2177 This is called when a stash is deleted from the symbol table.
2178
2179 =cut
2180 */
2181
2182 void
2183 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2184 {
2185     dVAR;
2186     struct xpvhv_aux *aux;
2187
2188     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2189
2190     if (len > I32_MAX)
2191         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2192
2193     if (!SvOOK(hv)) return;
2194
2195     aux = HvAUX(hv);
2196     if (!aux->xhv_name_u.xhvnameu_name) return;
2197
2198     if (aux->xhv_name_count) {
2199         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2200         I32 const count = aux->xhv_name_count;
2201         HEK **victim = namep + (count < 0 ? -count : count);
2202         while (victim-- > namep + 1)
2203             if (
2204              (HEK_UTF8(*victim) || (flags & SVf_UTF8)) 
2205                 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2206                 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2207             ) {
2208                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2209                 if (count < 0) ++aux->xhv_name_count;
2210                 else --aux->xhv_name_count;
2211                 if (
2212                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2213                  && !*namep
2214                 ) {  /* if there are none left */
2215                     Safefree(namep);
2216                     aux->xhv_name_u.xhvnameu_names = NULL;
2217                     aux->xhv_name_count = 0;
2218                 }
2219                 else {
2220                     /* Move the last one back to fill the empty slot. It
2221                        does not matter what order they are in. */
2222                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2223                 }
2224                 return;
2225             }
2226         if (
2227             count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8)) 
2228                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2229                 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2230         ) {
2231             aux->xhv_name_count = -count;
2232         }
2233     }
2234     else if(
2235         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) 
2236                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2237                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2238                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2239     ) {
2240         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2241         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2242         *aux->xhv_name_u.xhvnameu_names = namehek;
2243         aux->xhv_name_count = -1;
2244     }
2245 }
2246
2247 AV **
2248 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2249     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2250
2251     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2252     PERL_UNUSED_CONTEXT;
2253
2254     return &(iter->xhv_backreferences);
2255 }
2256
2257 void
2258 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2259     AV *av;
2260
2261     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2262
2263     if (!SvOOK(hv))
2264         return;
2265
2266     av = HvAUX(hv)->xhv_backreferences;
2267
2268     if (av) {
2269         HvAUX(hv)->xhv_backreferences = 0;
2270         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2271         if (SvTYPE(av) == SVt_PVAV)
2272             SvREFCNT_dec(av);
2273     }
2274 }
2275
2276 /*
2277 hv_iternext is implemented as a macro in hv.h
2278
2279 =for apidoc hv_iternext
2280
2281 Returns entries from a hash iterator.  See C<hv_iterinit>.
2282
2283 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2284 iterator currently points to, without losing your place or invalidating your
2285 iterator.  Note that in this case the current entry is deleted from the hash
2286 with your iterator holding the last reference to it.  Your iterator is flagged
2287 to free the entry on the next call to C<hv_iternext>, so you must not discard
2288 your iterator immediately else the entry will leak - call C<hv_iternext> to
2289 trigger the resource deallocation.
2290
2291 =for apidoc hv_iternext_flags
2292
2293 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2294 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2295 set the placeholders keys (for restricted hashes) will be returned in addition
2296 to normal keys. By default placeholders are automatically skipped over.
2297 Currently a placeholder is implemented with a value that is
2298 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2299 restricted hashes may change, and the implementation currently is
2300 insufficiently abstracted for any change to be tidy.
2301
2302 =cut
2303 */
2304
2305 HE *
2306 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2307 {
2308     dVAR;
2309     register XPVHV* xhv;
2310     register HE *entry;
2311     HE *oldentry;
2312     MAGIC* mg;
2313     struct xpvhv_aux *iter;
2314
2315     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2316
2317     if (!hv)
2318         Perl_croak(aTHX_ "Bad hash");
2319
2320     xhv = (XPVHV*)SvANY(hv);
2321
2322     if (!SvOOK(hv)) {
2323         /* Too many things (well, pp_each at least) merrily assume that you can
2324            call iv_iternext without calling hv_iterinit, so we'll have to deal
2325            with it.  */
2326         hv_iterinit(hv);
2327     }
2328     iter = HvAUX(hv);
2329
2330     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2331     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2332         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2333             SV * const key = sv_newmortal();
2334             if (entry) {
2335                 sv_setsv(key, HeSVKEY_force(entry));
2336                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2337             }
2338             else {
2339                 char *k;
2340                 HEK *hek;
2341
2342                 /* one HE per MAGICAL hash */
2343                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2344                 Zero(entry, 1, HE);
2345                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2346                 hek = (HEK*)k;
2347                 HeKEY_hek(entry) = hek;
2348                 HeKLEN(entry) = HEf_SVKEY;
2349             }
2350             magic_nextpack(MUTABLE_SV(hv),mg,key);
2351             if (SvOK(key)) {
2352                 /* force key to stay around until next time */
2353                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2354                 return entry;               /* beware, hent_val is not set */
2355             }
2356             SvREFCNT_dec(HeVAL(entry));
2357             Safefree(HeKEY_hek(entry));
2358             del_HE(entry);
2359             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2360             return NULL;
2361         }
2362     }
2363 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2364     if (!entry && SvRMAGICAL((const SV *)hv)
2365         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2366         prime_env_iter();
2367 #ifdef VMS
2368         /* The prime_env_iter() on VMS just loaded up new hash values
2369          * so the iteration count needs to be reset back to the beginning
2370          */
2371         hv_iterinit(hv);
2372         iter = HvAUX(hv);
2373         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2374 #endif
2375     }
2376 #endif
2377
2378     /* hv_iterint now ensures this.  */
2379     assert (HvARRAY(hv));
2380
2381     /* At start of hash, entry is NULL.  */
2382     if (entry)
2383     {
2384         entry = HeNEXT(entry);
2385         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2386             /*
2387              * Skip past any placeholders -- don't want to include them in
2388              * any iteration.
2389              */
2390             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2391                 entry = HeNEXT(entry);
2392             }
2393         }
2394     }
2395
2396     /* Skip the entire loop if the hash is empty.   */
2397     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2398         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2399         while (!entry) {
2400             /* OK. Come to the end of the current list.  Grab the next one.  */
2401
2402             iter->xhv_riter++; /* HvRITER(hv)++ */
2403             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2404                 /* There is no next one.  End of the hash.  */
2405                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2406                 break;
2407             }
2408             entry = (HvARRAY(hv))[iter->xhv_riter];
2409
2410             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2411                 /* If we have an entry, but it's a placeholder, don't count it.
2412                    Try the next.  */
2413                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2414                     entry = HeNEXT(entry);
2415             }
2416             /* Will loop again if this linked list starts NULL
2417                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2418                or if we run through it and find only placeholders.  */
2419         }
2420     }
2421
2422     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2423         HvLAZYDEL_off(hv);
2424         hv_free_ent(hv, oldentry);
2425     }
2426
2427     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2428       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2429
2430     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2431     return entry;
2432 }
2433
2434 /*
2435 =for apidoc hv_iterkey
2436
2437 Returns the key from the current position of the hash iterator.  See
2438 C<hv_iterinit>.
2439
2440 =cut
2441 */
2442
2443 char *
2444 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2445 {
2446     PERL_ARGS_ASSERT_HV_ITERKEY;
2447
2448     if (HeKLEN(entry) == HEf_SVKEY) {
2449         STRLEN len;
2450         char * const p = SvPV(HeKEY_sv(entry), len);
2451         *retlen = len;
2452         return p;
2453     }
2454     else {
2455         *retlen = HeKLEN(entry);
2456         return HeKEY(entry);
2457     }
2458 }
2459
2460 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2461 /*
2462 =for apidoc hv_iterkeysv
2463
2464 Returns the key as an C<SV*> from the current position of the hash
2465 iterator.  The return value will always be a mortal copy of the key.  Also
2466 see C<hv_iterinit>.
2467
2468 =cut
2469 */
2470
2471 SV *
2472 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2473 {
2474     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2475
2476     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2477 }
2478
2479 /*
2480 =for apidoc hv_iterval
2481
2482 Returns the value from the current position of the hash iterator.  See
2483 C<hv_iterkey>.
2484
2485 =cut
2486 */
2487
2488 SV *
2489 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2490 {
2491     PERL_ARGS_ASSERT_HV_ITERVAL;
2492
2493     if (SvRMAGICAL(hv)) {
2494         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2495             SV* const sv = sv_newmortal();
2496             if (HeKLEN(entry) == HEf_SVKEY)
2497                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2498             else
2499                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2500             return sv;
2501         }
2502     }
2503     return HeVAL(entry);
2504 }
2505
2506 /*
2507 =for apidoc hv_iternextsv
2508
2509 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2510 operation.
2511
2512 =cut
2513 */
2514
2515 SV *
2516 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2517 {
2518     HE * const he = hv_iternext_flags(hv, 0);
2519
2520     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2521
2522     if (!he)
2523         return NULL;
2524     *key = hv_iterkey(he, retlen);
2525     return hv_iterval(hv, he);
2526 }
2527
2528 /*
2529
2530 Now a macro in hv.h
2531
2532 =for apidoc hv_magic
2533
2534 Adds magic to a hash.  See C<sv_magic>.
2535
2536 =cut
2537 */
2538
2539 /* possibly free a shared string if no one has access to it
2540  * len and hash must both be valid for str.
2541  */
2542 void
2543 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2544 {
2545     unshare_hek_or_pvn (NULL, str, len, hash);
2546 }
2547
2548
2549 void
2550 Perl_unshare_hek(pTHX_ HEK *hek)
2551 {
2552     assert(hek);
2553     unshare_hek_or_pvn(hek, NULL, 0, 0);
2554 }
2555
2556 /* possibly free a shared string if no one has access to it
2557    hek if non-NULL takes priority over the other 3, else str, len and hash
2558    are used.  If so, len and hash must both be valid for str.
2559  */
2560 STATIC void
2561 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2562 {
2563     dVAR;
2564     register XPVHV* xhv;
2565     HE *entry;
2566     register HE **oentry;
2567     bool is_utf8 = FALSE;
2568     int k_flags = 0;
2569     const char * const save = str;
2570     struct shared_he *he = NULL;
2571
2572     if (hek) {
2573         /* Find the shared he which is just before us in memory.  */
2574         he = (struct shared_he *)(((char *)hek)
2575                                   - STRUCT_OFFSET(struct shared_he,
2576                                                   shared_he_hek));
2577
2578         /* Assert that the caller passed us a genuine (or at least consistent)
2579            shared hek  */
2580         assert (he->shared_he_he.hent_hek == hek);
2581
2582         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2583             --he->shared_he_he.he_valu.hent_refcount;
2584             return;
2585         }
2586
2587         hash = HEK_HASH(hek);
2588     } else if (len < 0) {
2589         STRLEN tmplen = -len;
2590         is_utf8 = TRUE;
2591         /* See the note in hv_fetch(). --jhi */
2592         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2593         len = tmplen;
2594         if (is_utf8)
2595             k_flags = HVhek_UTF8;
2596         if (str != save)
2597             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2598     }
2599
2600     /* what follows was the moral equivalent of:
2601     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2602         if (--*Svp == NULL)
2603             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2604     } */
2605     xhv = (XPVHV*)SvANY(PL_strtab);
2606     /* assert(xhv_array != 0) */
2607     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2608     if (he) {
2609         const HE *const he_he = &(he->shared_he_he);
2610         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2611             if (entry == he_he)
2612                 break;
2613         }
2614     } else {
2615         const int flags_masked = k_flags & HVhek_MASK;
2616         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2617             if (HeHASH(entry) != hash)          /* strings can't be equal */
2618                 continue;
2619             if (HeKLEN(entry) != len)
2620                 continue;
2621             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2622                 continue;
2623             if (HeKFLAGS(entry) != flags_masked)
2624                 continue;
2625             break;
2626         }
2627     }
2628
2629     if (entry) {
2630         if (--entry->he_valu.hent_refcount == 0) {
2631             *oentry = HeNEXT(entry);
2632             Safefree(entry);
2633             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2634         }
2635     }
2636
2637     if (!entry)
2638         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2639                          "Attempt to free non-existent shared string '%s'%s"
2640                          pTHX__FORMAT,
2641                          hek ? HEK_KEY(hek) : str,
2642                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2643     if (k_flags & HVhek_FREEKEY)
2644         Safefree(str);
2645 }
2646
2647 /* get a (constant) string ptr from the global string table
2648  * string will get added if it is not already there.
2649  * len and hash must both be valid for str.
2650  */
2651 HEK *
2652 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2653 {
2654     bool is_utf8 = FALSE;
2655     int flags = 0;
2656     const char * const save = str;
2657
2658     PERL_ARGS_ASSERT_SHARE_HEK;
2659
2660     if (len < 0) {
2661       STRLEN tmplen = -len;
2662       is_utf8 = TRUE;
2663       /* See the note in hv_fetch(). --jhi */
2664       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2665       len = tmplen;
2666       /* If we were able to downgrade here, then than means that we were passed
2667          in a key which only had chars 0-255, but was utf8 encoded.  */
2668       if (is_utf8)
2669           flags = HVhek_UTF8;
2670       /* If we found we were able to downgrade the string to bytes, then
2671          we should flag that it needs upgrading on keys or each.  Also flag
2672          that we need share_hek_flags to free the string.  */
2673       if (str != save) {
2674           PERL_HASH(hash, str, len);
2675           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2676       }
2677     }
2678
2679     return share_hek_flags (str, len, hash, flags);
2680 }
2681
2682 STATIC HEK *
2683 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2684 {
2685     dVAR;
2686     register HE *entry;
2687     const int flags_masked = flags & HVhek_MASK;
2688     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2689     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2690
2691     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2692
2693     /* what follows is the moral equivalent of:
2694
2695     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2696         hv_store(PL_strtab, str, len, NULL, hash);
2697
2698         Can't rehash the shared string table, so not sure if it's worth
2699         counting the number of entries in the linked list
2700     */
2701
2702     /* assert(xhv_array != 0) */
2703     entry = (HvARRAY(PL_strtab))[hindex];
2704     for (;entry; entry = HeNEXT(entry)) {
2705         if (HeHASH(entry) != hash)              /* strings can't be equal */
2706             continue;
2707         if (HeKLEN(entry) != len)
2708             continue;
2709         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2710             continue;
2711         if (HeKFLAGS(entry) != flags_masked)
2712             continue;
2713         break;
2714     }
2715
2716     if (!entry) {
2717         /* What used to be head of the list.
2718            If this is NULL, then we're the first entry for this slot, which
2719            means we need to increate fill.  */
2720         struct shared_he *new_entry;
2721         HEK *hek;
2722         char *k;
2723         HE **const head = &HvARRAY(PL_strtab)[hindex];
2724         HE *const next = *head;
2725
2726         /* We don't actually store a HE from the arena and a regular HEK.
2727            Instead we allocate one chunk of memory big enough for both,
2728            and put the HEK straight after the HE. This way we can find the
2729            HEK directly from the HE.
2730         */
2731
2732         Newx(k, STRUCT_OFFSET(struct shared_he,
2733                                 shared_he_hek.hek_key[0]) + len + 2, char);
2734         new_entry = (struct shared_he *)k;
2735         entry = &(new_entry->shared_he_he);
2736         hek = &(new_entry->shared_he_hek);
2737
2738         Copy(str, HEK_KEY(hek), len, char);
2739         HEK_KEY(hek)[len] = 0;
2740         HEK_LEN(hek) = len;
2741         HEK_HASH(hek) = hash;
2742         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2743
2744         /* Still "point" to the HEK, so that other code need not know what
2745            we're up to.  */
2746         HeKEY_hek(entry) = hek;
2747         entry->he_valu.hent_refcount = 0;
2748         HeNEXT(entry) = next;
2749         *head = entry;
2750
2751         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2752         if (!next) {                    /* initial entry? */
2753         } else if (xhv->xhv_keys > xhv->xhv_max /* HvUSEDKEYS(hv) > HvMAX(hv) */) {
2754                 hsplit(PL_strtab);
2755         }
2756     }
2757
2758     ++entry->he_valu.hent_refcount;
2759
2760     if (flags & HVhek_FREEKEY)
2761         Safefree(str);
2762
2763     return HeKEY_hek(entry);
2764 }
2765
2766 I32 *
2767 Perl_hv_placeholders_p(pTHX_ HV *hv)
2768 {
2769     dVAR;
2770     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2771
2772     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2773
2774     if (!mg) {
2775         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2776
2777         if (!mg) {
2778             Perl_die(aTHX_ "panic: hv_placeholders_p");
2779         }
2780     }
2781     return &(mg->mg_len);
2782 }
2783
2784
2785 I32
2786 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2787 {
2788     dVAR;
2789     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2790
2791     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2792
2793     return mg ? mg->mg_len : 0;
2794 }
2795
2796 void
2797 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2798 {
2799     dVAR;
2800     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2801
2802     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2803
2804     if (mg) {
2805         mg->mg_len = ph;
2806     } else if (ph) {
2807         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2808             Perl_die(aTHX_ "panic: hv_placeholders_set");
2809     }
2810     /* else we don't need to add magic to record 0 placeholders.  */
2811 }
2812
2813 STATIC SV *
2814 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2815 {
2816     dVAR;
2817     SV *value;
2818
2819     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2820
2821     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2822     case HVrhek_undef:
2823         value = newSV(0);
2824         break;
2825     case HVrhek_delete:
2826         value = &PL_sv_placeholder;
2827         break;
2828     case HVrhek_IV:
2829         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2830         break;
2831     case HVrhek_UV:
2832         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2833         break;
2834     case HVrhek_PV:
2835     case HVrhek_PV_UTF8:
2836         /* Create a string SV that directly points to the bytes in our
2837            structure.  */
2838         value = newSV_type(SVt_PV);
2839         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2840         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2841         /* This stops anything trying to free it  */
2842         SvLEN_set(value, 0);
2843         SvPOK_on(value);
2844         SvREADONLY_on(value);
2845         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2846             SvUTF8_on(value);
2847         break;
2848     default:
2849         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2850                    (UV)he->refcounted_he_data[0]);
2851     }
2852     return value;
2853 }
2854
2855 /*
2856 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
2857
2858 Generates and returns a C<HV *> representing the content of a
2859 C<refcounted_he> chain.
2860 I<flags> is currently unused and must be zero.
2861
2862 =cut
2863 */
2864 HV *
2865 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
2866 {
2867     dVAR;
2868     HV *hv;
2869     U32 placeholders, max;
2870
2871     if (flags)
2872         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
2873             (UV)flags);
2874
2875     /* We could chase the chain once to get an idea of the number of keys,
2876        and call ksplit.  But for now we'll make a potentially inefficient
2877        hash with only 8 entries in its array.  */
2878     hv = newHV();
2879     max = HvMAX(hv);
2880     if (!HvARRAY(hv)) {
2881         char *array;
2882         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2883         HvARRAY(hv) = (HE**)array;
2884     }
2885
2886     placeholders = 0;
2887     while (chain) {
2888 #ifdef USE_ITHREADS
2889         U32 hash = chain->refcounted_he_hash;
2890 #else
2891         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2892 #endif
2893         HE **oentry = &((HvARRAY(hv))[hash & max]);
2894         HE *entry = *oentry;
2895         SV *value;
2896
2897         for (; entry; entry = HeNEXT(entry)) {
2898             if (HeHASH(entry) == hash) {
2899                 /* We might have a duplicate key here.  If so, entry is older
2900                    than the key we've already put in the hash, so if they are
2901                    the same, skip adding entry.  */
2902 #ifdef USE_ITHREADS
2903                 const STRLEN klen = HeKLEN(entry);
2904                 const char *const key = HeKEY(entry);
2905                 if (klen == chain->refcounted_he_keylen
2906                     && (!!HeKUTF8(entry)
2907                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2908                     && memEQ(key, REF_HE_KEY(chain), klen))
2909                     goto next_please;
2910 #else
2911                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2912                     goto next_please;
2913                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2914                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2915                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2916                              HeKLEN(entry)))
2917                     goto next_please;
2918 #endif
2919             }
2920         }
2921         assert (!entry);
2922         entry = new_HE();
2923
2924 #ifdef USE_ITHREADS
2925         HeKEY_hek(entry)
2926             = share_hek_flags(REF_HE_KEY(chain),
2927                               chain->refcounted_he_keylen,
2928                               chain->refcounted_he_hash,
2929                               (chain->refcounted_he_data[0]
2930                                & (HVhek_UTF8|HVhek_WASUTF8)));
2931 #else
2932         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2933 #endif
2934         value = refcounted_he_value(chain);
2935         if (value == &PL_sv_placeholder)
2936             placeholders++;
2937         HeVAL(entry) = value;
2938
2939         /* Link it into the chain.  */
2940         HeNEXT(entry) = *oentry;
2941         *oentry = entry;
2942
2943         HvTOTALKEYS(hv)++;
2944
2945     next_please:
2946         chain = chain->refcounted_he_next;
2947     }
2948
2949     if (placeholders) {
2950         clear_placeholders(hv, placeholders);
2951         HvTOTALKEYS(hv) -= placeholders;
2952     }
2953
2954     /* We could check in the loop to see if we encounter any keys with key
2955        flags, but it's probably not worth it, as this per-hash flag is only
2956        really meant as an optimisation for things like Storable.  */
2957     HvHASKFLAGS_on(hv);
2958     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2959
2960     return hv;
2961 }
2962
2963 /*
2964 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
2965
2966 Search along a C<refcounted_he> chain for an entry with the key specified
2967 by I<keypv> and I<keylen>.  If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
2968 bit set, the key octets are interpreted as UTF-8, otherwise they
2969 are interpreted as Latin-1.  I<hash> is a precomputed hash of the key
2970 string, or zero if it has not been precomputed.  Returns a mortal scalar
2971 representing the value associated with the key, or C<&PL_sv_placeholder>
2972 if there is no value associated with the key.
2973
2974 =cut
2975 */
2976
2977 SV *
2978 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
2979                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
2980 {
2981     dVAR;
2982     U8 utf8_flag;
2983     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
2984
2985     if (flags & ~REFCOUNTED_HE_KEY_UTF8)
2986         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
2987             (UV)flags);
2988     if (!chain)
2989         return &PL_sv_placeholder;
2990     if (flags & REFCOUNTED_HE_KEY_UTF8) {
2991         /* For searching purposes, canonicalise to Latin-1 where possible. */
2992         const char *keyend = keypv + keylen, *p;
2993         STRLEN nonascii_count = 0;
2994         for (p = keypv; p != keyend; p++) {
2995             U8 c = (U8)*p;
2996             if (c & 0x80) {
2997                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
2998                             (((U8)*p) & 0xc0) == 0x80))
2999                     goto canonicalised_key;
3000                 nonascii_count++;
3001             }
3002         }
3003         if (nonascii_count) {
3004             char *q;
3005             const char *p = keypv, *keyend = keypv + keylen;
3006             keylen -= nonascii_count;
3007             Newx(q, keylen, char);
3008             SAVEFREEPV(q);
3009             keypv = q;
3010             for (; p != keyend; p++, q++) {
3011                 U8 c = (U8)*p;
3012                 *q = (char)
3013                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3014             }
3015         }
3016         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3017         canonicalised_key: ;
3018     }
3019     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3020     if (!hash)
3021         PERL_HASH(hash, keypv, keylen);
3022
3023     for (; chain; chain = chain->refcounted_he_next) {
3024         if (
3025 #ifdef USE_ITHREADS
3026             hash == chain->refcounted_he_hash &&
3027             keylen == chain->refcounted_he_keylen &&
3028             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3029             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3030 #else
3031             hash == HEK_HASH(chain->refcounted_he_hek) &&
3032             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3033             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3034             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3035 #endif
3036         )
3037             return sv_2mortal(refcounted_he_value(chain));
3038     }
3039     return &PL_sv_placeholder;
3040 }
3041
3042 /*
3043 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3044
3045 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3046 instead of a string/length pair.
3047
3048 =cut
3049 */
3050
3051 SV *
3052 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3053                          const char *key, U32 hash, U32 flags)
3054 {
3055     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3056     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3057 }
3058
3059 /*
3060 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3061
3062 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3063 string/length pair.
3064
3065 =cut
3066 */
3067
3068 SV *
3069 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3070                          SV *key, U32 hash, U32 flags)
3071 {
3072     const char *keypv;
3073     STRLEN keylen;
3074     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3075     if (flags & REFCOUNTED_HE_KEY_UTF8)
3076         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3077             (UV)flags);
3078     keypv = SvPV_const(key, keylen);
3079     if (SvUTF8(key))
3080         flags |= REFCOUNTED_HE_KEY_UTF8;
3081     if (!hash && SvIsCOW_shared_hash(key))
3082         hash = SvSHARED_HASH(key);
3083     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3084 }
3085
3086 /*
3087 =for apidoc m|struct refcounted_he *|refcounted_he_new_pvn|struct refcounted_he *parent|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
3088
3089 Creates a new C<refcounted_he>.  This consists of a single key/value
3090 pair and a reference to an existing C<refcounted_he> chain (which may
3091 be empty), and thus forms a longer chain.  When using the longer chain,
3092 the new key/value pair takes precedence over any entry for the same key
3093 further along the chain.
3094
3095 The new key is specified by I<keypv> and I<keylen>.  If I<flags> has
3096 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3097 as UTF-8, otherwise they are interpreted as Latin-1.  I<hash> is
3098 a precomputed hash of the key string, or zero if it has not been
3099 precomputed.
3100
3101 I<value> is the scalar value to store for this key.  I<value> is copied
3102 by this function, which thus does not take ownership of any reference
3103 to it, and later changes to the scalar will not be reflected in the
3104 value visible in the C<refcounted_he>.  Complex types of scalar will not
3105 be stored with referential integrity, but will be coerced to strings.
3106 I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3107 value is to be associated with the key; this, as with any non-null value,
3108 takes precedence over the existence of a value for the key further along
3109 the chain.
3110
3111 I<parent> points to the rest of the C<refcounted_he> chain to be
3112 attached to the new C<refcounted_he>.  This function takes ownership
3113 of one reference to I<parent>, and returns one reference to the new
3114 C<refcounted_he>.
3115
3116 =cut
3117 */
3118
3119 struct refcounted_he *
3120 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3121         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3122 {
3123     dVAR;
3124     STRLEN value_len = 0;
3125     const char *value_p = NULL;
3126     bool is_pv;
3127     char value_type;
3128     char hekflags;
3129     STRLEN key_offset = 1;
3130     struct refcounted_he *he;
3131     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3132
3133     if (!value || value == &PL_sv_placeholder) {
3134         value_type = HVrhek_delete;
3135     } else if (SvPOK(value)) {
3136         value_type = HVrhek_PV;
3137     } else if (SvIOK(value)) {
3138         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3139     } else if (!SvOK(value)) {
3140         value_type = HVrhek_undef;
3141     } else {
3142         value_type = HVrhek_PV;
3143     }
3144     is_pv = value_type == HVrhek_PV;
3145     if (is_pv) {
3146         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3147            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3148         value_p = SvPV_const(value, value_len);
3149         if (SvUTF8(value))
3150             value_type = HVrhek_PV_UTF8;
3151         key_offset = value_len + 2;
3152     }
3153     hekflags = value_type;
3154
3155     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3156         /* Canonicalise to Latin-1 where possible. */
3157         const char *keyend = keypv + keylen, *p;
3158         STRLEN nonascii_count = 0;
3159         for (p = keypv; p != keyend; p++) {
3160             U8 c = (U8)*p;
3161             if (c & 0x80) {
3162                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3163                             (((U8)*p) & 0xc0) == 0x80))
3164                     goto canonicalised_key;
3165                 nonascii_count++;
3166             }
3167         }
3168         if (nonascii_count) {
3169             char *q;
3170             const char *p = keypv, *keyend = keypv + keylen;
3171             keylen -= nonascii_count;
3172             Newx(q, keylen, char);
3173             SAVEFREEPV(q);
3174             keypv = q;
3175             for (; p != keyend; p++, q++) {
3176                 U8 c = (U8)*p;
3177                 *q = (char)
3178                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3179             }
3180         }
3181         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3182         canonicalised_key: ;
3183     }
3184     if (flags & REFCOUNTED_HE_KEY_UTF8)
3185         hekflags |= HVhek_UTF8;
3186     if (!hash)
3187         PERL_HASH(hash, keypv, keylen);
3188
3189 #ifdef USE_ITHREADS
3190     he = (struct refcounted_he*)
3191         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3192                              + keylen
3193                              + key_offset);
3194 #else
3195     he = (struct refcounted_he*)
3196         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3197                              + key_offset);
3198 #endif
3199
3200     he->refcounted_he_next = parent;
3201
3202     if (is_pv) {
3203         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3204         he->refcounted_he_val.refcounted_he_u_len = value_len;
3205     } else if (value_type == HVrhek_IV) {
3206         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3207     } else if (value_type == HVrhek_UV) {
3208         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3209     }
3210
3211 #ifdef USE_ITHREADS
3212     he->refcounted_he_hash = hash;
3213     he->refcounted_he_keylen = keylen;
3214     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3215 #else
3216     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3217 #endif
3218
3219     he->refcounted_he_data[0] = hekflags;
3220     he->refcounted_he_refcnt = 1;
3221
3222     return he;
3223 }
3224
3225 /*
3226 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3227
3228 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3229 of a string/length pair.
3230
3231 =cut
3232 */
3233
3234 struct refcounted_he *
3235 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3236         const char *key, U32 hash, SV *value, U32 flags)
3237 {
3238     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3239     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3240 }
3241
3242 /*
3243 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3244
3245 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3246 string/length pair.
3247
3248 =cut
3249 */
3250
3251 struct refcounted_he *
3252 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3253         SV *key, U32 hash, SV *value, U32 flags)
3254 {
3255     const char *keypv;
3256     STRLEN keylen;
3257     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3258     if (flags & REFCOUNTED_HE_KEY_UTF8)
3259         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3260             (UV)flags);
3261     keypv = SvPV_const(key, keylen);
3262     if (SvUTF8(key))
3263         flags |= REFCOUNTED_HE_KEY_UTF8;
3264     if (!hash && SvIsCOW_shared_hash(key))
3265         hash = SvSHARED_HASH(key);
3266     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3267 }
3268
3269 /*
3270 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3271
3272 Decrements the reference count of a C<refcounted_he> by one.  If the
3273 reference count reaches zero the structure's memory is freed, which
3274 (recursively) causes a reduction of its parent C<refcounted_he>'s
3275 reference count.  It is safe to pass a null pointer to this function:
3276 no action occurs in this case.
3277
3278 =cut
3279 */
3280
3281 void
3282 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3283     dVAR;
3284     PERL_UNUSED_CONTEXT;
3285
3286     while (he) {
3287         struct refcounted_he *copy;
3288         U32 new_count;
3289
3290         HINTS_REFCNT_LOCK;
3291         new_count = --he->refcounted_he_refcnt;
3292         HINTS_REFCNT_UNLOCK;
3293         
3294         if (new_count) {
3295             return;
3296         }
3297
3298 #ifndef USE_ITHREADS
3299         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3300 #endif
3301         copy = he;
3302         he = he->refcounted_he_next;
3303         PerlMemShared_free(copy);
3304     }
3305 }
3306
3307 /*
3308 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3309
3310 Increment the reference count of a C<refcounted_he>.  The pointer to the
3311 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3312 to this function: no action occurs and a null pointer is returned.
3313
3314 =cut
3315 */
3316
3317 struct refcounted_he *
3318 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3319 {
3320     dVAR;
3321     if (he) {
3322         HINTS_REFCNT_LOCK;
3323         he->refcounted_he_refcnt++;
3324         HINTS_REFCNT_UNLOCK;
3325     }
3326     return he;
3327 }
3328
3329 /*
3330 =for apidoc cop_fetch_label
3331
3332 Returns the label attached to a cop.
3333 The flags pointer may be set to C<SVf_UTF8> or 0.
3334
3335 =cut
3336 */
3337
3338 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3339    the linked list.  */
3340 const char *
3341 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3342     struct refcounted_he *const chain = cop->cop_hints_hash;
3343
3344     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3345
3346     if (!chain)
3347         return NULL;
3348 #ifdef USE_ITHREADS
3349     if (chain->refcounted_he_keylen != 1)
3350         return NULL;
3351     if (*REF_HE_KEY(chain) != ':')
3352         return NULL;
3353 #else
3354     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3355         return NULL;
3356     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3357         return NULL;
3358 #endif
3359     /* Stop anyone trying to really mess us up by adding their own value for
3360        ':' into %^H  */
3361     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3362         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3363         return NULL;
3364
3365     if (len)
3366         *len = chain->refcounted_he_val.refcounted_he_u_len;
3367     if (flags) {
3368         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3369                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3370     }
3371     return chain->refcounted_he_data + 1;
3372 }
3373
3374 /*
3375 =for apidoc cop_store_label
3376
3377 Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
3378 for a utf-8 label.
3379
3380 =cut
3381 */
3382
3383 void
3384 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3385                      U32 flags)
3386 {
3387     SV *labelsv;
3388     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3389
3390     if (flags & ~(SVf_UTF8))
3391         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3392                    (UV)flags);
3393     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3394     if (flags & SVf_UTF8)
3395         SvUTF8_on(labelsv);
3396     cop->cop_hints_hash
3397         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3398 }
3399
3400 /*
3401 =for apidoc hv_assert
3402
3403 Check that a hash is in an internally consistent state.
3404
3405 =cut
3406 */
3407
3408 #ifdef DEBUGGING
3409
3410 void
3411 Perl_hv_assert(pTHX_ HV *hv)
3412 {
3413     dVAR;
3414     HE* entry;
3415     int withflags = 0;
3416     int placeholders = 0;
3417     int real = 0;
3418     int bad = 0;
3419     const I32 riter = HvRITER_get(hv);
3420     HE *eiter = HvEITER_get(hv);
3421
3422     PERL_ARGS_ASSERT_HV_ASSERT;
3423
3424     (void)hv_iterinit(hv);
3425
3426     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3427         /* sanity check the values */
3428         if (HeVAL(entry) == &PL_sv_placeholder)
3429             placeholders++;
3430         else
3431             real++;
3432         /* sanity check the keys */
3433         if (HeSVKEY(entry)) {
3434             NOOP;   /* Don't know what to check on SV keys.  */
3435         } else if (HeKUTF8(entry)) {
3436             withflags++;
3437             if (HeKWASUTF8(entry)) {
3438                 PerlIO_printf(Perl_debug_log,
3439                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3440                             (int) HeKLEN(entry),  HeKEY(entry));
3441                 bad = 1;
3442             }
3443         } else if (HeKWASUTF8(entry))
3444             withflags++;
3445     }
3446     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3447         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3448         const int nhashkeys = HvUSEDKEYS(hv);
3449         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3450
3451         if (nhashkeys != real) {
3452             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3453             bad = 1;
3454         }
3455         if (nhashplaceholders != placeholders) {
3456             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3457             bad = 1;
3458         }
3459     }
3460     if (withflags && ! HvHASKFLAGS(hv)) {
3461         PerlIO_printf(Perl_debug_log,
3462                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3463                     withflags);
3464         bad = 1;
3465     }
3466     if (bad) {
3467         sv_dump(MUTABLE_SV(hv));
3468     }
3469     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3470     HvEITER_set(hv, eiter);
3471 }
3472
3473 #endif
3474
3475 /*
3476  * Local variables:
3477  * c-indentation-style: bsd
3478  * c-basic-offset: 4
3479  * indent-tabs-mode: t
3480  * End:
3481  *
3482  * ex: set ts=8 sts=4 sw=4 noet:
3483  */