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