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