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