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