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