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