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