sigsystem.t depends on fork().
[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 %hash = (). See also L</hv_undef>.
1550
1551 =cut
1552 */
1553
1554 void
1555 Perl_hv_clear(pTHX_ HV *hv)
1556 {
1557     dVAR;
1558     register XPVHV* xhv;
1559     if (!hv)
1560         return;
1561
1562     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1563
1564     xhv = (XPVHV*)SvANY(hv);
1565
1566     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1567         /* restricted hash: convert all keys to placeholders */
1568         STRLEN i;
1569         for (i = 0; i <= xhv->xhv_max; i++) {
1570             HE *entry = (HvARRAY(hv))[i];
1571             for (; entry; entry = HeNEXT(entry)) {
1572                 /* not already placeholder */
1573                 if (HeVAL(entry) != &PL_sv_placeholder) {
1574                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))
1575                      && !SvIsCOW(HeVAL(entry))) {
1576                         SV* const keysv = hv_iterkeysv(entry);
1577                         Perl_croak(aTHX_
1578                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1579                                    (void*)keysv);
1580                     }
1581                     SvREFCNT_dec(HeVAL(entry));
1582                     HeVAL(entry) = &PL_sv_placeholder;
1583                     HvPLACEHOLDERS(hv)++;
1584                 }
1585             }
1586         }
1587     }
1588     else {
1589         hfreeentries(hv);
1590         HvPLACEHOLDERS_set(hv, 0);
1591
1592         if (SvRMAGICAL(hv))
1593             mg_clear(MUTABLE_SV(hv));
1594
1595         HvHASKFLAGS_off(hv);
1596         HvREHASH_off(hv);
1597     }
1598     if (SvOOK(hv)) {
1599         if(HvENAME_get(hv))
1600             mro_isa_changed_in(hv);
1601         HvEITER_set(hv, NULL);
1602     }
1603 }
1604
1605 /*
1606 =for apidoc hv_clear_placeholders
1607
1608 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1609 marked as readonly and the key is subsequently deleted, the key is not actually
1610 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1611 it so it will be ignored by future operations such as iterating over the hash,
1612 but will still allow the hash to have a value reassigned to the key at some
1613 future point.  This function clears any such placeholder keys from the hash.
1614 See Hash::Util::lock_keys() for an example of its use.
1615
1616 =cut
1617 */
1618
1619 void
1620 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1621 {
1622     dVAR;
1623     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1624
1625     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1626
1627     if (items)
1628         clear_placeholders(hv, items);
1629 }
1630
1631 static void
1632 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1633 {
1634     dVAR;
1635     I32 i;
1636
1637     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1638
1639     if (items == 0)
1640         return;
1641
1642     i = HvMAX(hv);
1643     do {
1644         /* Loop down the linked list heads  */
1645         HE **oentry = &(HvARRAY(hv))[i];
1646         HE *entry;
1647
1648         while ((entry = *oentry)) {
1649             if (HeVAL(entry) == &PL_sv_placeholder) {
1650                 *oentry = HeNEXT(entry);
1651                 if (entry == HvEITER_get(hv))
1652                     HvLAZYDEL_on(hv);
1653                 else {
1654                     if (SvOOK(hv) && HvLAZYDEL(hv) &&
1655                         entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1656                         HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1657                     hv_free_ent(hv, entry);
1658                 }
1659
1660                 if (--items == 0) {
1661                     /* Finished.  */
1662                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1663                     if (HvUSEDKEYS(hv) == 0)
1664                         HvHASKFLAGS_off(hv);
1665                     HvPLACEHOLDERS_set(hv, 0);
1666                     return;
1667                 }
1668             } else {
1669                 oentry = &HeNEXT(entry);
1670             }
1671         }
1672     } while (--i >= 0);
1673     /* You can't get here, hence assertion should always fail.  */
1674     assert (items == 0);
1675     assert (0);
1676 }
1677
1678 STATIC void
1679 S_hfreeentries(pTHX_ HV *hv)
1680 {
1681     STRLEN index = 0;
1682     XPVHV * const xhv = (XPVHV*)SvANY(hv);
1683     SV *sv;
1684
1685     PERL_ARGS_ASSERT_HFREEENTRIES;
1686
1687     while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
1688         SvREFCNT_dec(sv);
1689     }
1690 }
1691
1692
1693 /* hfree_next_entry()
1694  * For use only by S_hfreeentries() and sv_clear().
1695  * Delete the next available HE from hv and return the associated SV.
1696  * Returns null on empty hash. Nevertheless null is not a reliable
1697  * indicator that the hash is empty, as the deleted entry may have a
1698  * null value.
1699  * indexp is a pointer to the current index into HvARRAY. The index should
1700  * initially be set to 0. hfree_next_entry() may update it.  */
1701
1702 SV*
1703 Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1704 {
1705     struct xpvhv_aux *iter;
1706     HE *entry;
1707     HE ** array;
1708 #ifdef DEBUGGING
1709     STRLEN orig_index = *indexp;
1710 #endif
1711
1712     PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1713
1714     if (SvOOK(hv) && ((iter = HvAUX(hv)))
1715         && ((entry = iter->xhv_eiter)) )
1716     {
1717         /* the iterator may get resurrected after each
1718          * destructor call, so check each time */
1719         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1720             HvLAZYDEL_off(hv);
1721             hv_free_ent(hv, entry);
1722             /* warning: at this point HvARRAY may have been
1723              * re-allocated, HvMAX changed etc */
1724         }
1725         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1726         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1727     }
1728
1729     if (!((XPVHV*)SvANY(hv))->xhv_keys)
1730         return NULL;
1731
1732     array = HvARRAY(hv);
1733     assert(array);
1734     while ( ! ((entry = array[*indexp])) ) {
1735         if ((*indexp)++ >= HvMAX(hv))
1736             *indexp = 0;
1737         assert(*indexp != orig_index);
1738     }
1739     array[*indexp] = HeNEXT(entry);
1740     ((XPVHV*) SvANY(hv))->xhv_keys--;
1741
1742     if (   PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
1743         && HeVAL(entry) && isGV(HeVAL(entry))
1744         && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
1745     ) {
1746         STRLEN klen;
1747         const char * const key = HePV(entry,klen);
1748         if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
1749          || (klen == 1 && key[0] == ':')) {
1750             mro_package_moved(
1751              NULL, GvHV(HeVAL(entry)),
1752              (GV *)HeVAL(entry), 0
1753             );
1754         }
1755     }
1756     return hv_free_ent_ret(hv, entry);
1757 }
1758
1759
1760 /*
1761 =for apidoc hv_undef
1762
1763 Undefines the hash.  The XS equivalent of undef(%hash).
1764
1765 As well as freeing all the elements of the hash (like hv_clear()), this
1766 also frees any auxiliary data and storage associated with the hash.
1767 See also L</hv_clear>.
1768
1769 =cut
1770 */
1771
1772 void
1773 Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1774 {
1775     dVAR;
1776     register XPVHV* xhv;
1777     const char *name;
1778
1779     if (!hv)
1780         return;
1781     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1782     xhv = (XPVHV*)SvANY(hv);
1783
1784     /* The name must be deleted before the call to hfreeeeentries so that
1785        CVs are anonymised properly. But the effective name must be pre-
1786        served until after that call (and only deleted afterwards if the
1787        call originated from sv_clear). For stashes with one name that is
1788        both the canonical name and the effective name, hv_name_set has to
1789        allocate an array for storing the effective name. We can skip that
1790        during global destruction, as it does not matter where the CVs point
1791        if they will be freed anyway. */
1792     /* note that the code following prior to hfreeentries is duplicated
1793      * in sv_clear(), and changes here should be done there too */
1794     if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
1795         if (PL_stashcache)
1796             (void)hv_delete(PL_stashcache, name,
1797                             HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
1798                             G_DISCARD
1799                            );
1800         hv_name_set(hv, NULL, 0, 0);
1801     }
1802     hfreeentries(hv);
1803     if (SvOOK(hv)) {
1804       struct xpvhv_aux * const aux = HvAUX(hv);
1805       struct mro_meta *meta;
1806
1807       if ((name = HvENAME_get(hv))) {
1808         if (PL_phase != PERL_PHASE_DESTRUCT)
1809             mro_isa_changed_in(hv);
1810         if (PL_stashcache)
1811             (void)hv_delete(
1812                     PL_stashcache, name,
1813                     HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
1814                     G_DISCARD
1815                   );
1816       }
1817
1818       /* If this call originated from sv_clear, then we must check for
1819        * effective names that need freeing, as well as the usual name. */
1820       name = HvNAME(hv);
1821       if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
1822         if (name && PL_stashcache)
1823             (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
1824         hv_name_set(hv, NULL, 0, flags);
1825       }
1826       if((meta = aux->xhv_mro_meta)) {
1827         if (meta->mro_linear_all) {
1828             SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
1829             meta->mro_linear_all = NULL;
1830             /* This is just acting as a shortcut pointer.  */
1831             meta->mro_linear_current = NULL;
1832         } else if (meta->mro_linear_current) {
1833             /* Only the current MRO is stored, so this owns the data.
1834              */
1835             SvREFCNT_dec(meta->mro_linear_current);
1836             meta->mro_linear_current = NULL;
1837         }
1838         SvREFCNT_dec(meta->mro_nextmethod);
1839         SvREFCNT_dec(meta->isa);
1840         Safefree(meta);
1841         aux->xhv_mro_meta = NULL;
1842       }
1843       if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
1844         SvFLAGS(hv) &= ~SVf_OOK;
1845     }
1846     if (!SvOOK(hv)) {
1847         Safefree(HvARRAY(hv));
1848         xhv->xhv_max   = 7;     /* HvMAX(hv) = 7 (it's a normal hash) */
1849         HvARRAY(hv) = 0;
1850     }
1851     HvPLACEHOLDERS_set(hv, 0);
1852
1853     if (SvRMAGICAL(hv))
1854         mg_clear(MUTABLE_SV(hv));
1855 }
1856
1857 /*
1858 =for apidoc hv_fill
1859
1860 Returns the number of hash buckets that happen to be in use. This function is
1861 wrapped by the macro C<HvFILL>.
1862
1863 Previously this value was stored in the HV structure, rather than being
1864 calculated on demand.
1865
1866 =cut
1867 */
1868
1869 STRLEN
1870 Perl_hv_fill(pTHX_ HV const *const hv)
1871 {
1872     STRLEN count = 0;
1873     HE **ents = HvARRAY(hv);
1874
1875     PERL_ARGS_ASSERT_HV_FILL;
1876
1877     if (ents) {
1878         HE *const *const last = ents + HvMAX(hv);
1879         count = last + 1 - ents;
1880
1881         do {
1882             if (!*ents)
1883                 --count;
1884         } while (++ents <= last);
1885     }
1886     return count;
1887 }
1888
1889 static struct xpvhv_aux*
1890 S_hv_auxinit(HV *hv) {
1891     struct xpvhv_aux *iter;
1892     char *array;
1893
1894     PERL_ARGS_ASSERT_HV_AUXINIT;
1895
1896     if (!HvARRAY(hv)) {
1897         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1898             + sizeof(struct xpvhv_aux), char);
1899     } else {
1900         array = (char *) HvARRAY(hv);
1901         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1902               + sizeof(struct xpvhv_aux), char);
1903     }
1904     HvARRAY(hv) = (HE**) array;
1905     SvOOK_on(hv);
1906     iter = HvAUX(hv);
1907
1908     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1909     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1910     iter->xhv_name_u.xhvnameu_name = 0;
1911     iter->xhv_name_count = 0;
1912     iter->xhv_backreferences = 0;
1913     iter->xhv_mro_meta = NULL;
1914     return iter;
1915 }
1916
1917 /*
1918 =for apidoc hv_iterinit
1919
1920 Prepares a starting point to traverse a hash table.  Returns the number of
1921 keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>).  The return value is
1922 currently only meaningful for hashes without tie magic.
1923
1924 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1925 hash buckets that happen to be in use.  If you still need that esoteric
1926 value, you can get it through the macro C<HvFILL(hv)>.
1927
1928
1929 =cut
1930 */
1931
1932 I32
1933 Perl_hv_iterinit(pTHX_ HV *hv)
1934 {
1935     PERL_ARGS_ASSERT_HV_ITERINIT;
1936
1937     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1938
1939     if (!hv)
1940         Perl_croak(aTHX_ "Bad hash");
1941
1942     if (SvOOK(hv)) {
1943         struct xpvhv_aux * const iter = HvAUX(hv);
1944         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1945         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1946             HvLAZYDEL_off(hv);
1947             hv_free_ent(hv, entry);
1948         }
1949         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1950         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1951     } else {
1952         hv_auxinit(hv);
1953     }
1954
1955     /* used to be xhv->xhv_fill before 5.004_65 */
1956     return HvTOTALKEYS(hv);
1957 }
1958
1959 I32 *
1960 Perl_hv_riter_p(pTHX_ HV *hv) {
1961     struct xpvhv_aux *iter;
1962
1963     PERL_ARGS_ASSERT_HV_RITER_P;
1964
1965     if (!hv)
1966         Perl_croak(aTHX_ "Bad hash");
1967
1968     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1969     return &(iter->xhv_riter);
1970 }
1971
1972 HE **
1973 Perl_hv_eiter_p(pTHX_ HV *hv) {
1974     struct xpvhv_aux *iter;
1975
1976     PERL_ARGS_ASSERT_HV_EITER_P;
1977
1978     if (!hv)
1979         Perl_croak(aTHX_ "Bad hash");
1980
1981     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1982     return &(iter->xhv_eiter);
1983 }
1984
1985 void
1986 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1987     struct xpvhv_aux *iter;
1988
1989     PERL_ARGS_ASSERT_HV_RITER_SET;
1990
1991     if (!hv)
1992         Perl_croak(aTHX_ "Bad hash");
1993
1994     if (SvOOK(hv)) {
1995         iter = HvAUX(hv);
1996     } else {
1997         if (riter == -1)
1998             return;
1999
2000         iter = hv_auxinit(hv);
2001     }
2002     iter->xhv_riter = riter;
2003 }
2004
2005 void
2006 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2007     struct xpvhv_aux *iter;
2008
2009     PERL_ARGS_ASSERT_HV_EITER_SET;
2010
2011     if (!hv)
2012         Perl_croak(aTHX_ "Bad hash");
2013
2014     if (SvOOK(hv)) {
2015         iter = HvAUX(hv);
2016     } else {
2017         /* 0 is the default so don't go malloc()ing a new structure just to
2018            hold 0.  */
2019         if (!eiter)
2020             return;
2021
2022         iter = hv_auxinit(hv);
2023     }
2024     iter->xhv_eiter = eiter;
2025 }
2026
2027 void
2028 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2029 {
2030     dVAR;
2031     struct xpvhv_aux *iter;
2032     U32 hash;
2033     HEK **spot;
2034
2035     PERL_ARGS_ASSERT_HV_NAME_SET;
2036
2037     if (len > I32_MAX)
2038         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2039
2040     if (SvOOK(hv)) {
2041         iter = HvAUX(hv);
2042         if (iter->xhv_name_u.xhvnameu_name) {
2043             if(iter->xhv_name_count) {
2044               if(flags & HV_NAME_SETALL) {
2045                 HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2046                 HEK **hekp = name + (
2047                     iter->xhv_name_count < 0
2048                      ? -iter->xhv_name_count
2049                      :  iter->xhv_name_count
2050                    );
2051                 while(hekp-- > name+1) 
2052                     unshare_hek_or_pvn(*hekp, 0, 0, 0);
2053                 /* The first elem may be null. */
2054                 if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2055                 Safefree(name);
2056                 spot = &iter->xhv_name_u.xhvnameu_name;
2057                 iter->xhv_name_count = 0;
2058               }
2059               else {
2060                 if(iter->xhv_name_count > 0) {
2061                     /* shift some things over */
2062                     Renew(
2063                      iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2064                     );
2065                     spot = iter->xhv_name_u.xhvnameu_names;
2066                     spot[iter->xhv_name_count] = spot[1];
2067                     spot[1] = spot[0];
2068                     iter->xhv_name_count = -(iter->xhv_name_count + 1);
2069                 }
2070                 else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2071                     unshare_hek_or_pvn(*spot, 0, 0, 0);
2072                 }
2073               }
2074             }
2075             else if (flags & HV_NAME_SETALL) {
2076                 unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2077                 spot = &iter->xhv_name_u.xhvnameu_name;
2078             }
2079             else {
2080                 HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2081                 Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2082                 iter->xhv_name_count = -2;
2083                 spot = iter->xhv_name_u.xhvnameu_names;
2084                 spot[1] = existing_name;
2085             }
2086         }
2087         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2088     } else {
2089         if (name == 0)
2090             return;
2091
2092         iter = hv_auxinit(hv);
2093         spot = &iter->xhv_name_u.xhvnameu_name;
2094     }
2095     PERL_HASH(hash, name, len);
2096     *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
2097 }
2098
2099 /*
2100 This is basically sv_eq_flags() in sv.c, but we avoid the magic
2101 and bytes checking.
2102 */
2103
2104 STATIC I32
2105 hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2106     if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2107         if (flags & SVf_UTF8)
2108             return (bytes_cmp_utf8(
2109                         (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2110                         (const U8*)pv, pvlen) == 0);
2111         else
2112             return (bytes_cmp_utf8(
2113                         (const U8*)pv, pvlen,
2114                         (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2115     }
2116     else
2117         return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
2118                     || memEQ(HEK_KEY(hek), pv, pvlen));
2119 }
2120
2121 /*
2122 =for apidoc hv_ename_add
2123
2124 Adds a name to a stash's internal list of effective names.  See
2125 C<hv_ename_delete>.
2126
2127 This is called when a stash is assigned to a new location in the symbol
2128 table.
2129
2130 =cut
2131 */
2132
2133 void
2134 Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2135 {
2136     dVAR;
2137     struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2138     U32 hash;
2139
2140     PERL_ARGS_ASSERT_HV_ENAME_ADD;
2141
2142     if (len > I32_MAX)
2143         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2144
2145     PERL_HASH(hash, name, len);
2146
2147     if (aux->xhv_name_count) {
2148         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
2149         I32 count = aux->xhv_name_count;
2150         HEK **hekp = xhv_name + (count < 0 ? -count : count);
2151         while (hekp-- > xhv_name)
2152             if (
2153                  (HEK_UTF8(*hekp) || (flags & SVf_UTF8)) 
2154                     ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2155                     : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2156                ) {
2157                 if (hekp == xhv_name && count < 0)
2158                     aux->xhv_name_count = -count;
2159                 return;
2160             }
2161         if (count < 0) aux->xhv_name_count--, count = -count;
2162         else aux->xhv_name_count++;
2163         Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2164         (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2165     }
2166     else {
2167         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2168         if (
2169             existing_name && (
2170              (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2171                 ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2172                 : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2173             )
2174         ) return;
2175         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2176         aux->xhv_name_count = existing_name ? 2 : -2;
2177         *aux->xhv_name_u.xhvnameu_names = existing_name;
2178         (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2179     }
2180 }
2181
2182 /*
2183 =for apidoc hv_ename_delete
2184
2185 Removes a name from a stash's internal list of effective names.  If this is
2186 the name returned by C<HvENAME>, then another name in the list will take
2187 its place (C<HvENAME> will use it).
2188
2189 This is called when a stash is deleted from the symbol table.
2190
2191 =cut
2192 */
2193
2194 void
2195 Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2196 {
2197     dVAR;
2198     struct xpvhv_aux *aux;
2199
2200     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2201
2202     if (len > I32_MAX)
2203         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2204
2205     if (!SvOOK(hv)) return;
2206
2207     aux = HvAUX(hv);
2208     if (!aux->xhv_name_u.xhvnameu_name) return;
2209
2210     if (aux->xhv_name_count) {
2211         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2212         I32 const count = aux->xhv_name_count;
2213         HEK **victim = namep + (count < 0 ? -count : count);
2214         while (victim-- > namep + 1)
2215             if (
2216              (HEK_UTF8(*victim) || (flags & SVf_UTF8)) 
2217                 ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2218                 : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2219             ) {
2220                 unshare_hek_or_pvn(*victim, 0, 0, 0);
2221                 if (count < 0) ++aux->xhv_name_count;
2222                 else --aux->xhv_name_count;
2223                 if (
2224                     (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2225                  && !*namep
2226                 ) {  /* if there are none left */
2227                     Safefree(namep);
2228                     aux->xhv_name_u.xhvnameu_names = NULL;
2229                     aux->xhv_name_count = 0;
2230                 }
2231                 else {
2232                     /* Move the last one back to fill the empty slot. It
2233                        does not matter what order they are in. */
2234                     *victim = *(namep + (count < 0 ? -count : count) - 1);
2235                 }
2236                 return;
2237             }
2238         if (
2239             count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8)) 
2240                 ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2241                 : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2242         ) {
2243             aux->xhv_name_count = -count;
2244         }
2245     }
2246     else if(
2247         (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) 
2248                 ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2249                 : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2250                             memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2251     ) {
2252         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2253         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2254         *aux->xhv_name_u.xhvnameu_names = namehek;
2255         aux->xhv_name_count = -1;
2256     }
2257 }
2258
2259 AV **
2260 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2261     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2262
2263     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2264     PERL_UNUSED_CONTEXT;
2265
2266     return &(iter->xhv_backreferences);
2267 }
2268
2269 void
2270 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2271     AV *av;
2272
2273     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2274
2275     if (!SvOOK(hv))
2276         return;
2277
2278     av = HvAUX(hv)->xhv_backreferences;
2279
2280     if (av) {
2281         HvAUX(hv)->xhv_backreferences = 0;
2282         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2283         if (SvTYPE(av) == SVt_PVAV)
2284             SvREFCNT_dec(av);
2285     }
2286 }
2287
2288 /*
2289 hv_iternext is implemented as a macro in hv.h
2290
2291 =for apidoc hv_iternext
2292
2293 Returns entries from a hash iterator.  See C<hv_iterinit>.
2294
2295 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2296 iterator currently points to, without losing your place or invalidating your
2297 iterator.  Note that in this case the current entry is deleted from the hash
2298 with your iterator holding the last reference to it.  Your iterator is flagged
2299 to free the entry on the next call to C<hv_iternext>, so you must not discard
2300 your iterator immediately else the entry will leak - call C<hv_iternext> to
2301 trigger the resource deallocation.
2302
2303 =for apidoc hv_iternext_flags
2304
2305 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2306 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2307 set the placeholders keys (for restricted hashes) will be returned in addition
2308 to normal keys. By default placeholders are automatically skipped over.
2309 Currently a placeholder is implemented with a value that is
2310 C<&Perl_sv_placeholder>.  Note that the implementation of placeholders and
2311 restricted hashes may change, and the implementation currently is
2312 insufficiently abstracted for any change to be tidy.
2313
2314 =cut
2315 */
2316
2317 HE *
2318 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2319 {
2320     dVAR;
2321     register XPVHV* xhv;
2322     register HE *entry;
2323     HE *oldentry;
2324     MAGIC* mg;
2325     struct xpvhv_aux *iter;
2326
2327     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2328
2329     if (!hv)
2330         Perl_croak(aTHX_ "Bad hash");
2331
2332     xhv = (XPVHV*)SvANY(hv);
2333
2334     if (!SvOOK(hv)) {
2335         /* Too many things (well, pp_each at least) merrily assume that you can
2336            call iv_iternext without calling hv_iterinit, so we'll have to deal
2337            with it.  */
2338         hv_iterinit(hv);
2339     }
2340     iter = HvAUX(hv);
2341
2342     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2343     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2344         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2345             SV * const key = sv_newmortal();
2346             if (entry) {
2347                 sv_setsv(key, HeSVKEY_force(entry));
2348                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2349             }
2350             else {
2351                 char *k;
2352                 HEK *hek;
2353
2354                 /* one HE per MAGICAL hash */
2355                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2356                 Zero(entry, 1, HE);
2357                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2358                 hek = (HEK*)k;
2359                 HeKEY_hek(entry) = hek;
2360                 HeKLEN(entry) = HEf_SVKEY;
2361             }
2362             magic_nextpack(MUTABLE_SV(hv),mg,key);
2363             if (SvOK(key)) {
2364                 /* force key to stay around until next time */
2365                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2366                 return entry;               /* beware, hent_val is not set */
2367             }
2368             SvREFCNT_dec(HeVAL(entry));
2369             Safefree(HeKEY_hek(entry));
2370             del_HE(entry);
2371             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2372             return NULL;
2373         }
2374     }
2375 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2376     if (!entry && SvRMAGICAL((const SV *)hv)
2377         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2378         prime_env_iter();
2379 #ifdef VMS
2380         /* The prime_env_iter() on VMS just loaded up new hash values
2381          * so the iteration count needs to be reset back to the beginning
2382          */
2383         hv_iterinit(hv);
2384         iter = HvAUX(hv);
2385         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2386 #endif
2387     }
2388 #endif
2389
2390     /* hv_iterinit now ensures this.  */
2391     assert (HvARRAY(hv));
2392
2393     /* At start of hash, entry is NULL.  */
2394     if (entry)
2395     {
2396         entry = HeNEXT(entry);
2397         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2398             /*
2399              * Skip past any placeholders -- don't want to include them in
2400              * any iteration.
2401              */
2402             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2403                 entry = HeNEXT(entry);
2404             }
2405         }
2406     }
2407
2408     /* Skip the entire loop if the hash is empty.   */
2409     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2410         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2411         while (!entry) {
2412             /* OK. Come to the end of the current list.  Grab the next one.  */
2413
2414             iter->xhv_riter++; /* HvRITER(hv)++ */
2415             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2416                 /* There is no next one.  End of the hash.  */
2417                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2418                 break;
2419             }
2420             entry = (HvARRAY(hv))[iter->xhv_riter];
2421
2422             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2423                 /* If we have an entry, but it's a placeholder, don't count it.
2424                    Try the next.  */
2425                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2426                     entry = HeNEXT(entry);
2427             }
2428             /* Will loop again if this linked list starts NULL
2429                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2430                or if we run through it and find only placeholders.  */
2431         }
2432     }
2433     else iter->xhv_riter = -1;
2434
2435     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2436         HvLAZYDEL_off(hv);
2437         hv_free_ent(hv, oldentry);
2438     }
2439
2440     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2441       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2442
2443     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2444     return entry;
2445 }
2446
2447 /*
2448 =for apidoc hv_iterkey
2449
2450 Returns the key from the current position of the hash iterator.  See
2451 C<hv_iterinit>.
2452
2453 =cut
2454 */
2455
2456 char *
2457 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2458 {
2459     PERL_ARGS_ASSERT_HV_ITERKEY;
2460
2461     if (HeKLEN(entry) == HEf_SVKEY) {
2462         STRLEN len;
2463         char * const p = SvPV(HeKEY_sv(entry), len);
2464         *retlen = len;
2465         return p;
2466     }
2467     else {
2468         *retlen = HeKLEN(entry);
2469         return HeKEY(entry);
2470     }
2471 }
2472
2473 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2474 /*
2475 =for apidoc hv_iterkeysv
2476
2477 Returns the key as an C<SV*> from the current position of the hash
2478 iterator.  The return value will always be a mortal copy of the key.  Also
2479 see C<hv_iterinit>.
2480
2481 =cut
2482 */
2483
2484 SV *
2485 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2486 {
2487     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2488
2489     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2490 }
2491
2492 /*
2493 =for apidoc hv_iterval
2494
2495 Returns the value from the current position of the hash iterator.  See
2496 C<hv_iterkey>.
2497
2498 =cut
2499 */
2500
2501 SV *
2502 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2503 {
2504     PERL_ARGS_ASSERT_HV_ITERVAL;
2505
2506     if (SvRMAGICAL(hv)) {
2507         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2508             SV* const sv = sv_newmortal();
2509             if (HeKLEN(entry) == HEf_SVKEY)
2510                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2511             else
2512                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2513             return sv;
2514         }
2515     }
2516     return HeVAL(entry);
2517 }
2518
2519 /*
2520 =for apidoc hv_iternextsv
2521
2522 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2523 operation.
2524
2525 =cut
2526 */
2527
2528 SV *
2529 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2530 {
2531     HE * const he = hv_iternext_flags(hv, 0);
2532
2533     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2534
2535     if (!he)
2536         return NULL;
2537     *key = hv_iterkey(he, retlen);
2538     return hv_iterval(hv, he);
2539 }
2540
2541 /*
2542
2543 Now a macro in hv.h
2544
2545 =for apidoc hv_magic
2546
2547 Adds magic to a hash.  See C<sv_magic>.
2548
2549 =cut
2550 */
2551
2552 /* possibly free a shared string if no one has access to it
2553  * len and hash must both be valid for str.
2554  */
2555 void
2556 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2557 {
2558     unshare_hek_or_pvn (NULL, str, len, hash);
2559 }
2560
2561
2562 void
2563 Perl_unshare_hek(pTHX_ HEK *hek)
2564 {
2565     assert(hek);
2566     unshare_hek_or_pvn(hek, NULL, 0, 0);
2567 }
2568
2569 /* possibly free a shared string if no one has access to it
2570    hek if non-NULL takes priority over the other 3, else str, len and hash
2571    are used.  If so, len and hash must both be valid for str.
2572  */
2573 STATIC void
2574 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2575 {
2576     dVAR;
2577     register XPVHV* xhv;
2578     HE *entry;
2579     register HE **oentry;
2580     bool is_utf8 = FALSE;
2581     int k_flags = 0;
2582     const char * const save = str;
2583     struct shared_he *he = NULL;
2584
2585     if (hek) {
2586         /* Find the shared he which is just before us in memory.  */
2587         he = (struct shared_he *)(((char *)hek)
2588                                   - STRUCT_OFFSET(struct shared_he,
2589                                                   shared_he_hek));
2590
2591         /* Assert that the caller passed us a genuine (or at least consistent)
2592            shared hek  */
2593         assert (he->shared_he_he.hent_hek == hek);
2594
2595         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2596             --he->shared_he_he.he_valu.hent_refcount;
2597             return;
2598         }
2599
2600         hash = HEK_HASH(hek);
2601     } else if (len < 0) {
2602         STRLEN tmplen = -len;
2603         is_utf8 = TRUE;
2604         /* See the note in hv_fetch(). --jhi */
2605         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2606         len = tmplen;
2607         if (is_utf8)
2608             k_flags = HVhek_UTF8;
2609         if (str != save)
2610             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2611     }
2612
2613     /* what follows was the moral equivalent of:
2614     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2615         if (--*Svp == NULL)
2616             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2617     } */
2618     xhv = (XPVHV*)SvANY(PL_strtab);
2619     /* assert(xhv_array != 0) */
2620     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2621     if (he) {
2622         const HE *const he_he = &(he->shared_he_he);
2623         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2624             if (entry == he_he)
2625                 break;
2626         }
2627     } else {
2628         const int flags_masked = k_flags & HVhek_MASK;
2629         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2630             if (HeHASH(entry) != hash)          /* strings can't be equal */
2631                 continue;
2632             if (HeKLEN(entry) != len)
2633                 continue;
2634             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2635                 continue;
2636             if (HeKFLAGS(entry) != flags_masked)
2637                 continue;
2638             break;
2639         }
2640     }
2641
2642     if (entry) {
2643         if (--entry->he_valu.hent_refcount == 0) {
2644             *oentry = HeNEXT(entry);
2645             Safefree(entry);
2646             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2647         }
2648     }
2649
2650     if (!entry)
2651         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2652                          "Attempt to free nonexistent shared string '%s'%s"
2653                          pTHX__FORMAT,
2654                          hek ? HEK_KEY(hek) : str,
2655                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2656     if (k_flags & HVhek_FREEKEY)
2657         Safefree(str);
2658 }
2659
2660 /* get a (constant) string ptr from the global string table
2661  * string will get added if it is not already there.
2662  * len and hash must both be valid for str.
2663  */
2664 HEK *
2665 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2666 {
2667     bool is_utf8 = FALSE;
2668     int flags = 0;
2669     const char * const save = str;
2670
2671     PERL_ARGS_ASSERT_SHARE_HEK;
2672
2673     if (len < 0) {
2674       STRLEN tmplen = -len;
2675       is_utf8 = TRUE;
2676       /* See the note in hv_fetch(). --jhi */
2677       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2678       len = tmplen;
2679       /* If we were able to downgrade here, then than means that we were passed
2680          in a key which only had chars 0-255, but was utf8 encoded.  */
2681       if (is_utf8)
2682           flags = HVhek_UTF8;
2683       /* If we found we were able to downgrade the string to bytes, then
2684          we should flag that it needs upgrading on keys or each.  Also flag
2685          that we need share_hek_flags to free the string.  */
2686       if (str != save) {
2687           PERL_HASH(hash, str, len);
2688           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2689       }
2690     }
2691
2692     return share_hek_flags (str, len, hash, flags);
2693 }
2694
2695 STATIC HEK *
2696 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2697 {
2698     dVAR;
2699     register HE *entry;
2700     const int flags_masked = flags & HVhek_MASK;
2701     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2702     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2703
2704     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2705
2706     /* what follows is the moral equivalent of:
2707
2708     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2709         hv_store(PL_strtab, str, len, NULL, hash);
2710
2711         Can't rehash the shared string table, so not sure if it's worth
2712         counting the number of entries in the linked list
2713     */
2714
2715     /* assert(xhv_array != 0) */
2716     entry = (HvARRAY(PL_strtab))[hindex];
2717     for (;entry; entry = HeNEXT(entry)) {
2718         if (HeHASH(entry) != hash)              /* strings can't be equal */
2719             continue;
2720         if (HeKLEN(entry) != len)
2721             continue;
2722         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2723             continue;
2724         if (HeKFLAGS(entry) != flags_masked)
2725             continue;
2726         break;
2727     }
2728
2729     if (!entry) {
2730         /* What used to be head of the list.
2731            If this is NULL, then we're the first entry for this slot, which
2732            means we need to increate fill.  */
2733         struct shared_he *new_entry;
2734         HEK *hek;
2735         char *k;
2736         HE **const head = &HvARRAY(PL_strtab)[hindex];
2737         HE *const next = *head;
2738
2739         /* We don't actually store a HE from the arena and a regular HEK.
2740            Instead we allocate one chunk of memory big enough for both,
2741            and put the HEK straight after the HE. This way we can find the
2742            HE directly from the HEK.
2743         */
2744
2745         Newx(k, STRUCT_OFFSET(struct shared_he,
2746                                 shared_he_hek.hek_key[0]) + len + 2, char);
2747         new_entry = (struct shared_he *)k;
2748         entry = &(new_entry->shared_he_he);
2749         hek = &(new_entry->shared_he_hek);
2750
2751         Copy(str, HEK_KEY(hek), len, char);
2752         HEK_KEY(hek)[len] = 0;
2753         HEK_LEN(hek) = len;
2754         HEK_HASH(hek) = hash;
2755         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2756
2757         /* Still "point" to the HEK, so that other code need not know what
2758            we're up to.  */
2759         HeKEY_hek(entry) = hek;
2760         entry->he_valu.hent_refcount = 0;
2761         HeNEXT(entry) = next;
2762         *head = entry;
2763
2764         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2765         if (!next) {                    /* initial entry? */
2766         } else if (xhv->xhv_keys > xhv->xhv_max /* HvUSEDKEYS(hv) > HvMAX(hv) */) {
2767                 hsplit(PL_strtab);
2768         }
2769     }
2770
2771     ++entry->he_valu.hent_refcount;
2772
2773     if (flags & HVhek_FREEKEY)
2774         Safefree(str);
2775
2776     return HeKEY_hek(entry);
2777 }
2778
2779 I32 *
2780 Perl_hv_placeholders_p(pTHX_ HV *hv)
2781 {
2782     dVAR;
2783     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2784
2785     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2786
2787     if (!mg) {
2788         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2789
2790         if (!mg) {
2791             Perl_die(aTHX_ "panic: hv_placeholders_p");
2792         }
2793     }
2794     return &(mg->mg_len);
2795 }
2796
2797
2798 I32
2799 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2800 {
2801     dVAR;
2802     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2803
2804     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2805
2806     return mg ? mg->mg_len : 0;
2807 }
2808
2809 void
2810 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2811 {
2812     dVAR;
2813     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2814
2815     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2816
2817     if (mg) {
2818         mg->mg_len = ph;
2819     } else if (ph) {
2820         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2821             Perl_die(aTHX_ "panic: hv_placeholders_set");
2822     }
2823     /* else we don't need to add magic to record 0 placeholders.  */
2824 }
2825
2826 STATIC SV *
2827 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2828 {
2829     dVAR;
2830     SV *value;
2831
2832     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2833
2834     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2835     case HVrhek_undef:
2836         value = newSV(0);
2837         break;
2838     case HVrhek_delete:
2839         value = &PL_sv_placeholder;
2840         break;
2841     case HVrhek_IV:
2842         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2843         break;
2844     case HVrhek_UV:
2845         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2846         break;
2847     case HVrhek_PV:
2848     case HVrhek_PV_UTF8:
2849         /* Create a string SV that directly points to the bytes in our
2850            structure.  */
2851         value = newSV_type(SVt_PV);
2852         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2853         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2854         /* This stops anything trying to free it  */
2855         SvLEN_set(value, 0);
2856         SvPOK_on(value);
2857         SvREADONLY_on(value);
2858         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2859             SvUTF8_on(value);
2860         break;
2861     default:
2862         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2863                    (UV)he->refcounted_he_data[0]);
2864     }
2865     return value;
2866 }
2867
2868 /*
2869 =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
2870
2871 Generates and returns a C<HV *> representing the content of a
2872 C<refcounted_he> chain.
2873 I<flags> is currently unused and must be zero.
2874
2875 =cut
2876 */
2877 HV *
2878 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
2879 {
2880     dVAR;
2881     HV *hv;
2882     U32 placeholders, max;
2883
2884     if (flags)
2885         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
2886             (UV)flags);
2887
2888     /* We could chase the chain once to get an idea of the number of keys,
2889        and call ksplit.  But for now we'll make a potentially inefficient
2890        hash with only 8 entries in its array.  */
2891     hv = newHV();
2892     max = HvMAX(hv);
2893     if (!HvARRAY(hv)) {
2894         char *array;
2895         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2896         HvARRAY(hv) = (HE**)array;
2897     }
2898
2899     placeholders = 0;
2900     while (chain) {
2901 #ifdef USE_ITHREADS
2902         U32 hash = chain->refcounted_he_hash;
2903 #else
2904         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2905 #endif
2906         HE **oentry = &((HvARRAY(hv))[hash & max]);
2907         HE *entry = *oentry;
2908         SV *value;
2909
2910         for (; entry; entry = HeNEXT(entry)) {
2911             if (HeHASH(entry) == hash) {
2912                 /* We might have a duplicate key here.  If so, entry is older
2913                    than the key we've already put in the hash, so if they are
2914                    the same, skip adding entry.  */
2915 #ifdef USE_ITHREADS
2916                 const STRLEN klen = HeKLEN(entry);
2917                 const char *const key = HeKEY(entry);
2918                 if (klen == chain->refcounted_he_keylen
2919                     && (!!HeKUTF8(entry)
2920                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2921                     && memEQ(key, REF_HE_KEY(chain), klen))
2922                     goto next_please;
2923 #else
2924                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2925                     goto next_please;
2926                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2927                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2928                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2929                              HeKLEN(entry)))
2930                     goto next_please;
2931 #endif
2932             }
2933         }
2934         assert (!entry);
2935         entry = new_HE();
2936
2937 #ifdef USE_ITHREADS
2938         HeKEY_hek(entry)
2939             = share_hek_flags(REF_HE_KEY(chain),
2940                               chain->refcounted_he_keylen,
2941                               chain->refcounted_he_hash,
2942                               (chain->refcounted_he_data[0]
2943                                & (HVhek_UTF8|HVhek_WASUTF8)));
2944 #else
2945         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2946 #endif
2947         value = refcounted_he_value(chain);
2948         if (value == &PL_sv_placeholder)
2949             placeholders++;
2950         HeVAL(entry) = value;
2951
2952         /* Link it into the chain.  */
2953         HeNEXT(entry) = *oentry;
2954         *oentry = entry;
2955
2956         HvTOTALKEYS(hv)++;
2957
2958     next_please:
2959         chain = chain->refcounted_he_next;
2960     }
2961
2962     if (placeholders) {
2963         clear_placeholders(hv, placeholders);
2964         HvTOTALKEYS(hv) -= placeholders;
2965     }
2966
2967     /* We could check in the loop to see if we encounter any keys with key
2968        flags, but it's probably not worth it, as this per-hash flag is only
2969        really meant as an optimisation for things like Storable.  */
2970     HvHASKFLAGS_on(hv);
2971     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2972
2973     return hv;
2974 }
2975
2976 /*
2977 =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
2978
2979 Search along a C<refcounted_he> chain for an entry with the key specified
2980 by I<keypv> and I<keylen>.  If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
2981 bit set, the key octets are interpreted as UTF-8, otherwise they
2982 are interpreted as Latin-1.  I<hash> is a precomputed hash of the key
2983 string, or zero if it has not been precomputed.  Returns a mortal scalar
2984 representing the value associated with the key, or C<&PL_sv_placeholder>
2985 if there is no value associated with the key.
2986
2987 =cut
2988 */
2989
2990 SV *
2991 Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
2992                          const char *keypv, STRLEN keylen, U32 hash, U32 flags)
2993 {
2994     dVAR;
2995     U8 utf8_flag;
2996     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
2997
2998     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
2999         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
3000             (UV)flags);
3001     if (!chain)
3002         return &PL_sv_placeholder;
3003     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3004         /* For searching purposes, canonicalise to Latin-1 where possible. */
3005         const char *keyend = keypv + keylen, *p;
3006         STRLEN nonascii_count = 0;
3007         for (p = keypv; p != keyend; p++) {
3008             U8 c = (U8)*p;
3009             if (c & 0x80) {
3010                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3011                             (((U8)*p) & 0xc0) == 0x80))
3012                     goto canonicalised_key;
3013                 nonascii_count++;
3014             }
3015         }
3016         if (nonascii_count) {
3017             char *q;
3018             const char *p = keypv, *keyend = keypv + keylen;
3019             keylen -= nonascii_count;
3020             Newx(q, keylen, char);
3021             SAVEFREEPV(q);
3022             keypv = q;
3023             for (; p != keyend; p++, q++) {
3024                 U8 c = (U8)*p;
3025                 *q = (char)
3026                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3027             }
3028         }
3029         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3030         canonicalised_key: ;
3031     }
3032     utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3033     if (!hash)
3034         PERL_HASH(hash, keypv, keylen);
3035
3036     for (; chain; chain = chain->refcounted_he_next) {
3037         if (
3038 #ifdef USE_ITHREADS
3039             hash == chain->refcounted_he_hash &&
3040             keylen == chain->refcounted_he_keylen &&
3041             memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3042             utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3043 #else
3044             hash == HEK_HASH(chain->refcounted_he_hek) &&
3045             keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3046             memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3047             utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3048 #endif
3049         )
3050             return
3051                 flags & REFCOUNTED_HE_EXISTS
3052                     ? (chain->refcounted_he_data[0] & HVrhek_typemask)
3053                         == HVrhek_delete
3054                        ? NULL
3055                        : &PL_sv_yes
3056                     : sv_2mortal(refcounted_he_value(chain));
3057     }
3058     return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3059 }
3060
3061 /*
3062 =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3063
3064 Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
3065 instead of a string/length pair.
3066
3067 =cut
3068 */
3069
3070 SV *
3071 Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3072                          const char *key, U32 hash, U32 flags)
3073 {
3074     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3075     return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3076 }
3077
3078 /*
3079 =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3080
3081 Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
3082 string/length pair.
3083
3084 =cut
3085 */
3086
3087 SV *
3088 Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3089                          SV *key, U32 hash, U32 flags)
3090 {
3091     const char *keypv;
3092     STRLEN keylen;
3093     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3094     if (flags & REFCOUNTED_HE_KEY_UTF8)
3095         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3096             (UV)flags);
3097     keypv = SvPV_const(key, keylen);
3098     if (SvUTF8(key))
3099         flags |= REFCOUNTED_HE_KEY_UTF8;
3100     if (!hash && SvIsCOW_shared_hash(key))
3101         hash = SvSHARED_HASH(key);
3102     return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3103 }
3104
3105 /*
3106 =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
3107
3108 Creates a new C<refcounted_he>.  This consists of a single key/value
3109 pair and a reference to an existing C<refcounted_he> chain (which may
3110 be empty), and thus forms a longer chain.  When using the longer chain,
3111 the new key/value pair takes precedence over any entry for the same key
3112 further along the chain.
3113
3114 The new key is specified by I<keypv> and I<keylen>.  If I<flags> has
3115 the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
3116 as UTF-8, otherwise they are interpreted as Latin-1.  I<hash> is
3117 a precomputed hash of the key string, or zero if it has not been
3118 precomputed.
3119
3120 I<value> is the scalar value to store for this key.  I<value> is copied
3121 by this function, which thus does not take ownership of any reference
3122 to it, and later changes to the scalar will not be reflected in the
3123 value visible in the C<refcounted_he>.  Complex types of scalar will not
3124 be stored with referential integrity, but will be coerced to strings.
3125 I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
3126 value is to be associated with the key; this, as with any non-null value,
3127 takes precedence over the existence of a value for the key further along
3128 the chain.
3129
3130 I<parent> points to the rest of the C<refcounted_he> chain to be
3131 attached to the new C<refcounted_he>.  This function takes ownership
3132 of one reference to I<parent>, and returns one reference to the new
3133 C<refcounted_he>.
3134
3135 =cut
3136 */
3137
3138 struct refcounted_he *
3139 Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3140         const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3141 {
3142     dVAR;
3143     STRLEN value_len = 0;
3144     const char *value_p = NULL;
3145     bool is_pv;
3146     char value_type;
3147     char hekflags;
3148     STRLEN key_offset = 1;
3149     struct refcounted_he *he;
3150     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3151
3152     if (!value || value == &PL_sv_placeholder) {
3153         value_type = HVrhek_delete;
3154     } else if (SvPOK(value)) {
3155         value_type = HVrhek_PV;
3156     } else if (SvIOK(value)) {
3157         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3158     } else if (!SvOK(value)) {
3159         value_type = HVrhek_undef;
3160     } else {
3161         value_type = HVrhek_PV;
3162     }
3163     is_pv = value_type == HVrhek_PV;
3164     if (is_pv) {
3165         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3166            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
3167         value_p = SvPV_const(value, value_len);
3168         if (SvUTF8(value))
3169             value_type = HVrhek_PV_UTF8;
3170         key_offset = value_len + 2;
3171     }
3172     hekflags = value_type;
3173
3174     if (flags & REFCOUNTED_HE_KEY_UTF8) {
3175         /* Canonicalise to Latin-1 where possible. */
3176         const char *keyend = keypv + keylen, *p;
3177         STRLEN nonascii_count = 0;
3178         for (p = keypv; p != keyend; p++) {
3179             U8 c = (U8)*p;
3180             if (c & 0x80) {
3181                 if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
3182                             (((U8)*p) & 0xc0) == 0x80))
3183                     goto canonicalised_key;
3184                 nonascii_count++;
3185             }
3186         }
3187         if (nonascii_count) {
3188             char *q;
3189             const char *p = keypv, *keyend = keypv + keylen;
3190             keylen -= nonascii_count;
3191             Newx(q, keylen, char);
3192             SAVEFREEPV(q);
3193             keypv = q;
3194             for (; p != keyend; p++, q++) {
3195                 U8 c = (U8)*p;
3196                 *q = (char)
3197                     ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
3198             }
3199         }
3200         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3201         canonicalised_key: ;
3202     }
3203     if (flags & REFCOUNTED_HE_KEY_UTF8)
3204         hekflags |= HVhek_UTF8;
3205     if (!hash)
3206         PERL_HASH(hash, keypv, keylen);
3207
3208 #ifdef USE_ITHREADS
3209     he = (struct refcounted_he*)
3210         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3211                              + keylen
3212                              + key_offset);
3213 #else
3214     he = (struct refcounted_he*)
3215         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3216                              + key_offset);
3217 #endif
3218
3219     he->refcounted_he_next = parent;
3220
3221     if (is_pv) {
3222         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3223         he->refcounted_he_val.refcounted_he_u_len = value_len;
3224     } else if (value_type == HVrhek_IV) {
3225         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3226     } else if (value_type == HVrhek_UV) {
3227         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3228     }
3229
3230 #ifdef USE_ITHREADS
3231     he->refcounted_he_hash = hash;
3232     he->refcounted_he_keylen = keylen;
3233     Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3234 #else
3235     he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3236 #endif
3237
3238     he->refcounted_he_data[0] = hekflags;
3239     he->refcounted_he_refcnt = 1;
3240
3241     return he;
3242 }
3243
3244 /*
3245 =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3246
3247 Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
3248 of a string/length pair.
3249
3250 =cut
3251 */
3252
3253 struct refcounted_he *
3254 Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3255         const char *key, U32 hash, SV *value, U32 flags)
3256 {
3257     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3258     return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3259 }
3260
3261 /*
3262 =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3263
3264 Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
3265 string/length pair.
3266
3267 =cut
3268 */
3269
3270 struct refcounted_he *
3271 Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3272         SV *key, U32 hash, SV *value, U32 flags)
3273 {
3274     const char *keypv;
3275     STRLEN keylen;
3276     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3277     if (flags & REFCOUNTED_HE_KEY_UTF8)
3278         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3279             (UV)flags);
3280     keypv = SvPV_const(key, keylen);
3281     if (SvUTF8(key))
3282         flags |= REFCOUNTED_HE_KEY_UTF8;
3283     if (!hash && SvIsCOW_shared_hash(key))
3284         hash = SvSHARED_HASH(key);
3285     return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3286 }
3287
3288 /*
3289 =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3290
3291 Decrements the reference count of a C<refcounted_he> by one.  If the
3292 reference count reaches zero the structure's memory is freed, which
3293 (recursively) causes a reduction of its parent C<refcounted_he>'s
3294 reference count.  It is safe to pass a null pointer to this function:
3295 no action occurs in this case.
3296
3297 =cut
3298 */
3299
3300 void
3301 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3302     dVAR;
3303     PERL_UNUSED_CONTEXT;
3304
3305     while (he) {
3306         struct refcounted_he *copy;
3307         U32 new_count;
3308
3309         HINTS_REFCNT_LOCK;
3310         new_count = --he->refcounted_he_refcnt;
3311         HINTS_REFCNT_UNLOCK;
3312         
3313         if (new_count) {
3314             return;
3315         }
3316
3317 #ifndef USE_ITHREADS
3318         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3319 #endif
3320         copy = he;
3321         he = he->refcounted_he_next;
3322         PerlMemShared_free(copy);
3323     }
3324 }
3325
3326 /*
3327 =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3328
3329 Increment the reference count of a C<refcounted_he>.  The pointer to the
3330 C<refcounted_he> is also returned.  It is safe to pass a null pointer
3331 to this function: no action occurs and a null pointer is returned.
3332
3333 =cut
3334 */
3335
3336 struct refcounted_he *
3337 Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3338 {
3339     dVAR;
3340     if (he) {
3341         HINTS_REFCNT_LOCK;
3342         he->refcounted_he_refcnt++;
3343         HINTS_REFCNT_UNLOCK;
3344     }
3345     return he;
3346 }
3347
3348 /*
3349 =for apidoc cop_fetch_label
3350
3351 Returns the label attached to a cop.
3352 The flags pointer may be set to C<SVf_UTF8> or 0.
3353
3354 =cut
3355 */
3356
3357 /* pp_entereval is aware that labels are stored with a key ':' at the top of
3358    the linked list.  */
3359 const char *
3360 Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3361     struct refcounted_he *const chain = cop->cop_hints_hash;
3362
3363     PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3364
3365     if (!chain)
3366         return NULL;
3367 #ifdef USE_ITHREADS
3368     if (chain->refcounted_he_keylen != 1)
3369         return NULL;
3370     if (*REF_HE_KEY(chain) != ':')
3371         return NULL;
3372 #else
3373     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3374         return NULL;
3375     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3376         return NULL;
3377 #endif
3378     /* Stop anyone trying to really mess us up by adding their own value for
3379        ':' into %^H  */
3380     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3381         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3382         return NULL;
3383
3384     if (len)
3385         *len = chain->refcounted_he_val.refcounted_he_u_len;
3386     if (flags) {
3387         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3388                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3389     }
3390     return chain->refcounted_he_data + 1;
3391 }
3392
3393 /*
3394 =for apidoc cop_store_label
3395
3396 Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
3397 for a utf-8 label.
3398
3399 =cut
3400 */
3401
3402 void
3403 Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3404                      U32 flags)
3405 {
3406     SV *labelsv;
3407     PERL_ARGS_ASSERT_COP_STORE_LABEL;
3408
3409     if (flags & ~(SVf_UTF8))
3410         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3411                    (UV)flags);
3412     labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3413     if (flags & SVf_UTF8)
3414         SvUTF8_on(labelsv);
3415     cop->cop_hints_hash
3416         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3417 }
3418
3419 /*
3420 =for apidoc hv_assert
3421
3422 Check that a hash is in an internally consistent state.
3423
3424 =cut
3425 */
3426
3427 #ifdef DEBUGGING
3428
3429 void
3430 Perl_hv_assert(pTHX_ HV *hv)
3431 {
3432     dVAR;
3433     HE* entry;
3434     int withflags = 0;
3435     int placeholders = 0;
3436     int real = 0;
3437     int bad = 0;
3438     const I32 riter = HvRITER_get(hv);
3439     HE *eiter = HvEITER_get(hv);
3440
3441     PERL_ARGS_ASSERT_HV_ASSERT;
3442
3443     (void)hv_iterinit(hv);
3444
3445     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3446         /* sanity check the values */
3447         if (HeVAL(entry) == &PL_sv_placeholder)
3448             placeholders++;
3449         else
3450             real++;
3451         /* sanity check the keys */
3452         if (HeSVKEY(entry)) {
3453             NOOP;   /* Don't know what to check on SV keys.  */
3454         } else if (HeKUTF8(entry)) {
3455             withflags++;
3456             if (HeKWASUTF8(entry)) {
3457                 PerlIO_printf(Perl_debug_log,
3458                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3459                             (int) HeKLEN(entry),  HeKEY(entry));
3460                 bad = 1;
3461             }
3462         } else if (HeKWASUTF8(entry))
3463             withflags++;
3464     }
3465     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3466         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3467         const int nhashkeys = HvUSEDKEYS(hv);
3468         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3469
3470         if (nhashkeys != real) {
3471             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3472             bad = 1;
3473         }
3474         if (nhashplaceholders != placeholders) {
3475             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3476             bad = 1;
3477         }
3478     }
3479     if (withflags && ! HvHASKFLAGS(hv)) {
3480         PerlIO_printf(Perl_debug_log,
3481                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3482                     withflags);
3483         bad = 1;
3484     }
3485     if (bad) {
3486         sv_dump(MUTABLE_SV(hv));
3487     }
3488     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3489     HvEITER_set(hv, eiter);
3490 }
3491
3492 #endif
3493
3494 /*
3495  * Local variables:
3496  * c-indentation-style: bsd
3497  * c-basic-offset: 4
3498  * indent-tabs-mode: t
3499  * End:
3500  *
3501  * ex: set ts=8 sts=4 sw=4 noet:
3502  */