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