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