Skip suid File::Copy tests on a nosuid partition
[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 (HvNAME(hv) && anonymise_cv(HvNAME_HEK(hv), val) && GvCVu(val))
1462         mro_method_changed_in(hv);
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 static I32
1476 S_anonymise_cv(pTHX_ HEK *stash, SV *val)
1477 {
1478     CV *cv;
1479
1480     PERL_ARGS_ASSERT_ANONYMISE_CV;
1481
1482     if (val && isGV(val) && isGV_with_GP(val) && (cv = GvCV(val))) {
1483         if ((SV *)CvGV(cv) == val) {
1484             GV *anongv;
1485
1486             if (stash) {
1487                 SV *gvname = newSVhek(stash);
1488                 sv_catpvs(gvname, "::__ANON__");
1489                 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
1490                 SvREFCNT_dec(gvname);
1491             } else {
1492                 anongv = gv_fetchpvs("__ANON__::__ANON__", GV_ADDMULTI,
1493                                      SVt_PVCV);
1494             }
1495             CvGV(cv) = anongv;
1496             CvANON_on(cv);
1497             return 1;
1498         }
1499     }
1500     return 0;
1501 }
1502
1503 void
1504 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1505 {
1506     dVAR;
1507
1508     PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1509
1510     if (!entry)
1511         return;
1512     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1513     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1514     if (HeKLEN(entry) == HEf_SVKEY) {
1515         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1516     }
1517     hv_free_ent(hv, entry);
1518 }
1519
1520 /*
1521 =for apidoc hv_clear
1522
1523 Clears a hash, making it empty.
1524
1525 =cut
1526 */
1527
1528 void
1529 Perl_hv_clear(pTHX_ HV *hv)
1530 {
1531     dVAR;
1532     register XPVHV* xhv;
1533     if (!hv)
1534         return;
1535
1536     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1537
1538     xhv = (XPVHV*)SvANY(hv);
1539
1540     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1541         /* restricted hash: convert all keys to placeholders */
1542         STRLEN i;
1543         for (i = 0; i <= xhv->xhv_max; i++) {
1544             HE *entry = (HvARRAY(hv))[i];
1545             for (; entry; entry = HeNEXT(entry)) {
1546                 /* not already placeholder */
1547                 if (HeVAL(entry) != &PL_sv_placeholder) {
1548                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1549                         SV* const keysv = hv_iterkeysv(entry);
1550                         Perl_croak(aTHX_
1551                                    "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1552                                    (void*)keysv);
1553                     }
1554                     SvREFCNT_dec(HeVAL(entry));
1555                     HeVAL(entry) = &PL_sv_placeholder;
1556                     HvPLACEHOLDERS(hv)++;
1557                 }
1558             }
1559         }
1560         goto reset;
1561     }
1562
1563     hfreeentries(hv);
1564     HvPLACEHOLDERS_set(hv, 0);
1565     if (HvARRAY(hv))
1566         Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
1567
1568     if (SvRMAGICAL(hv))
1569         mg_clear(MUTABLE_SV(hv));
1570
1571     HvHASKFLAGS_off(hv);
1572     HvREHASH_off(hv);
1573     reset:
1574     if (SvOOK(hv)) {
1575         if(HvNAME_get(hv))
1576             mro_isa_changed_in(hv);
1577         HvEITER_set(hv, NULL);
1578     }
1579 }
1580
1581 /*
1582 =for apidoc hv_clear_placeholders
1583
1584 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1585 marked as readonly and the key is subsequently deleted, the key is not actually
1586 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1587 it so it will be ignored by future operations such as iterating over the hash,
1588 but will still allow the hash to have a value reassigned to the key at some
1589 future point.  This function clears any such placeholder keys from the hash.
1590 See Hash::Util::lock_keys() for an example of its use.
1591
1592 =cut
1593 */
1594
1595 void
1596 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1597 {
1598     dVAR;
1599     const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1600
1601     PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1602
1603     if (items)
1604         clear_placeholders(hv, items);
1605 }
1606
1607 static void
1608 S_clear_placeholders(pTHX_ HV *hv, U32 items)
1609 {
1610     dVAR;
1611     I32 i;
1612
1613     PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1614
1615     if (items == 0)
1616         return;
1617
1618     i = HvMAX(hv);
1619     do {
1620         /* Loop down the linked list heads  */
1621         bool first = TRUE;
1622         HE **oentry = &(HvARRAY(hv))[i];
1623         HE *entry;
1624
1625         while ((entry = *oentry)) {
1626             if (HeVAL(entry) == &PL_sv_placeholder) {
1627                 *oentry = HeNEXT(entry);
1628                 if (entry == HvEITER_get(hv))
1629                     HvLAZYDEL_on(hv);
1630                 else
1631                     hv_free_ent(hv, entry);
1632
1633                 if (--items == 0) {
1634                     /* Finished.  */
1635                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1636                     if (HvKEYS(hv) == 0)
1637                         HvHASKFLAGS_off(hv);
1638                     HvPLACEHOLDERS_set(hv, 0);
1639                     return;
1640                 }
1641             } else {
1642                 oentry = &HeNEXT(entry);
1643                 first = FALSE;
1644             }
1645         }
1646     } while (--i >= 0);
1647     /* You can't get here, hence assertion should always fail.  */
1648     assert (items == 0);
1649     assert (0);
1650 }
1651
1652 STATIC void
1653 S_hfreeentries(pTHX_ HV *hv)
1654 {
1655     /* This is the array that we're going to restore  */
1656     HE **const orig_array = HvARRAY(hv);
1657     HEK *name;
1658     int attempts = 100;
1659
1660     PERL_ARGS_ASSERT_HFREEENTRIES;
1661
1662     if (!orig_array)
1663         return;
1664
1665     if (HvNAME(hv) && orig_array != NULL) {
1666         /* symbol table: make all the contained subs ANON */
1667         STRLEN i;
1668         XPVHV *xhv = (XPVHV*)SvANY(hv);
1669
1670         for (i = 0; i <= xhv->xhv_max; i++) {
1671             HE *entry = (HvARRAY(hv))[i];
1672             for (; entry; entry = HeNEXT(entry)) {
1673                 SV *val = HeVAL(entry);
1674                 /* we need to put the subs in the __ANON__ symtable, as
1675                  * this one is being cleared. */
1676                 anonymise_cv(NULL, val);
1677             }
1678         }
1679     }
1680
1681     if (SvOOK(hv)) {
1682         /* If the hash is actually a symbol table with a name, look after the
1683            name.  */
1684         struct xpvhv_aux *iter = HvAUX(hv);
1685
1686         name = iter->xhv_name;
1687         iter->xhv_name = NULL;
1688     } else {
1689         name = NULL;
1690     }
1691
1692     /* orig_array remains unchanged throughout the loop. If after freeing all
1693        the entries it turns out that one of the little blighters has triggered
1694        an action that has caused HvARRAY to be re-allocated, then we set
1695        array to the new HvARRAY, and try again.  */
1696
1697     while (1) {
1698         /* This is the one we're going to try to empty.  First time round
1699            it's the original array.  (Hopefully there will only be 1 time
1700            round) */
1701         HE ** const array = HvARRAY(hv);
1702         I32 i = HvMAX(hv);
1703
1704         /* Because we have taken xhv_name out, the only allocated pointer
1705            in the aux structure that might exist is the backreference array.
1706         */
1707
1708         if (SvOOK(hv)) {
1709             HE *entry;
1710             struct mro_meta *meta;
1711             struct xpvhv_aux *iter = HvAUX(hv);
1712             /* If there are weak references to this HV, we need to avoid
1713                freeing them up here.  In particular we need to keep the AV
1714                visible as what we're deleting might well have weak references
1715                back to this HV, so the for loop below may well trigger
1716                the removal of backreferences from this array.  */
1717
1718             if (iter->xhv_backreferences) {
1719                 /* So donate them to regular backref magic to keep them safe.
1720                    The sv_magic will increase the reference count of the AV,
1721                    so we need to drop it first. */
1722                 SvREFCNT_dec(iter->xhv_backreferences);
1723                 if (AvFILLp(iter->xhv_backreferences) == -1) {
1724                     /* Turns out that the array is empty. Just free it.  */
1725                     SvREFCNT_dec(iter->xhv_backreferences);
1726
1727                 } else {
1728                     sv_magic(MUTABLE_SV(hv),
1729                              MUTABLE_SV(iter->xhv_backreferences),
1730                              PERL_MAGIC_backref, NULL, 0);
1731                 }
1732                 iter->xhv_backreferences = NULL;
1733             }
1734
1735             entry = iter->xhv_eiter; /* HvEITER(hv) */
1736             if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1737                 HvLAZYDEL_off(hv);
1738                 hv_free_ent(hv, entry);
1739             }
1740             iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1741             iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1742
1743             if((meta = iter->xhv_mro_meta)) {
1744                 if (meta->mro_linear_all) {
1745                     SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
1746                     meta->mro_linear_all = NULL;
1747                     /* This is just acting as a shortcut pointer.  */
1748                     meta->mro_linear_current = NULL;
1749                 } else if (meta->mro_linear_current) {
1750                     /* Only the current MRO is stored, so this owns the data.
1751                      */
1752                     SvREFCNT_dec(meta->mro_linear_current);
1753                     meta->mro_linear_current = NULL;
1754                 }
1755                 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1756                 SvREFCNT_dec(meta->isa);
1757                 Safefree(meta);
1758                 iter->xhv_mro_meta = NULL;
1759             }
1760
1761             /* There are now no allocated pointers in the aux structure.  */
1762
1763             SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure.  */
1764             /* What aux structure?  */
1765         }
1766
1767         /* make everyone else think the array is empty, so that the destructors
1768          * called for freed entries can't recusively mess with us */
1769         HvARRAY(hv) = NULL;
1770         ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1771
1772
1773         do {
1774             /* Loop down the linked list heads  */
1775             HE *entry = array[i];
1776
1777             while (entry) {
1778                 register HE * const oentry = entry;
1779                 entry = HeNEXT(entry);
1780                 hv_free_ent(hv, oentry);
1781             }
1782         } while (--i >= 0);
1783
1784         /* As there are no allocated pointers in the aux structure, it's now
1785            safe to free the array we just cleaned up, if it's not the one we're
1786            going to put back.  */
1787         if (array != orig_array) {
1788             Safefree(array);
1789         }
1790
1791         if (!HvARRAY(hv)) {
1792             /* Good. No-one added anything this time round.  */
1793             break;
1794         }
1795
1796         if (SvOOK(hv)) {
1797             /* Someone attempted to iterate or set the hash name while we had
1798                the array set to 0.  We'll catch backferences on the next time
1799                round the while loop.  */
1800             assert(HvARRAY(hv));
1801
1802             if (HvAUX(hv)->xhv_name) {
1803                 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1804             }
1805         }
1806
1807         if (--attempts == 0) {
1808             Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1809         }
1810     }
1811         
1812     HvARRAY(hv) = orig_array;
1813
1814     /* If the hash was actually a symbol table, put the name back.  */
1815     if (name) {
1816         /* We have restored the original array.  If name is non-NULL, then
1817            the original array had an aux structure at the end. So this is
1818            valid:  */
1819         SvFLAGS(hv) |= SVf_OOK;
1820         HvAUX(hv)->xhv_name = name;
1821     }
1822 }
1823
1824 /*
1825 =for apidoc hv_undef
1826
1827 Undefines the hash.
1828
1829 =cut
1830 */
1831
1832 void
1833 Perl_hv_undef(pTHX_ HV *hv)
1834 {
1835     dVAR;
1836     register XPVHV* xhv;
1837     const char *name;
1838
1839     if (!hv)
1840         return;
1841     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1842     xhv = (XPVHV*)SvANY(hv);
1843
1844     if ((name = HvNAME_get(hv)) && !PL_dirty)
1845         mro_isa_changed_in(hv);
1846
1847     hfreeentries(hv);
1848     if (name) {
1849         if (PL_stashcache)
1850             (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1851         hv_name_set(hv, NULL, 0, 0);
1852     }
1853     SvFLAGS(hv) &= ~SVf_OOK;
1854     Safefree(HvARRAY(hv));
1855     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1856     HvARRAY(hv) = 0;
1857     HvPLACEHOLDERS_set(hv, 0);
1858
1859     if (SvRMAGICAL(hv))
1860         mg_clear(MUTABLE_SV(hv));
1861 }
1862
1863 /*
1864 =for apidoc hv_fill
1865
1866 Returns the number of hash buckets that happen to be in use. This function is
1867 wrapped by the macro C<HvFILL>.
1868
1869 Previously this value was stored in the HV structure, rather than being
1870 calculated on demand.
1871
1872 =cut
1873 */
1874
1875 STRLEN
1876 Perl_hv_fill(pTHX_ HV const *const hv)
1877 {
1878     STRLEN count = 0;
1879     HE **ents = HvARRAY(hv);
1880
1881     PERL_ARGS_ASSERT_HV_FILL;
1882
1883     if (ents) {
1884         HE *const *const last = ents + HvMAX(hv);
1885         count = last + 1 - ents;
1886
1887         do {
1888             if (!*ents)
1889                 --count;
1890         } while (++ents <= last);
1891     }
1892     return count;
1893 }
1894
1895 static struct xpvhv_aux*
1896 S_hv_auxinit(HV *hv) {
1897     struct xpvhv_aux *iter;
1898     char *array;
1899
1900     PERL_ARGS_ASSERT_HV_AUXINIT;
1901
1902     if (!HvARRAY(hv)) {
1903         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1904             + sizeof(struct xpvhv_aux), char);
1905     } else {
1906         array = (char *) HvARRAY(hv);
1907         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1908               + sizeof(struct xpvhv_aux), char);
1909     }
1910     HvARRAY(hv) = (HE**) array;
1911     /* SvOOK_on(hv) attacks the IV flags.  */
1912     SvFLAGS(hv) |= SVf_OOK;
1913     iter = HvAUX(hv);
1914
1915     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1916     iter->xhv_eiter = NULL;     /* HvEITER(hv) = NULL */
1917     iter->xhv_name = 0;
1918     iter->xhv_backreferences = 0;
1919     iter->xhv_mro_meta = NULL;
1920     return iter;
1921 }
1922
1923 /*
1924 =for apidoc hv_iterinit
1925
1926 Prepares a starting point to traverse a hash table.  Returns the number of
1927 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1928 currently only meaningful for hashes without tie magic.
1929
1930 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1931 hash buckets that happen to be in use.  If you still need that esoteric
1932 value, you can get it through the macro C<HvFILL(tb)>.
1933
1934
1935 =cut
1936 */
1937
1938 I32
1939 Perl_hv_iterinit(pTHX_ HV *hv)
1940 {
1941     PERL_ARGS_ASSERT_HV_ITERINIT;
1942
1943     /* FIXME: Are we not NULL, or do we croak? Place bets now! */
1944
1945     if (!hv)
1946         Perl_croak(aTHX_ "Bad hash");
1947
1948     if (SvOOK(hv)) {
1949         struct xpvhv_aux * const iter = HvAUX(hv);
1950         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1951         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1952             HvLAZYDEL_off(hv);
1953             hv_free_ent(hv, entry);
1954         }
1955         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1956         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1957     } else {
1958         hv_auxinit(hv);
1959     }
1960
1961     /* used to be xhv->xhv_fill before 5.004_65 */
1962     return HvTOTALKEYS(hv);
1963 }
1964
1965 I32 *
1966 Perl_hv_riter_p(pTHX_ HV *hv) {
1967     struct xpvhv_aux *iter;
1968
1969     PERL_ARGS_ASSERT_HV_RITER_P;
1970
1971     if (!hv)
1972         Perl_croak(aTHX_ "Bad hash");
1973
1974     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1975     return &(iter->xhv_riter);
1976 }
1977
1978 HE **
1979 Perl_hv_eiter_p(pTHX_ HV *hv) {
1980     struct xpvhv_aux *iter;
1981
1982     PERL_ARGS_ASSERT_HV_EITER_P;
1983
1984     if (!hv)
1985         Perl_croak(aTHX_ "Bad hash");
1986
1987     iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
1988     return &(iter->xhv_eiter);
1989 }
1990
1991 void
1992 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1993     struct xpvhv_aux *iter;
1994
1995     PERL_ARGS_ASSERT_HV_RITER_SET;
1996
1997     if (!hv)
1998         Perl_croak(aTHX_ "Bad hash");
1999
2000     if (SvOOK(hv)) {
2001         iter = HvAUX(hv);
2002     } else {
2003         if (riter == -1)
2004             return;
2005
2006         iter = hv_auxinit(hv);
2007     }
2008     iter->xhv_riter = riter;
2009 }
2010
2011 void
2012 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2013     struct xpvhv_aux *iter;
2014
2015     PERL_ARGS_ASSERT_HV_EITER_SET;
2016
2017     if (!hv)
2018         Perl_croak(aTHX_ "Bad hash");
2019
2020     if (SvOOK(hv)) {
2021         iter = HvAUX(hv);
2022     } else {
2023         /* 0 is the default so don't go malloc()ing a new structure just to
2024            hold 0.  */
2025         if (!eiter)
2026             return;
2027
2028         iter = hv_auxinit(hv);
2029     }
2030     iter->xhv_eiter = eiter;
2031 }
2032
2033 void
2034 Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2035 {
2036     dVAR;
2037     struct xpvhv_aux *iter;
2038     U32 hash;
2039
2040     PERL_ARGS_ASSERT_HV_NAME_SET;
2041     PERL_UNUSED_ARG(flags);
2042
2043     if (len > I32_MAX)
2044         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2045
2046     if (SvOOK(hv)) {
2047         iter = HvAUX(hv);
2048         if (iter->xhv_name) {
2049             unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2050         }
2051     } else {
2052         if (name == 0)
2053             return;
2054
2055         iter = hv_auxinit(hv);
2056     }
2057     PERL_HASH(hash, name, len);
2058     iter->xhv_name = name ? share_hek(name, len, hash) : NULL;
2059 }
2060
2061 AV **
2062 Perl_hv_backreferences_p(pTHX_ HV *hv) {
2063     struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2064
2065     PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2066     PERL_UNUSED_CONTEXT;
2067
2068     return &(iter->xhv_backreferences);
2069 }
2070
2071 void
2072 Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2073     AV *av;
2074
2075     PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2076
2077     if (!SvOOK(hv))
2078         return;
2079
2080     av = HvAUX(hv)->xhv_backreferences;
2081
2082     if (av) {
2083         HvAUX(hv)->xhv_backreferences = 0;
2084         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2085         SvREFCNT_dec(av);
2086     }
2087 }
2088
2089 /*
2090 hv_iternext is implemented as a macro in hv.h
2091
2092 =for apidoc hv_iternext
2093
2094 Returns entries from a hash iterator.  See C<hv_iterinit>.
2095
2096 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2097 iterator currently points to, without losing your place or invalidating your
2098 iterator.  Note that in this case the current entry is deleted from the hash
2099 with your iterator holding the last reference to it.  Your iterator is flagged
2100 to free the entry on the next call to C<hv_iternext>, so you must not discard
2101 your iterator immediately else the entry will leak - call C<hv_iternext> to
2102 trigger the resource deallocation.
2103
2104 =for apidoc hv_iternext_flags
2105
2106 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
2107 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2108 set the placeholders keys (for restricted hashes) will be returned in addition
2109 to normal keys. By default placeholders are automatically skipped over.
2110 Currently a placeholder is implemented with a value that is
2111 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
2112 restricted hashes may change, and the implementation currently is
2113 insufficiently abstracted for any change to be tidy.
2114
2115 =cut
2116 */
2117
2118 HE *
2119 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2120 {
2121     dVAR;
2122     register XPVHV* xhv;
2123     register HE *entry;
2124     HE *oldentry;
2125     MAGIC* mg;
2126     struct xpvhv_aux *iter;
2127
2128     PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2129
2130     if (!hv)
2131         Perl_croak(aTHX_ "Bad hash");
2132
2133     xhv = (XPVHV*)SvANY(hv);
2134
2135     if (!SvOOK(hv)) {
2136         /* Too many things (well, pp_each at least) merrily assume that you can
2137            call iv_iternext without calling hv_iterinit, so we'll have to deal
2138            with it.  */
2139         hv_iterinit(hv);
2140     }
2141     iter = HvAUX(hv);
2142
2143     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2144     if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
2145         if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2146             SV * const key = sv_newmortal();
2147             if (entry) {
2148                 sv_setsv(key, HeSVKEY_force(entry));
2149                 SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
2150             }
2151             else {
2152                 char *k;
2153                 HEK *hek;
2154
2155                 /* one HE per MAGICAL hash */
2156                 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2157                 Zero(entry, 1, HE);
2158                 Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2159                 hek = (HEK*)k;
2160                 HeKEY_hek(entry) = hek;
2161                 HeKLEN(entry) = HEf_SVKEY;
2162             }
2163             magic_nextpack(MUTABLE_SV(hv),mg,key);
2164             if (SvOK(key)) {
2165                 /* force key to stay around until next time */
2166                 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2167                 return entry;               /* beware, hent_val is not set */
2168             }
2169             SvREFCNT_dec(HeVAL(entry));
2170             Safefree(HeKEY_hek(entry));
2171             del_HE(entry);
2172             iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2173             return NULL;
2174         }
2175     }
2176 #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
2177     if (!entry && SvRMAGICAL((const SV *)hv)
2178         && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2179         prime_env_iter();
2180 #ifdef VMS
2181         /* The prime_env_iter() on VMS just loaded up new hash values
2182          * so the iteration count needs to be reset back to the beginning
2183          */
2184         hv_iterinit(hv);
2185         iter = HvAUX(hv);
2186         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2187 #endif
2188     }
2189 #endif
2190
2191     /* hv_iterint now ensures this.  */
2192     assert (HvARRAY(hv));
2193
2194     /* At start of hash, entry is NULL.  */
2195     if (entry)
2196     {
2197         entry = HeNEXT(entry);
2198         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2199             /*
2200              * Skip past any placeholders -- don't want to include them in
2201              * any iteration.
2202              */
2203             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2204                 entry = HeNEXT(entry);
2205             }
2206         }
2207     }
2208
2209     /* Skip the entire loop if the hash is empty.   */
2210     if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
2211         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2212         while (!entry) {
2213             /* OK. Come to the end of the current list.  Grab the next one.  */
2214
2215             iter->xhv_riter++; /* HvRITER(hv)++ */
2216             if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2217                 /* There is no next one.  End of the hash.  */
2218                 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2219                 break;
2220             }
2221             entry = (HvARRAY(hv))[iter->xhv_riter];
2222
2223             if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2224                 /* If we have an entry, but it's a placeholder, don't count it.
2225                    Try the next.  */
2226                 while (entry && HeVAL(entry) == &PL_sv_placeholder)
2227                     entry = HeNEXT(entry);
2228             }
2229             /* Will loop again if this linked list starts NULL
2230                (for HV_ITERNEXT_WANTPLACEHOLDERS)
2231                or if we run through it and find only placeholders.  */
2232         }
2233     }
2234
2235     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2236         HvLAZYDEL_off(hv);
2237         hv_free_ent(hv, oldentry);
2238     }
2239
2240     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2241       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
2242
2243     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2244     return entry;
2245 }
2246
2247 /*
2248 =for apidoc hv_iterkey
2249
2250 Returns the key from the current position of the hash iterator.  See
2251 C<hv_iterinit>.
2252
2253 =cut
2254 */
2255
2256 char *
2257 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2258 {
2259     PERL_ARGS_ASSERT_HV_ITERKEY;
2260
2261     if (HeKLEN(entry) == HEf_SVKEY) {
2262         STRLEN len;
2263         char * const p = SvPV(HeKEY_sv(entry), len);
2264         *retlen = len;
2265         return p;
2266     }
2267     else {
2268         *retlen = HeKLEN(entry);
2269         return HeKEY(entry);
2270     }
2271 }
2272
2273 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2274 /*
2275 =for apidoc hv_iterkeysv
2276
2277 Returns the key as an C<SV*> from the current position of the hash
2278 iterator.  The return value will always be a mortal copy of the key.  Also
2279 see C<hv_iterinit>.
2280
2281 =cut
2282 */
2283
2284 SV *
2285 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2286 {
2287     PERL_ARGS_ASSERT_HV_ITERKEYSV;
2288
2289     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2290 }
2291
2292 /*
2293 =for apidoc hv_iterval
2294
2295 Returns the value from the current position of the hash iterator.  See
2296 C<hv_iterkey>.
2297
2298 =cut
2299 */
2300
2301 SV *
2302 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2303 {
2304     PERL_ARGS_ASSERT_HV_ITERVAL;
2305
2306     if (SvRMAGICAL(hv)) {
2307         if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2308             SV* const sv = sv_newmortal();
2309             if (HeKLEN(entry) == HEf_SVKEY)
2310                 mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2311             else
2312                 mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2313             return sv;
2314         }
2315     }
2316     return HeVAL(entry);
2317 }
2318
2319 /*
2320 =for apidoc hv_iternextsv
2321
2322 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2323 operation.
2324
2325 =cut
2326 */
2327
2328 SV *
2329 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2330 {
2331     HE * const he = hv_iternext_flags(hv, 0);
2332
2333     PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2334
2335     if (!he)
2336         return NULL;
2337     *key = hv_iterkey(he, retlen);
2338     return hv_iterval(hv, he);
2339 }
2340
2341 /*
2342
2343 Now a macro in hv.h
2344
2345 =for apidoc hv_magic
2346
2347 Adds magic to a hash.  See C<sv_magic>.
2348
2349 =cut
2350 */
2351
2352 /* possibly free a shared string if no one has access to it
2353  * len and hash must both be valid for str.
2354  */
2355 void
2356 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2357 {
2358     unshare_hek_or_pvn (NULL, str, len, hash);
2359 }
2360
2361
2362 void
2363 Perl_unshare_hek(pTHX_ HEK *hek)
2364 {
2365     assert(hek);
2366     unshare_hek_or_pvn(hek, NULL, 0, 0);
2367 }
2368
2369 /* possibly free a shared string if no one has access to it
2370    hek if non-NULL takes priority over the other 3, else str, len and hash
2371    are used.  If so, len and hash must both be valid for str.
2372  */
2373 STATIC void
2374 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2375 {
2376     dVAR;
2377     register XPVHV* xhv;
2378     HE *entry;
2379     register HE **oentry;
2380     HE **first;
2381     bool is_utf8 = FALSE;
2382     int k_flags = 0;
2383     const char * const save = str;
2384     struct shared_he *he = NULL;
2385
2386     if (hek) {
2387         /* Find the shared he which is just before us in memory.  */
2388         he = (struct shared_he *)(((char *)hek)
2389                                   - STRUCT_OFFSET(struct shared_he,
2390                                                   shared_he_hek));
2391
2392         /* Assert that the caller passed us a genuine (or at least consistent)
2393            shared hek  */
2394         assert (he->shared_he_he.hent_hek == hek);
2395
2396         if (he->shared_he_he.he_valu.hent_refcount - 1) {
2397             --he->shared_he_he.he_valu.hent_refcount;
2398             return;
2399         }
2400
2401         hash = HEK_HASH(hek);
2402     } else if (len < 0) {
2403         STRLEN tmplen = -len;
2404         is_utf8 = TRUE;
2405         /* See the note in hv_fetch(). --jhi */
2406         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2407         len = tmplen;
2408         if (is_utf8)
2409             k_flags = HVhek_UTF8;
2410         if (str != save)
2411             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2412     }
2413
2414     /* what follows was the moral equivalent of:
2415     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2416         if (--*Svp == NULL)
2417             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2418     } */
2419     xhv = (XPVHV*)SvANY(PL_strtab);
2420     /* assert(xhv_array != 0) */
2421     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2422     if (he) {
2423         const HE *const he_he = &(he->shared_he_he);
2424         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2425             if (entry == he_he)
2426                 break;
2427         }
2428     } else {
2429         const int flags_masked = k_flags & HVhek_MASK;
2430         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2431             if (HeHASH(entry) != hash)          /* strings can't be equal */
2432                 continue;
2433             if (HeKLEN(entry) != len)
2434                 continue;
2435             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2436                 continue;
2437             if (HeKFLAGS(entry) != flags_masked)
2438                 continue;
2439             break;
2440         }
2441     }
2442
2443     if (entry) {
2444         if (--entry->he_valu.hent_refcount == 0) {
2445             *oentry = HeNEXT(entry);
2446             Safefree(entry);
2447             xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2448         }
2449     }
2450
2451     if (!entry)
2452         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2453                          "Attempt to free non-existent shared string '%s'%s"
2454                          pTHX__FORMAT,
2455                          hek ? HEK_KEY(hek) : str,
2456                          ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2457     if (k_flags & HVhek_FREEKEY)
2458         Safefree(str);
2459 }
2460
2461 /* get a (constant) string ptr from the global string table
2462  * string will get added if it is not already there.
2463  * len and hash must both be valid for str.
2464  */
2465 HEK *
2466 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2467 {
2468     bool is_utf8 = FALSE;
2469     int flags = 0;
2470     const char * const save = str;
2471
2472     PERL_ARGS_ASSERT_SHARE_HEK;
2473
2474     if (len < 0) {
2475       STRLEN tmplen = -len;
2476       is_utf8 = TRUE;
2477       /* See the note in hv_fetch(). --jhi */
2478       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2479       len = tmplen;
2480       /* If we were able to downgrade here, then than means that we were passed
2481          in a key which only had chars 0-255, but was utf8 encoded.  */
2482       if (is_utf8)
2483           flags = HVhek_UTF8;
2484       /* If we found we were able to downgrade the string to bytes, then
2485          we should flag that it needs upgrading on keys or each.  Also flag
2486          that we need share_hek_flags to free the string.  */
2487       if (str != save)
2488           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2489     }
2490
2491     return share_hek_flags (str, len, hash, flags);
2492 }
2493
2494 STATIC HEK *
2495 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2496 {
2497     dVAR;
2498     register HE *entry;
2499     const int flags_masked = flags & HVhek_MASK;
2500     const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2501     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2502
2503     PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2504
2505     /* what follows is the moral equivalent of:
2506
2507     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2508         hv_store(PL_strtab, str, len, NULL, hash);
2509
2510         Can't rehash the shared string table, so not sure if it's worth
2511         counting the number of entries in the linked list
2512     */
2513
2514     /* assert(xhv_array != 0) */
2515     entry = (HvARRAY(PL_strtab))[hindex];
2516     for (;entry; entry = HeNEXT(entry)) {
2517         if (HeHASH(entry) != hash)              /* strings can't be equal */
2518             continue;
2519         if (HeKLEN(entry) != len)
2520             continue;
2521         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2522             continue;
2523         if (HeKFLAGS(entry) != flags_masked)
2524             continue;
2525         break;
2526     }
2527
2528     if (!entry) {
2529         /* What used to be head of the list.
2530            If this is NULL, then we're the first entry for this slot, which
2531            means we need to increate fill.  */
2532         struct shared_he *new_entry;
2533         HEK *hek;
2534         char *k;
2535         HE **const head = &HvARRAY(PL_strtab)[hindex];
2536         HE *const next = *head;
2537
2538         /* We don't actually store a HE from the arena and a regular HEK.
2539            Instead we allocate one chunk of memory big enough for both,
2540            and put the HEK straight after the HE. This way we can find the
2541            HEK directly from the HE.
2542         */
2543
2544         Newx(k, STRUCT_OFFSET(struct shared_he,
2545                                 shared_he_hek.hek_key[0]) + len + 2, char);
2546         new_entry = (struct shared_he *)k;
2547         entry = &(new_entry->shared_he_he);
2548         hek = &(new_entry->shared_he_hek);
2549
2550         Copy(str, HEK_KEY(hek), len, char);
2551         HEK_KEY(hek)[len] = 0;
2552         HEK_LEN(hek) = len;
2553         HEK_HASH(hek) = hash;
2554         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2555
2556         /* Still "point" to the HEK, so that other code need not know what
2557            we're up to.  */
2558         HeKEY_hek(entry) = hek;
2559         entry->he_valu.hent_refcount = 0;
2560         HeNEXT(entry) = next;
2561         *head = entry;
2562
2563         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2564         if (!next) {                    /* initial entry? */
2565         } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2566                 hsplit(PL_strtab);
2567         }
2568     }
2569
2570     ++entry->he_valu.hent_refcount;
2571
2572     if (flags & HVhek_FREEKEY)
2573         Safefree(str);
2574
2575     return HeKEY_hek(entry);
2576 }
2577
2578 I32 *
2579 Perl_hv_placeholders_p(pTHX_ HV *hv)
2580 {
2581     dVAR;
2582     MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2583
2584     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2585
2586     if (!mg) {
2587         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2588
2589         if (!mg) {
2590             Perl_die(aTHX_ "panic: hv_placeholders_p");
2591         }
2592     }
2593     return &(mg->mg_len);
2594 }
2595
2596
2597 I32
2598 Perl_hv_placeholders_get(pTHX_ const HV *hv)
2599 {
2600     dVAR;
2601     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2602
2603     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2604
2605     return mg ? mg->mg_len : 0;
2606 }
2607
2608 void
2609 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2610 {
2611     dVAR;
2612     MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2613
2614     PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2615
2616     if (mg) {
2617         mg->mg_len = ph;
2618     } else if (ph) {
2619         if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2620             Perl_die(aTHX_ "panic: hv_placeholders_set");
2621     }
2622     /* else we don't need to add magic to record 0 placeholders.  */
2623 }
2624
2625 STATIC SV *
2626 S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2627 {
2628     dVAR;
2629     SV *value;
2630
2631     PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2632
2633     switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2634     case HVrhek_undef:
2635         value = newSV(0);
2636         break;
2637     case HVrhek_delete:
2638         value = &PL_sv_placeholder;
2639         break;
2640     case HVrhek_IV:
2641         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2642         break;
2643     case HVrhek_UV:
2644         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2645         break;
2646     case HVrhek_PV:
2647     case HVrhek_PV_UTF8:
2648         /* Create a string SV that directly points to the bytes in our
2649            structure.  */
2650         value = newSV_type(SVt_PV);
2651         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2652         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2653         /* This stops anything trying to free it  */
2654         SvLEN_set(value, 0);
2655         SvPOK_on(value);
2656         SvREADONLY_on(value);
2657         if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2658             SvUTF8_on(value);
2659         break;
2660     default:
2661         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2662                    he->refcounted_he_data[0]);
2663     }
2664     return value;
2665 }
2666
2667 /*
2668 =for apidoc refcounted_he_chain_2hv
2669
2670 Generates and returns a C<HV *> by walking up the tree starting at the passed
2671 in C<struct refcounted_he *>.
2672
2673 =cut
2674 */
2675 HV *
2676 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2677 {
2678     dVAR;
2679     HV *hv = newHV();
2680     U32 placeholders = 0;
2681     /* We could chase the chain once to get an idea of the number of keys,
2682        and call ksplit.  But for now we'll make a potentially inefficient
2683        hash with only 8 entries in its array.  */
2684     const U32 max = HvMAX(hv);
2685
2686     if (!HvARRAY(hv)) {
2687         char *array;
2688         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2689         HvARRAY(hv) = (HE**)array;
2690     }
2691
2692     while (chain) {
2693 #ifdef USE_ITHREADS
2694         U32 hash = chain->refcounted_he_hash;
2695 #else
2696         U32 hash = HEK_HASH(chain->refcounted_he_hek);
2697 #endif
2698         HE **oentry = &((HvARRAY(hv))[hash & max]);
2699         HE *entry = *oentry;
2700         SV *value;
2701
2702         for (; entry; entry = HeNEXT(entry)) {
2703             if (HeHASH(entry) == hash) {
2704                 /* We might have a duplicate key here.  If so, entry is older
2705                    than the key we've already put in the hash, so if they are
2706                    the same, skip adding entry.  */
2707 #ifdef USE_ITHREADS
2708                 const STRLEN klen = HeKLEN(entry);
2709                 const char *const key = HeKEY(entry);
2710                 if (klen == chain->refcounted_he_keylen
2711                     && (!!HeKUTF8(entry)
2712                         == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2713                     && memEQ(key, REF_HE_KEY(chain), klen))
2714                     goto next_please;
2715 #else
2716                 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2717                     goto next_please;
2718                 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2719                     && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2720                     && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2721                              HeKLEN(entry)))
2722                     goto next_please;
2723 #endif
2724             }
2725         }
2726         assert (!entry);
2727         entry = new_HE();
2728
2729 #ifdef USE_ITHREADS
2730         HeKEY_hek(entry)
2731             = share_hek_flags(REF_HE_KEY(chain),
2732                               chain->refcounted_he_keylen,
2733                               chain->refcounted_he_hash,
2734                               (chain->refcounted_he_data[0]
2735                                & (HVhek_UTF8|HVhek_WASUTF8)));
2736 #else
2737         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
2738 #endif
2739         value = refcounted_he_value(chain);
2740         if (value == &PL_sv_placeholder)
2741             placeholders++;
2742         HeVAL(entry) = value;
2743
2744         /* Link it into the chain.  */
2745         HeNEXT(entry) = *oentry;
2746         *oentry = entry;
2747
2748         HvTOTALKEYS(hv)++;
2749
2750     next_please:
2751         chain = chain->refcounted_he_next;
2752     }
2753
2754     if (placeholders) {
2755         clear_placeholders(hv, placeholders);
2756         HvTOTALKEYS(hv) -= placeholders;
2757     }
2758
2759     /* We could check in the loop to see if we encounter any keys with key
2760        flags, but it's probably not worth it, as this per-hash flag is only
2761        really meant as an optimisation for things like Storable.  */
2762     HvHASKFLAGS_on(hv);
2763     DEBUG_A(Perl_hv_assert(aTHX_ hv));
2764
2765     return hv;
2766 }
2767
2768 SV *
2769 Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2770                          const char *key, STRLEN klen, int flags, U32 hash)
2771 {
2772     dVAR;
2773     /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2774        of your key has to exactly match that which is stored.  */
2775     SV *value = &PL_sv_placeholder;
2776
2777     if (chain) {
2778         /* No point in doing any of this if there's nothing to find.  */
2779         bool is_utf8;
2780
2781         if (keysv) {
2782             if (flags & HVhek_FREEKEY)
2783                 Safefree(key);
2784             key = SvPV_const(keysv, klen);
2785             flags = 0;
2786             is_utf8 = (SvUTF8(keysv) != 0);
2787         } else {
2788             is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
2789         }
2790
2791         if (!hash) {
2792             if (keysv && (SvIsCOW_shared_hash(keysv))) {
2793                 hash = SvSHARED_HASH(keysv);
2794             } else {
2795                 PERL_HASH(hash, key, klen);
2796             }
2797         }
2798
2799         for (; chain; chain = chain->refcounted_he_next) {
2800 #ifdef USE_ITHREADS
2801             if (hash != chain->refcounted_he_hash)
2802                 continue;
2803             if (klen != chain->refcounted_he_keylen)
2804                 continue;
2805             if (memNE(REF_HE_KEY(chain),key,klen))
2806                 continue;
2807             if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2808                 continue;
2809 #else
2810             if (hash != HEK_HASH(chain->refcounted_he_hek))
2811                 continue;
2812             if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
2813                 continue;
2814             if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2815                 continue;
2816             if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2817                 continue;
2818 #endif
2819
2820             value = sv_2mortal(refcounted_he_value(chain));
2821             break;
2822         }
2823     }
2824
2825     if (flags & HVhek_FREEKEY)
2826         Safefree(key);
2827
2828     return value;
2829 }
2830
2831 /*
2832 =for apidoc refcounted_he_new
2833
2834 Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2835 stored in a compact form, all references remain the property of the caller.
2836 The C<struct refcounted_he> is returned with a reference count of 1.
2837
2838 =cut
2839 */
2840
2841 struct refcounted_he *
2842 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2843                        SV *const key, SV *const value) {
2844     dVAR;
2845     STRLEN key_len;
2846     const char *key_p = SvPV_const(key, key_len);
2847     STRLEN value_len = 0;
2848     const char *value_p = NULL;
2849     char value_type;
2850     char flags;
2851     bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
2852
2853     if (SvPOK(value)) {
2854         value_type = HVrhek_PV;
2855     } else if (SvIOK(value)) {
2856         value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
2857     } else if (value == &PL_sv_placeholder) {
2858         value_type = HVrhek_delete;
2859     } else if (!SvOK(value)) {
2860         value_type = HVrhek_undef;
2861     } else {
2862         value_type = HVrhek_PV;
2863     }
2864
2865     if (value_type == HVrhek_PV) {
2866         /* Do it this way so that the SvUTF8() test is after the SvPV, in case
2867            the value is overloaded, and doesn't yet have the UTF-8flag set.  */
2868         value_p = SvPV_const(value, value_len);
2869         if (SvUTF8(value))
2870             value_type = HVrhek_PV_UTF8;
2871     }
2872     flags = value_type;
2873
2874     if (is_utf8) {
2875         /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2876            As we're going to be building hash keys from this value in future,
2877            normalise it now.  */
2878         key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2879         flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2880     }
2881
2882     return refcounted_he_new_common(parent, key_p, key_len, flags, value_type,
2883                                     ((value_type == HVrhek_PV
2884                                       || value_type == HVrhek_PV_UTF8) ?
2885                                      (void *)value_p : (void *)value),
2886                                     value_len);
2887 }
2888
2889 static struct refcounted_he *
2890 S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent,
2891                            const char *const key_p, const STRLEN key_len,
2892                            const char flags, char value_type,
2893                            const void *value, const STRLEN value_len) {
2894     dVAR;
2895     struct refcounted_he *he;
2896     U32 hash;
2897     const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8;
2898     STRLEN key_offset = is_pv ? value_len + 2 : 1;
2899
2900     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON;
2901
2902 #ifdef USE_ITHREADS
2903     he = (struct refcounted_he*)
2904         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2905                              + key_len
2906                              + key_offset);
2907 #else
2908     he = (struct refcounted_he*)
2909         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2910                              + key_offset);
2911 #endif
2912
2913     he->refcounted_he_next = parent;
2914
2915     if (is_pv) {
2916         Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char);
2917         he->refcounted_he_val.refcounted_he_u_len = value_len;
2918     } else if (value_type == HVrhek_IV) {
2919         he->refcounted_he_val.refcounted_he_u_iv = SvIVX((const SV *)value);
2920     } else if (value_type == HVrhek_UV) {
2921         he->refcounted_he_val.refcounted_he_u_uv = SvUVX((const SV *)value);
2922     }
2923
2924     PERL_HASH(hash, key_p, key_len);
2925
2926 #ifdef USE_ITHREADS
2927     he->refcounted_he_hash = hash;
2928     he->refcounted_he_keylen = key_len;
2929     Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
2930 #else
2931     he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
2932 #endif
2933
2934     if (flags & HVhek_WASUTF8) {
2935         /* If it was downgraded from UTF-8, then the pointer returned from
2936            bytes_from_utf8 is an allocated pointer that we must free.  */
2937         Safefree(key_p);
2938     }
2939
2940     he->refcounted_he_data[0] = flags;
2941     he->refcounted_he_refcnt = 1;
2942
2943     return he;
2944 }
2945
2946 /*
2947 =for apidoc refcounted_he_free
2948
2949 Decrements the reference count of the passed in C<struct refcounted_he *>
2950 by one. If the reference count reaches zero the structure's memory is freed,
2951 and C<refcounted_he_free> iterates onto the parent node.
2952
2953 =cut
2954 */
2955
2956 void
2957 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
2958     dVAR;
2959     PERL_UNUSED_CONTEXT;
2960
2961     while (he) {
2962         struct refcounted_he *copy;
2963         U32 new_count;
2964
2965         HINTS_REFCNT_LOCK;
2966         new_count = --he->refcounted_he_refcnt;
2967         HINTS_REFCNT_UNLOCK;
2968         
2969         if (new_count) {
2970             return;
2971         }
2972
2973 #ifndef USE_ITHREADS
2974         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
2975 #endif
2976         copy = he;
2977         he = he->refcounted_he_next;
2978         PerlMemShared_free(copy);
2979     }
2980 }
2981
2982 /* pp_entereval is aware that labels are stored with a key ':' at the top of
2983    the linked list.  */
2984 const char *
2985 Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len,
2986                      U32 *flags) {
2987     if (!chain)
2988         return NULL;
2989 #ifdef USE_ITHREADS
2990     if (chain->refcounted_he_keylen != 1)
2991         return NULL;
2992     if (*REF_HE_KEY(chain) != ':')
2993         return NULL;
2994 #else
2995     if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
2996         return NULL;
2997     if (*HEK_KEY(chain->refcounted_he_hek) != ':')
2998         return NULL;
2999 #endif
3000     /* Stop anyone trying to really mess us up by adding their own value for
3001        ':' into %^H  */
3002     if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3003         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3004         return NULL;
3005
3006     if (len)
3007         *len = chain->refcounted_he_val.refcounted_he_u_len;
3008     if (flags) {
3009         *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3010                   == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3011     }
3012     return chain->refcounted_he_data + 1;
3013 }
3014
3015 /* As newSTATEOP currently gets passed plain char* labels, we will only provide
3016    that interface. Once it works out how to pass in length and UTF-8 ness, this
3017    function will need superseding.  */
3018 struct refcounted_he *
3019 Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label)
3020 {
3021     PERL_ARGS_ASSERT_STORE_COP_LABEL;
3022
3023     return refcounted_he_new_common(chain, ":", 1, HVrhek_PV, HVrhek_PV,
3024                                     label, strlen(label));
3025 }
3026
3027 /*
3028 =for apidoc hv_assert
3029
3030 Check that a hash is in an internally consistent state.
3031
3032 =cut
3033 */
3034
3035 #ifdef DEBUGGING
3036
3037 void
3038 Perl_hv_assert(pTHX_ HV *hv)
3039 {
3040     dVAR;
3041     HE* entry;
3042     int withflags = 0;
3043     int placeholders = 0;
3044     int real = 0;
3045     int bad = 0;
3046     const I32 riter = HvRITER_get(hv);
3047     HE *eiter = HvEITER_get(hv);
3048
3049     PERL_ARGS_ASSERT_HV_ASSERT;
3050
3051     (void)hv_iterinit(hv);
3052
3053     while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3054         /* sanity check the values */
3055         if (HeVAL(entry) == &PL_sv_placeholder)
3056             placeholders++;
3057         else
3058             real++;
3059         /* sanity check the keys */
3060         if (HeSVKEY(entry)) {
3061             NOOP;   /* Don't know what to check on SV keys.  */
3062         } else if (HeKUTF8(entry)) {
3063             withflags++;
3064             if (HeKWASUTF8(entry)) {
3065                 PerlIO_printf(Perl_debug_log,
3066                             "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3067                             (int) HeKLEN(entry),  HeKEY(entry));
3068                 bad = 1;
3069             }
3070         } else if (HeKWASUTF8(entry))
3071             withflags++;
3072     }
3073     if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3074         static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3075         const int nhashkeys = HvUSEDKEYS(hv);
3076         const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3077
3078         if (nhashkeys != real) {
3079             PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3080             bad = 1;
3081         }
3082         if (nhashplaceholders != placeholders) {
3083             PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3084             bad = 1;
3085         }
3086     }
3087     if (withflags && ! HvHASKFLAGS(hv)) {
3088         PerlIO_printf(Perl_debug_log,
3089                     "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3090                     withflags);
3091         bad = 1;
3092     }
3093     if (bad) {
3094         sv_dump(MUTABLE_SV(hv));
3095     }
3096     HvRITER_set(hv, riter);             /* Restore hash iterator state */
3097     HvEITER_set(hv, eiter);
3098 }
3099
3100 #endif
3101
3102 /*
3103  * Local variables:
3104  * c-indentation-style: bsd
3105  * c-basic-offset: 4
3106  * indent-tabs-mode: t
3107  * End:
3108  *
3109  * ex: set ts=8 sts=4 sw=4 noet:
3110  */