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