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