Further yak-shaving on Pod::Usage. Now, t/pod/pod2usage2.t tests
[perl.git] / hv.c
1 /*    hv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, 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     HE* he;
43     HE* heend;
44     Newx(he, PERL_ARENA_SIZE/sizeof(HE), HE);
45     HeNEXT(he) = (HE*) PL_body_arenaroots[HE_SVSLOT];
46     PL_body_arenaroots[HE_SVSLOT] = he;
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     HE* he;
68     void ** const root = &PL_body_roots[HE_SVSLOT];
69
70     LOCK_SV_MUTEX;
71     if (!*root)
72         S_more_he(aTHX);
73     he = *root;
74     *root = HeNEXT(he);
75     UNLOCK_SV_MUTEX;
76     return he;
77 }
78
79 #define new_HE() new_he()
80 #define del_HE(p) \
81     STMT_START { \
82         LOCK_SV_MUTEX; \
83         HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]);    \
84         PL_body_roots[HE_SVSLOT] = p; \
85         UNLOCK_SV_MUTEX; \
86     } STMT_END
87
88
89
90 #endif
91
92 STATIC HEK *
93 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
94 {
95     const int flags_masked = flags & HVhek_MASK;
96     char *k;
97     register HEK *hek;
98
99     Newx(k, HEK_BASESIZE + len + 2, char);
100     hek = (HEK*)k;
101     Copy(str, HEK_KEY(hek), len, char);
102     HEK_KEY(hek)[len] = 0;
103     HEK_LEN(hek) = len;
104     HEK_HASH(hek) = hash;
105     HEK_FLAGS(hek) = (unsigned char)flags_masked;
106
107     if (flags & HVhek_FREEKEY)
108         Safefree(str);
109     return hek;
110 }
111
112 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
113  * for tied hashes */
114
115 void
116 Perl_free_tied_hv_pool(pTHX)
117 {
118     HE *he = PL_hv_fetch_ent_mh;
119     while (he) {
120         HE * const ohe = he;
121         Safefree(HeKEY_hek(he));
122         he = HeNEXT(he);
123         del_HE(ohe);
124     }
125     PL_hv_fetch_ent_mh = Nullhe;
126 }
127
128 #if defined(USE_ITHREADS)
129 HEK *
130 Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
131 {
132     HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
133
134     PERL_UNUSED_ARG(param);
135
136     if (shared) {
137         /* We already shared this hash key.  */
138         (void)share_hek_hek(shared);
139     }
140     else {
141         shared
142             = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
143                               HEK_HASH(source), HEK_FLAGS(source));
144         ptr_table_store(PL_ptr_table, source, shared);
145     }
146     return shared;
147 }
148
149 HE *
150 Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
151 {
152     HE *ret;
153
154     if (!e)
155         return Nullhe;
156     /* look for it in the table first */
157     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
158     if (ret)
159         return ret;
160
161     /* create anew and remember what it is */
162     ret = new_HE();
163     ptr_table_store(PL_ptr_table, e, ret);
164
165     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
166     if (HeKLEN(e) == HEf_SVKEY) {
167         char *k;
168         Newx(k, HEK_BASESIZE + sizeof(SV*), char);
169         HeKEY_hek(ret) = (HEK*)k;
170         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
171     }
172     else if (shared) {
173         /* This is hek_dup inlined, which seems to be important for speed
174            reasons.  */
175         HEK * const source = HeKEY_hek(e);
176         HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
177
178         if (shared) {
179             /* We already shared this hash key.  */
180             (void)share_hek_hek(shared);
181         }
182         else {
183             shared
184                 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
185                                   HEK_HASH(source), HEK_FLAGS(source));
186             ptr_table_store(PL_ptr_table, source, shared);
187         }
188         HeKEY_hek(ret) = shared;
189     }
190     else
191         HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
192                                         HeKFLAGS(e));
193     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
194     return ret;
195 }
196 #endif  /* USE_ITHREADS */
197
198 static void
199 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
200                 const char *msg)
201 {
202     SV * const sv = sv_newmortal();
203     if (!(flags & HVhek_FREEKEY)) {
204         sv_setpvn(sv, key, klen);
205     }
206     else {
207         /* Need to free saved eventually assign to mortal SV */
208         /* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
209         sv_usepvn(sv, (char *) key, klen);
210     }
211     if (flags & HVhek_UTF8) {
212         SvUTF8_on(sv);
213     }
214     Perl_croak(aTHX_ msg, sv);
215 }
216
217 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
218  * contains an SV* */
219
220 #define HV_FETCH_ISSTORE   0x01
221 #define HV_FETCH_ISEXISTS  0x02
222 #define HV_FETCH_LVALUE    0x04
223 #define HV_FETCH_JUST_SV   0x08
224
225 /*
226 =for apidoc hv_store
227
228 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
229 the length of the key.  The C<hash> parameter is the precomputed hash
230 value; if it is zero then Perl will compute it.  The return value will be
231 NULL if the operation failed or if the value did not need to be actually
232 stored within the hash (as in the case of tied hashes).  Otherwise it can
233 be dereferenced to get the original C<SV*>.  Note that the caller is
234 responsible for suitably incrementing the reference count of C<val> before
235 the call, and decrementing it if the function returned NULL.  Effectively
236 a successful hv_store takes ownership of one reference to C<val>.  This is
237 usually what you want; a newly created SV has a reference count of one, so
238 if all your code does is create SVs then store them in a hash, hv_store
239 will own the only reference to the new SV, and your code doesn't need to do
240 anything further to tidy up.  hv_store is not implemented as a call to
241 hv_store_ent, and does not create a temporary SV for the key, so if your
242 key data is not already in SV form then use hv_store in preference to
243 hv_store_ent.
244
245 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
246 information on how to use this function on tied hashes.
247
248 =cut
249 */
250
251 SV**
252 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
253 {
254     HE *hek;
255     STRLEN klen;
256     int flags;
257
258     if (klen_i32 < 0) {
259         klen = -klen_i32;
260         flags = HVhek_UTF8;
261     } else {
262         klen = klen_i32;
263         flags = 0;
264     }
265     hek = hv_fetch_common (hv, NULL, key, klen, flags,
266                            (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
267     return hek ? &HeVAL(hek) : NULL;
268 }
269
270 SV**
271 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
272                  register U32 hash, int flags)
273 {
274     HE * const hek = hv_fetch_common (hv, NULL, key, klen, flags,
275                                (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
276     return hek ? &HeVAL(hek) : NULL;
277 }
278
279 /*
280 =for apidoc hv_store_ent
281
282 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
283 parameter is the precomputed hash value; if it is zero then Perl will
284 compute it.  The return value is the new hash entry so created.  It will be
285 NULL if the operation failed or if the value did not need to be actually
286 stored within the hash (as in the case of tied hashes).  Otherwise the
287 contents of the return value can be accessed using the C<He?> macros
288 described here.  Note that the caller is responsible for suitably
289 incrementing the reference count of C<val> before the call, and
290 decrementing it if the function returned NULL.  Effectively a successful
291 hv_store_ent takes ownership of one reference to C<val>.  This is
292 usually what you want; a newly created SV has a reference count of one, so
293 if all your code does is create SVs then store them in a hash, hv_store
294 will own the only reference to the new SV, and your code doesn't need to do
295 anything further to tidy up.  Note that hv_store_ent only reads the C<key>;
296 unlike C<val> it does not take ownership of it, so maintaining the correct
297 reference count on C<key> is entirely the caller's responsibility.  hv_store
298 is not implemented as a call to hv_store_ent, and does not create a temporary
299 SV for the key, so if your key data is not already in SV form then use
300 hv_store in preference to hv_store_ent.
301
302 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
303 information on how to use this function on tied hashes.
304
305 =cut
306 */
307
308 HE *
309 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
310 {
311   return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
312 }
313
314 /*
315 =for apidoc hv_exists
316
317 Returns a boolean indicating whether the specified hash key exists.  The
318 C<klen> is the length of the key.
319
320 =cut
321 */
322
323 bool
324 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
325 {
326     STRLEN klen;
327     int flags;
328
329     if (klen_i32 < 0) {
330         klen = -klen_i32;
331         flags = HVhek_UTF8;
332     } else {
333         klen = klen_i32;
334         flags = 0;
335     }
336     return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
337         ? TRUE : FALSE;
338 }
339
340 /*
341 =for apidoc hv_fetch
342
343 Returns the SV which corresponds to the specified key in the hash.  The
344 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
345 part of a store.  Check that the return value is non-null before
346 dereferencing it to an C<SV*>.
347
348 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
349 information on how to use this function on tied hashes.
350
351 =cut
352 */
353
354 SV**
355 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
356 {
357     HE *hek;
358     STRLEN klen;
359     int flags;
360
361     if (klen_i32 < 0) {
362         klen = -klen_i32;
363         flags = HVhek_UTF8;
364     } else {
365         klen = klen_i32;
366         flags = 0;
367     }
368     hek = hv_fetch_common (hv, NULL, key, klen, flags,
369                            HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0),
370                            Nullsv, 0);
371     return hek ? &HeVAL(hek) : NULL;
372 }
373
374 /*
375 =for apidoc hv_exists_ent
376
377 Returns a boolean indicating whether the specified hash key exists. C<hash>
378 can be a valid precomputed hash value, or 0 to ask for it to be
379 computed.
380
381 =cut
382 */
383
384 bool
385 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
386 {
387     return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
388         ? TRUE : FALSE;
389 }
390
391 /* returns an HE * structure with the all fields set */
392 /* note that hent_val will be a mortal sv for MAGICAL hashes */
393 /*
394 =for apidoc hv_fetch_ent
395
396 Returns the hash entry which corresponds to the specified key in the hash.
397 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
398 if you want the function to compute it.  IF C<lval> is set then the fetch
399 will be part of a store.  Make sure the return value is non-null before
400 accessing it.  The return value when C<tb> is a tied hash is a pointer to a
401 static location, so be sure to make a copy of the structure if you need to
402 store it somewhere.
403
404 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
405 information on how to use this function on tied hashes.
406
407 =cut
408 */
409
410 HE *
411 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
412 {
413     return hv_fetch_common(hv, keysv, NULL, 0, 0, 
414                            (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
415 }
416
417 STATIC HE *
418 S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
419                   int flags, int action, SV *val, register U32 hash)
420 {
421     dVAR;
422     XPVHV* xhv;
423     HE *entry;
424     HE **oentry;
425     SV *sv;
426     bool is_utf8;
427     int masked_flags;
428
429     if (!hv)
430         return 0;
431
432     if (keysv) {
433         if (flags & HVhek_FREEKEY)
434             Safefree(key);
435         key = SvPV_const(keysv, klen);
436         flags = 0;
437         is_utf8 = (SvUTF8(keysv) != 0);
438     } else {
439         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
440     }
441
442     xhv = (XPVHV*)SvANY(hv);
443     if (SvMAGICAL(hv)) {
444         if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
445           {
446             if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
447                 sv = sv_newmortal();
448
449                 /* XXX should be able to skimp on the HE/HEK here when
450                    HV_FETCH_JUST_SV is true.  */
451
452                 if (!keysv) {
453                     keysv = newSVpvn(key, klen);
454                     if (is_utf8) {
455                         SvUTF8_on(keysv);
456                     }
457                 } else {
458                     keysv = newSVsv(keysv);
459                 }
460                 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
461
462                 /* grab a fake HE/HEK pair from the pool or make a new one */
463                 entry = PL_hv_fetch_ent_mh;
464                 if (entry)
465                     PL_hv_fetch_ent_mh = HeNEXT(entry);
466                 else {
467                     char *k;
468                     entry = new_HE();
469                     Newx(k, HEK_BASESIZE + sizeof(SV*), char);
470                     HeKEY_hek(entry) = (HEK*)k;
471                 }
472                 HeNEXT(entry) = Nullhe;
473                 HeSVKEY_set(entry, keysv);
474                 HeVAL(entry) = sv;
475                 sv_upgrade(sv, SVt_PVLV);
476                 LvTYPE(sv) = 'T';
477                  /* so we can free entry when freeing sv */
478                 LvTARG(sv) = (SV*)entry;
479
480                 /* XXX remove at some point? */
481                 if (flags & HVhek_FREEKEY)
482                     Safefree(key);
483
484                 return entry;
485             }
486 #ifdef ENV_IS_CASELESS
487             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
488                 U32 i;
489                 for (i = 0; i < klen; ++i)
490                     if (isLOWER(key[i])) {
491                         /* Would be nice if we had a routine to do the
492                            copy and upercase in a single pass through.  */
493                         const char * const nkey = strupr(savepvn(key,klen));
494                         /* Note that this fetch is for nkey (the uppercased
495                            key) whereas the store is for key (the original)  */
496                         entry = hv_fetch_common(hv, Nullsv, nkey, klen,
497                                                 HVhek_FREEKEY, /* free nkey */
498                                                 0 /* non-LVAL fetch */,
499                                                 Nullsv /* no value */,
500                                                 0 /* compute hash */);
501                         if (!entry && (action & HV_FETCH_LVALUE)) {
502                             /* This call will free key if necessary.
503                                Do it this way to encourage compiler to tail
504                                call optimise.  */
505                             entry = hv_fetch_common(hv, keysv, key, klen,
506                                                     flags, HV_FETCH_ISSTORE,
507                                                     NEWSV(61,0), hash);
508                         } else {
509                             if (flags & HVhek_FREEKEY)
510                                 Safefree(key);
511                         }
512                         return entry;
513                     }
514             }
515 #endif
516         } /* ISFETCH */
517         else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
518             if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
519                 /* I don't understand why hv_exists_ent has svret and sv,
520                    whereas hv_exists only had one.  */
521                 SV * const svret = sv_newmortal();
522                 sv = sv_newmortal();
523
524                 if (keysv || is_utf8) {
525                     if (!keysv) {
526                         keysv = newSVpvn(key, klen);
527                         SvUTF8_on(keysv);
528                     } else {
529                         keysv = newSVsv(keysv);
530                     }
531                     mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
532                 } else {
533                     mg_copy((SV*)hv, sv, key, klen);
534                 }
535                 if (flags & HVhek_FREEKEY)
536                     Safefree(key);
537                 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
538                 /* This cast somewhat evil, but I'm merely using NULL/
539                    not NULL to return the boolean exists.
540                    And I know hv is not NULL.  */
541                 return SvTRUE(svret) ? (HE *)hv : NULL;
542                 }
543 #ifdef ENV_IS_CASELESS
544             else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
545                 /* XXX This code isn't UTF8 clean.  */
546                 char * const keysave = (char * const)key;
547                 /* Will need to free this, so set FREEKEY flag.  */
548                 key = savepvn(key,klen);
549                 key = (const char*)strupr((char*)key);
550                 is_utf8 = 0;
551                 hash = 0;
552                 keysv = 0;
553
554                 if (flags & HVhek_FREEKEY) {
555                     Safefree(keysave);
556                 }
557                 flags |= HVhek_FREEKEY;
558             }
559 #endif
560         } /* ISEXISTS */
561         else if (action & HV_FETCH_ISSTORE) {
562             bool needs_copy;
563             bool needs_store;
564             hv_magic_check (hv, &needs_copy, &needs_store);
565             if (needs_copy) {
566                 const bool save_taint = PL_tainted;
567                 if (keysv || is_utf8) {
568                     if (!keysv) {
569                         keysv = newSVpvn(key, klen);
570                         SvUTF8_on(keysv);
571                     }
572                     if (PL_tainting)
573                         PL_tainted = SvTAINTED(keysv);
574                     keysv = sv_2mortal(newSVsv(keysv));
575                     mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
576                 } else {
577                     mg_copy((SV*)hv, val, key, klen);
578                 }
579
580                 TAINT_IF(save_taint);
581                 if (!HvARRAY(hv) && !needs_store) {
582                     if (flags & HVhek_FREEKEY)
583                         Safefree(key);
584                     return Nullhe;
585                 }
586 #ifdef ENV_IS_CASELESS
587                 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
588                     /* XXX This code isn't UTF8 clean.  */
589                     const char *keysave = key;
590                     /* Will need to free this, so set FREEKEY flag.  */
591                     key = savepvn(key,klen);
592                     key = (const char*)strupr((char*)key);
593                     is_utf8 = 0;
594                     hash = 0;
595                     keysv = 0;
596
597                     if (flags & HVhek_FREEKEY) {
598                         Safefree(keysave);
599                     }
600                     flags |= HVhek_FREEKEY;
601                 }
602 #endif
603             }
604         } /* ISSTORE */
605     } /* SvMAGICAL */
606
607     if (!HvARRAY(hv)) {
608         if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
609 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
610                  || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
611 #endif
612                                                                   ) {
613             char *array;
614             Newxz(array,
615                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
616                  char);
617             HvARRAY(hv) = (HE**)array;
618         }
619 #ifdef DYNAMIC_ENV_FETCH
620         else if (action & HV_FETCH_ISEXISTS) {
621             /* for an %ENV exists, if we do an insert it's by a recursive
622                store call, so avoid creating HvARRAY(hv) right now.  */
623         }
624 #endif
625         else {
626             /* XXX remove at some point? */
627             if (flags & HVhek_FREEKEY)
628                 Safefree(key);
629
630             return 0;
631         }
632     }
633
634     if (is_utf8) {
635         char * const keysave = (char * const)key;
636         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
637         if (is_utf8)
638             flags |= HVhek_UTF8;
639         else
640             flags &= ~HVhek_UTF8;
641         if (key != keysave) {
642             if (flags & HVhek_FREEKEY)
643                 Safefree(keysave);
644             flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
645         }
646     }
647
648     if (HvREHASH(hv)) {
649         PERL_HASH_INTERNAL(hash, key, klen);
650         /* We don't have a pointer to the hv, so we have to replicate the
651            flag into every HEK, so that hv_iterkeysv can see it.  */
652         /* And yes, you do need this even though you are not "storing" because
653            you can flip the flags below if doing an lval lookup.  (And that
654            was put in to give the semantics Andreas was expecting.)  */
655         flags |= HVhek_REHASH;
656     } else if (!hash) {
657         if (keysv && (SvIsCOW_shared_hash(keysv))) {
658             hash = SvSHARED_HASH(keysv);
659         } else {
660             PERL_HASH(hash, key, klen);
661         }
662     }
663
664     masked_flags = (flags & HVhek_MASK);
665
666 #ifdef DYNAMIC_ENV_FETCH
667     if (!HvARRAY(hv)) entry = Null(HE*);
668     else
669 #endif
670     {
671         entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
672     }
673     for (; entry; entry = HeNEXT(entry)) {
674         if (HeHASH(entry) != hash)              /* strings can't be equal */
675             continue;
676         if (HeKLEN(entry) != (I32)klen)
677             continue;
678         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
679             continue;
680         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
681             continue;
682
683         if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
684             if (HeKFLAGS(entry) != masked_flags) {
685                 /* We match if HVhek_UTF8 bit in our flags and hash key's
686                    match.  But if entry was set previously with HVhek_WASUTF8
687                    and key now doesn't (or vice versa) then we should change
688                    the key's flag, as this is assignment.  */
689                 if (HvSHAREKEYS(hv)) {
690                     /* Need to swap the key we have for a key with the flags we
691                        need. As keys are shared we can't just write to the
692                        flag, so we share the new one, unshare the old one.  */
693                     HEK *new_hek = share_hek_flags(key, klen, hash,
694                                                    masked_flags);
695                     unshare_hek (HeKEY_hek(entry));
696                     HeKEY_hek(entry) = new_hek;
697                 }
698                 else if (hv == PL_strtab) {
699                     /* PL_strtab is usually the only hash without HvSHAREKEYS,
700                        so putting this test here is cheap  */
701                     if (flags & HVhek_FREEKEY)
702                         Safefree(key);
703                     Perl_croak(aTHX_ S_strtab_error,
704                                action & HV_FETCH_LVALUE ? "fetch" : "store");
705                 }
706                 else
707                     HeKFLAGS(entry) = masked_flags;
708                 if (masked_flags & HVhek_ENABLEHVKFLAGS)
709                     HvHASKFLAGS_on(hv);
710             }
711             if (HeVAL(entry) == &PL_sv_placeholder) {
712                 /* yes, can store into placeholder slot */
713                 if (action & HV_FETCH_LVALUE) {
714                     if (SvMAGICAL(hv)) {
715                         /* This preserves behaviour with the old hv_fetch
716                            implementation which at this point would bail out
717                            with a break; (at "if we find a placeholder, we
718                            pretend we haven't found anything")
719
720                            That break mean that if a placeholder were found, it
721                            caused a call into hv_store, which in turn would
722                            check magic, and if there is no magic end up pretty
723                            much back at this point (in hv_store's code).  */
724                         break;
725                     }
726                     /* LVAL fetch which actaully needs a store.  */
727                     val = NEWSV(61,0);
728                     HvPLACEHOLDERS(hv)--;
729                 } else {
730                     /* store */
731                     if (val != &PL_sv_placeholder)
732                         HvPLACEHOLDERS(hv)--;
733                 }
734                 HeVAL(entry) = val;
735             } else if (action & HV_FETCH_ISSTORE) {
736                 SvREFCNT_dec(HeVAL(entry));
737                 HeVAL(entry) = val;
738             }
739         } else if (HeVAL(entry) == &PL_sv_placeholder) {
740             /* if we find a placeholder, we pretend we haven't found
741                anything */
742             break;
743         }
744         if (flags & HVhek_FREEKEY)
745             Safefree(key);
746         return entry;
747     }
748 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
749     if (!(action & HV_FETCH_ISSTORE) 
750         && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
751         unsigned long len;
752         const char * const env = PerlEnv_ENVgetenv_len(key,&len);
753         if (env) {
754             sv = newSVpvn(env,len);
755             SvTAINTED_on(sv);
756             return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
757                                    hash);
758         }
759     }
760 #endif
761
762     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
763         S_hv_notallowed(aTHX_ flags, key, klen,
764                         "Attempt to access disallowed key '%"SVf"' in"
765                         " a restricted hash");
766     }
767     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
768         /* Not doing some form of store, so return failure.  */
769         if (flags & HVhek_FREEKEY)
770             Safefree(key);
771         return 0;
772     }
773     if (action & HV_FETCH_LVALUE) {
774         val = NEWSV(61,0);
775         if (SvMAGICAL(hv)) {
776             /* At this point the old hv_fetch code would call to hv_store,
777                which in turn might do some tied magic. So we need to make that
778                magic check happen.  */
779             /* gonna assign to this, so it better be there */
780             return hv_fetch_common(hv, keysv, key, klen, flags,
781                                    HV_FETCH_ISSTORE, val, hash);
782             /* XXX Surely that could leak if the fetch-was-store fails?
783                Just like the hv_fetch.  */
784         }
785     }
786
787     /* Welcome to hv_store...  */
788
789     if (!HvARRAY(hv)) {
790         /* Not sure if we can get here.  I think the only case of oentry being
791            NULL is for %ENV with dynamic env fetch.  But that should disappear
792            with magic in the previous code.  */
793         char *array;
794         Newxz(array,
795              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
796              char);
797         HvARRAY(hv) = (HE**)array;
798     }
799
800     oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
801
802     entry = new_HE();
803     /* share_hek_flags will do the free for us.  This might be considered
804        bad API design.  */
805     if (HvSHAREKEYS(hv))
806         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
807     else if (hv == PL_strtab) {
808         /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
809            this test here is cheap  */
810         if (flags & HVhek_FREEKEY)
811             Safefree(key);
812         Perl_croak(aTHX_ S_strtab_error,
813                    action & HV_FETCH_LVALUE ? "fetch" : "store");
814     }
815     else                                       /* gotta do the real thing */
816         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
817     HeVAL(entry) = val;
818     HeNEXT(entry) = *oentry;
819     *oentry = entry;
820
821     if (val == &PL_sv_placeholder)
822         HvPLACEHOLDERS(hv)++;
823     if (masked_flags & HVhek_ENABLEHVKFLAGS)
824         HvHASKFLAGS_on(hv);
825
826     {
827         const HE *counter = HeNEXT(entry);
828
829         xhv->xhv_keys++; /* HvKEYS(hv)++ */
830         if (!counter) {                         /* initial entry? */
831             xhv->xhv_fill++; /* HvFILL(hv)++ */
832         } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
833             hsplit(hv);
834         } else if(!HvREHASH(hv)) {
835             U32 n_links = 1;
836
837             while ((counter = HeNEXT(counter)))
838                 n_links++;
839
840             if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
841                 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
842                    bucket splits on a rehashed hash, as we're not going to
843                    split it again, and if someone is lucky (evil) enough to
844                    get all the keys in one list they could exhaust our memory
845                    as we repeatedly double the number of buckets on every
846                    entry. Linear search feels a less worse thing to do.  */
847                 hsplit(hv);
848             }
849         }
850     }
851
852     return entry;
853 }
854
855 STATIC void
856 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
857 {
858     const MAGIC *mg = SvMAGIC(hv);
859     *needs_copy = FALSE;
860     *needs_store = TRUE;
861     while (mg) {
862         if (isUPPER(mg->mg_type)) {
863             *needs_copy = TRUE;
864             if (mg->mg_type == PERL_MAGIC_tied) {
865                 *needs_store = FALSE;
866                 return; /* We've set all there is to set. */
867             }
868         }
869         mg = mg->mg_moremagic;
870     }
871 }
872
873 /*
874 =for apidoc hv_scalar
875
876 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
877
878 =cut
879 */
880
881 SV *
882 Perl_hv_scalar(pTHX_ HV *hv)
883 {
884     SV *sv;
885
886     if (SvRMAGICAL(hv)) {
887         MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
888         if (mg)
889             return magic_scalarpack(hv, mg);
890     }
891
892     sv = sv_newmortal();
893     if (HvFILL((HV*)hv)) 
894         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
895                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
896     else
897         sv_setiv(sv, 0);
898     
899     return sv;
900 }
901
902 /*
903 =for apidoc hv_delete
904
905 Deletes a key/value pair in the hash.  The value SV is removed from the
906 hash and returned to the caller.  The C<klen> is the length of the key.
907 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
908 will be returned.
909
910 =cut
911 */
912
913 SV *
914 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
915 {
916     STRLEN klen;
917     int k_flags = 0;
918
919     if (klen_i32 < 0) {
920         klen = -klen_i32;
921         k_flags |= HVhek_UTF8;
922     } else {
923         klen = klen_i32;
924     }
925     return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
926 }
927
928 /*
929 =for apidoc hv_delete_ent
930
931 Deletes a key/value pair in the hash.  The value SV is removed from the
932 hash and returned to the caller.  The C<flags> value will normally be zero;
933 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
934 precomputed hash value, or 0 to ask for it to be computed.
935
936 =cut
937 */
938
939 SV *
940 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
941 {
942     return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
943 }
944
945 STATIC SV *
946 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
947                    int k_flags, I32 d_flags, U32 hash)
948 {
949     dVAR;
950     register XPVHV* xhv;
951     register HE *entry;
952     register HE **oentry;
953     HE *const *first_entry;
954     SV *sv;
955     bool is_utf8;
956     int masked_flags;
957
958     if (!hv)
959         return Nullsv;
960
961     if (keysv) {
962         if (k_flags & HVhek_FREEKEY)
963             Safefree(key);
964         key = SvPV_const(keysv, klen);
965         k_flags = 0;
966         is_utf8 = (SvUTF8(keysv) != 0);
967     } else {
968         is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
969     }
970
971     if (SvRMAGICAL(hv)) {
972         bool needs_copy;
973         bool needs_store;
974         hv_magic_check (hv, &needs_copy, &needs_store);
975
976         if (needs_copy) {
977             entry = hv_fetch_common(hv, keysv, key, klen,
978                                     k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
979                                     Nullsv, hash);
980             sv = entry ? HeVAL(entry) : NULL;
981             if (sv) {
982                 if (SvMAGICAL(sv)) {
983                     mg_clear(sv);
984                 }
985                 if (!needs_store) {
986                     if (mg_find(sv, PERL_MAGIC_tiedelem)) {
987                         /* No longer an element */
988                         sv_unmagic(sv, PERL_MAGIC_tiedelem);
989                         return sv;
990                     }           
991                     return Nullsv;              /* element cannot be deleted */
992                 }
993 #ifdef ENV_IS_CASELESS
994                 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
995                     /* XXX This code isn't UTF8 clean.  */
996                     keysv = sv_2mortal(newSVpvn(key,klen));
997                     if (k_flags & HVhek_FREEKEY) {
998                         Safefree(key);
999                     }
1000                     key = strupr(SvPVX(keysv));
1001                     is_utf8 = 0;
1002                     k_flags = 0;
1003                     hash = 0;
1004                 }
1005 #endif
1006             }
1007         }
1008     }
1009     xhv = (XPVHV*)SvANY(hv);
1010     if (!HvARRAY(hv))
1011         return Nullsv;
1012
1013     if (is_utf8) {
1014         const char *keysave = key;
1015         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1016
1017         if (is_utf8)
1018             k_flags |= HVhek_UTF8;
1019         else
1020             k_flags &= ~HVhek_UTF8;
1021         if (key != keysave) {
1022             if (k_flags & HVhek_FREEKEY) {
1023                 /* This shouldn't happen if our caller does what we expect,
1024                    but strictly the API allows it.  */
1025                 Safefree(keysave);
1026             }
1027             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1028         }
1029         HvHASKFLAGS_on((SV*)hv);
1030     }
1031
1032     if (HvREHASH(hv)) {
1033         PERL_HASH_INTERNAL(hash, key, klen);
1034     } else if (!hash) {
1035         if (keysv && (SvIsCOW_shared_hash(keysv))) {
1036             hash = SvSHARED_HASH(keysv);
1037         } else {
1038             PERL_HASH(hash, key, klen);
1039         }
1040     }
1041
1042     masked_flags = (k_flags & HVhek_MASK);
1043
1044     first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1045     entry = *oentry;
1046     for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1047         if (HeHASH(entry) != hash)              /* strings can't be equal */
1048             continue;
1049         if (HeKLEN(entry) != (I32)klen)
1050             continue;
1051         if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
1052             continue;
1053         if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1054             continue;
1055
1056         if (hv == PL_strtab) {
1057             if (k_flags & HVhek_FREEKEY)
1058                 Safefree(key);
1059             Perl_croak(aTHX_ S_strtab_error, "delete");
1060         }
1061
1062         /* if placeholder is here, it's already been deleted.... */
1063         if (HeVAL(entry) == &PL_sv_placeholder)
1064         {
1065           if (k_flags & HVhek_FREEKEY)
1066             Safefree(key);
1067           return Nullsv;
1068         }
1069         else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1070             S_hv_notallowed(aTHX_ k_flags, key, klen,
1071                             "Attempt to delete readonly key '%"SVf"' from"
1072                             " a restricted hash");
1073         }
1074         if (k_flags & HVhek_FREEKEY)
1075             Safefree(key);
1076
1077         if (d_flags & G_DISCARD)
1078             sv = Nullsv;
1079         else {
1080             sv = sv_2mortal(HeVAL(entry));
1081             HeVAL(entry) = &PL_sv_placeholder;
1082         }
1083
1084         /*
1085          * If a restricted hash, rather than really deleting the entry, put
1086          * a placeholder there. This marks the key as being "approved", so
1087          * we can still access via not-really-existing key without raising
1088          * an error.
1089          */
1090         if (SvREADONLY(hv)) {
1091             SvREFCNT_dec(HeVAL(entry));
1092             HeVAL(entry) = &PL_sv_placeholder;
1093             /* We'll be saving this slot, so the number of allocated keys
1094              * doesn't go down, but the number placeholders goes up */
1095             HvPLACEHOLDERS(hv)++;
1096         } else {
1097             *oentry = HeNEXT(entry);
1098             if(!*first_entry) {
1099                 xhv->xhv_fill--; /* HvFILL(hv)-- */
1100             }
1101             if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
1102                 HvLAZYDEL_on(hv);
1103             else
1104                 hv_free_ent(hv, entry);
1105             xhv->xhv_keys--; /* HvKEYS(hv)-- */
1106             if (xhv->xhv_keys == 0)
1107                 HvHASKFLAGS_off(hv);
1108         }
1109         return sv;
1110     }
1111     if (SvREADONLY(hv)) {
1112         S_hv_notallowed(aTHX_ k_flags, key, klen,
1113                         "Attempt to delete disallowed key '%"SVf"' from"
1114                         " a restricted hash");
1115     }
1116
1117     if (k_flags & HVhek_FREEKEY)
1118         Safefree(key);
1119     return Nullsv;
1120 }
1121
1122 STATIC void
1123 S_hsplit(pTHX_ HV *hv)
1124 {
1125     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1126     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1127     register I32 newsize = oldsize * 2;
1128     register I32 i;
1129     char *a = (char*) HvARRAY(hv);
1130     register HE **aep;
1131     register HE **oentry;
1132     int longest_chain = 0;
1133     int was_shared;
1134
1135     /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1136       hv, (int) oldsize);*/
1137
1138     if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1139       /* Can make this clear any placeholders first for non-restricted hashes,
1140          even though Storable rebuilds restricted hashes by putting in all the
1141          placeholders (first) before turning on the readonly flag, because
1142          Storable always pre-splits the hash.  */
1143       hv_clear_placeholders(hv);
1144     }
1145                
1146     PL_nomemok = TRUE;
1147 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1148     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1149           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1150     if (!a) {
1151       PL_nomemok = FALSE;
1152       return;
1153     }
1154     if (SvOOK(hv)) {
1155         Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1156     }
1157 #else
1158     Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1159         + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1160     if (!a) {
1161       PL_nomemok = FALSE;
1162       return;
1163     }
1164     Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1165     if (SvOOK(hv)) {
1166         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1167     }
1168     if (oldsize >= 64) {
1169         offer_nice_chunk(HvARRAY(hv),
1170                          PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1171                          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1172     }
1173     else
1174         Safefree(HvARRAY(hv));
1175 #endif
1176
1177     PL_nomemok = FALSE;
1178     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
1179     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1180     HvARRAY(hv) = (HE**) a;
1181     aep = (HE**)a;
1182
1183     for (i=0; i<oldsize; i++,aep++) {
1184         int left_length = 0;
1185         int right_length = 0;
1186         register HE *entry;
1187         register HE **bep;
1188
1189         if (!*aep)                              /* non-existent */
1190             continue;
1191         bep = aep+oldsize;
1192         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1193             if ((HeHASH(entry) & newsize) != (U32)i) {
1194                 *oentry = HeNEXT(entry);
1195                 HeNEXT(entry) = *bep;
1196                 if (!*bep)
1197                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1198                 *bep = entry;
1199                 right_length++;
1200                 continue;
1201             }
1202             else {
1203                 oentry = &HeNEXT(entry);
1204                 left_length++;
1205             }
1206         }
1207         if (!*aep)                              /* everything moved */
1208             xhv->xhv_fill--; /* HvFILL(hv)-- */
1209         /* I think we don't actually need to keep track of the longest length,
1210            merely flag if anything is too long. But for the moment while
1211            developing this code I'll track it.  */
1212         if (left_length > longest_chain)
1213             longest_chain = left_length;
1214         if (right_length > longest_chain)
1215             longest_chain = right_length;
1216     }
1217
1218
1219     /* Pick your policy for "hashing isn't working" here:  */
1220     if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked?  */
1221         || HvREHASH(hv)) {
1222         return;
1223     }
1224
1225     if (hv == PL_strtab) {
1226         /* Urg. Someone is doing something nasty to the string table.
1227            Can't win.  */
1228         return;
1229     }
1230
1231     /* Awooga. Awooga. Pathological data.  */
1232     /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1233       longest_chain, HvTOTALKEYS(hv), HvFILL(hv),  1+HvMAX(hv));*/
1234
1235     ++newsize;
1236     Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1237          + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1238     if (SvOOK(hv)) {
1239         Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1240     }
1241
1242     was_shared = HvSHAREKEYS(hv);
1243
1244     xhv->xhv_fill = 0;
1245     HvSHAREKEYS_off(hv);
1246     HvREHASH_on(hv);
1247
1248     aep = HvARRAY(hv);
1249
1250     for (i=0; i<newsize; i++,aep++) {
1251         register HE *entry = *aep;
1252         while (entry) {
1253             /* We're going to trash this HE's next pointer when we chain it
1254                into the new hash below, so store where we go next.  */
1255             HE * const next = HeNEXT(entry);
1256             UV hash;
1257             HE **bep;
1258
1259             /* Rehash it */
1260             PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1261
1262             if (was_shared) {
1263                 /* Unshare it.  */
1264                 HEK * const new_hek
1265                     = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1266                                      hash, HeKFLAGS(entry));
1267                 unshare_hek (HeKEY_hek(entry));
1268                 HeKEY_hek(entry) = new_hek;
1269             } else {
1270                 /* Not shared, so simply write the new hash in. */
1271                 HeHASH(entry) = hash;
1272             }
1273             /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1274             HEK_REHASH_on(HeKEY_hek(entry));
1275             /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1276
1277             /* Copy oentry to the correct new chain.  */
1278             bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1279             if (!*bep)
1280                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1281             HeNEXT(entry) = *bep;
1282             *bep = entry;
1283
1284             entry = next;
1285         }
1286     }
1287     Safefree (HvARRAY(hv));
1288     HvARRAY(hv) = (HE **)a;
1289 }
1290
1291 void
1292 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1293 {
1294     register XPVHV* xhv = (XPVHV*)SvANY(hv);
1295     const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1296     register I32 newsize;
1297     register I32 i;
1298     register char *a;
1299     register HE **aep;
1300     register HE *entry;
1301     register HE **oentry;
1302
1303     newsize = (I32) newmax;                     /* possible truncation here */
1304     if (newsize != newmax || newmax <= oldsize)
1305         return;
1306     while ((newsize & (1 + ~newsize)) != newsize) {
1307         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1308     }
1309     if (newsize < newmax)
1310         newsize *= 2;
1311     if (newsize < newmax)
1312         return;                                 /* overflow detection */
1313
1314     a = (char *) HvARRAY(hv);
1315     if (a) {
1316         PL_nomemok = TRUE;
1317 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1318         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1319               + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1320         if (!a) {
1321           PL_nomemok = FALSE;
1322           return;
1323         }
1324         if (SvOOK(hv)) {
1325             Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1326         }
1327 #else
1328         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1329             + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1330         if (!a) {
1331           PL_nomemok = FALSE;
1332           return;
1333         }
1334         Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1335         if (SvOOK(hv)) {
1336             Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1337         }
1338         if (oldsize >= 64) {
1339             offer_nice_chunk(HvARRAY(hv),
1340                              PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1341                              + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
1342         }
1343         else
1344             Safefree(HvARRAY(hv));
1345 #endif
1346         PL_nomemok = FALSE;
1347         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1348     }
1349     else {
1350         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1351     }
1352     xhv->xhv_max = --newsize;   /* HvMAX(hv) = --newsize */
1353     HvARRAY(hv) = (HE **) a;
1354     if (!xhv->xhv_fill /* !HvFILL(hv) */)       /* skip rest if no entries */
1355         return;
1356
1357     aep = (HE**)a;
1358     for (i=0; i<oldsize; i++,aep++) {
1359         if (!*aep)                              /* non-existent */
1360             continue;
1361         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1362             register I32 j;
1363             if ((j = (HeHASH(entry) & newsize)) != i) {
1364                 j -= i;
1365                 *oentry = HeNEXT(entry);
1366                 if (!(HeNEXT(entry) = aep[j]))
1367                     xhv->xhv_fill++; /* HvFILL(hv)++ */
1368                 aep[j] = entry;
1369                 continue;
1370             }
1371             else
1372                 oentry = &HeNEXT(entry);
1373         }
1374         if (!*aep)                              /* everything moved */
1375             xhv->xhv_fill--; /* HvFILL(hv)-- */
1376     }
1377 }
1378
1379 /*
1380 =for apidoc newHV
1381
1382 Creates a new HV.  The reference count is set to 1.
1383
1384 =cut
1385 */
1386
1387 HV *
1388 Perl_newHV(pTHX)
1389 {
1390     register XPVHV* xhv;
1391     HV * const hv = (HV*)NEWSV(502,0);
1392
1393     sv_upgrade((SV *)hv, SVt_PVHV);
1394     xhv = (XPVHV*)SvANY(hv);
1395     SvPOK_off(hv);
1396     SvNOK_off(hv);
1397 #ifndef NODEFAULT_SHAREKEYS
1398     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1399 #endif
1400
1401     xhv->xhv_max    = 7;        /* HvMAX(hv) = 7 (start with 8 buckets) */
1402     xhv->xhv_fill   = 0;        /* HvFILL(hv) = 0 */
1403     return hv;
1404 }
1405
1406 HV *
1407 Perl_newHVhv(pTHX_ HV *ohv)
1408 {
1409     HV * const hv = newHV();
1410     STRLEN hv_max, hv_fill;
1411
1412     if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1413         return hv;
1414     hv_max = HvMAX(ohv);
1415
1416     if (!SvMAGICAL((SV *)ohv)) {
1417         /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1418         STRLEN i;
1419         const bool shared = !!HvSHAREKEYS(ohv);
1420         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1421         char *a;
1422         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1423         ents = (HE**)a;
1424
1425         /* In each bucket... */
1426         for (i = 0; i <= hv_max; i++) {
1427             HE *prev = NULL, *ent = NULL;
1428             HE *oent = oents[i];
1429
1430             if (!oent) {
1431                 ents[i] = NULL;
1432                 continue;
1433             }
1434
1435             /* Copy the linked list of entries. */
1436             for (; oent; oent = HeNEXT(oent)) {
1437                 const U32 hash   = HeHASH(oent);
1438                 const char * const key = HeKEY(oent);
1439                 const STRLEN len = HeKLEN(oent);
1440                 const int flags  = HeKFLAGS(oent);
1441
1442                 ent = new_HE();
1443                 HeVAL(ent)     = newSVsv(HeVAL(oent));
1444                 HeKEY_hek(ent)
1445                     = shared ? share_hek_flags(key, len, hash, flags)
1446                              :  save_hek_flags(key, len, hash, flags);
1447                 if (prev)
1448                     HeNEXT(prev) = ent;
1449                 else
1450                     ents[i] = ent;
1451                 prev = ent;
1452                 HeNEXT(ent) = NULL;
1453             }
1454         }
1455
1456         HvMAX(hv)   = hv_max;
1457         HvFILL(hv)  = hv_fill;
1458         HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
1459         HvARRAY(hv) = ents;
1460     } /* not magical */
1461     else {
1462         /* Iterate over ohv, copying keys and values one at a time. */
1463         HE *entry;
1464         const I32 riter = HvRITER_get(ohv);
1465         HE * const eiter = HvEITER_get(ohv);
1466
1467         /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1468         while (hv_max && hv_max + 1 >= hv_fill * 2)
1469             hv_max = hv_max / 2;
1470         HvMAX(hv) = hv_max;
1471
1472         hv_iterinit(ohv);
1473         while ((entry = hv_iternext_flags(ohv, 0))) {
1474             hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1475                            newSVsv(HeVAL(entry)), HeHASH(entry),
1476                            HeKFLAGS(entry));
1477         }
1478         HvRITER_set(ohv, riter);
1479         HvEITER_set(ohv, eiter);
1480     }
1481
1482     return hv;
1483 }
1484
1485 void
1486 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1487 {
1488     SV *val;
1489
1490     if (!entry)
1491         return;
1492     val = HeVAL(entry);
1493     if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
1494         PL_sub_generation++;    /* may be deletion of method from stash */
1495     SvREFCNT_dec(val);
1496     if (HeKLEN(entry) == HEf_SVKEY) {
1497         SvREFCNT_dec(HeKEY_sv(entry));
1498         Safefree(HeKEY_hek(entry));
1499     }
1500     else if (HvSHAREKEYS(hv))
1501         unshare_hek(HeKEY_hek(entry));
1502     else
1503         Safefree(HeKEY_hek(entry));
1504     del_HE(entry);
1505 }
1506
1507 void
1508 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1509 {
1510     if (!entry)
1511         return;
1512     /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent  */
1513     sv_2mortal(SvREFCNT_inc(HeVAL(entry)));     /* free between statements */
1514     if (HeKLEN(entry) == HEf_SVKEY) {
1515         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1516     }
1517     hv_free_ent(hv, entry);
1518 }
1519
1520 /*
1521 =for apidoc hv_clear
1522
1523 Clears a hash, making it empty.
1524
1525 =cut
1526 */
1527
1528 void
1529 Perl_hv_clear(pTHX_ HV *hv)
1530 {
1531     dVAR;
1532     register XPVHV* xhv;
1533     if (!hv)
1534         return;
1535
1536     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1537
1538     xhv = (XPVHV*)SvANY(hv);
1539
1540     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
1541         /* restricted hash: convert all keys to placeholders */
1542         STRLEN i;
1543         for (i = 0; i <= xhv->xhv_max; i++) {
1544             HE *entry = (HvARRAY(hv))[i];
1545             for (; entry; entry = HeNEXT(entry)) {
1546                 /* not already placeholder */
1547                 if (HeVAL(entry) != &PL_sv_placeholder) {
1548                     if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1549                         SV* keysv = hv_iterkeysv(entry);
1550                         Perl_croak(aTHX_
1551         "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1552                                    keysv);
1553                     }
1554                     SvREFCNT_dec(HeVAL(entry));
1555                     HeVAL(entry) = &PL_sv_placeholder;
1556                     HvPLACEHOLDERS(hv)++;
1557                 }
1558             }
1559         }
1560         goto reset;
1561     }
1562
1563     hfreeentries(hv);
1564     HvPLACEHOLDERS_set(hv, 0);
1565     if (HvARRAY(hv))
1566         (void)memzero(HvARRAY(hv),
1567                       (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1568
1569     if (SvRMAGICAL(hv))
1570         mg_clear((SV*)hv);
1571
1572     HvHASKFLAGS_off(hv);
1573     HvREHASH_off(hv);
1574     reset:
1575     if (SvOOK(hv)) {
1576         HvEITER_set(hv, NULL);
1577     }
1578 }
1579
1580 /*
1581 =for apidoc hv_clear_placeholders
1582
1583 Clears any placeholders from a hash.  If a restricted hash has any of its keys
1584 marked as readonly and the key is subsequently deleted, the key is not actually
1585 deleted but is marked by assigning it a value of &PL_sv_placeholder.  This tags
1586 it so it will be ignored by future operations such as iterating over the hash,
1587 but will still allow the hash to have a value reassigned to the key at some
1588 future point.  This function clears any such placeholder keys from the hash.
1589 See Hash::Util::lock_keys() for an example of its use.
1590
1591 =cut
1592 */
1593
1594 void
1595 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1596 {
1597     dVAR;
1598     I32 items = (I32)HvPLACEHOLDERS_get(hv);
1599     I32 i;
1600
1601     if (items == 0)
1602         return;
1603
1604     i = HvMAX(hv);
1605     do {
1606         /* Loop down the linked list heads  */
1607         bool first = 1;
1608         HE **oentry = &(HvARRAY(hv))[i];
1609         HE *entry = *oentry;
1610
1611         if (!entry)
1612             continue;
1613
1614         for (; entry; entry = *oentry) {
1615             if (HeVAL(entry) == &PL_sv_placeholder) {
1616                 *oentry = HeNEXT(entry);
1617                 if (first && !*oentry)
1618                     HvFILL(hv)--; /* This linked list is now empty.  */
1619                 if (HvEITER_get(hv))
1620                     HvLAZYDEL_on(hv);
1621                 else
1622                     hv_free_ent(hv, entry);
1623
1624                 if (--items == 0) {
1625                     /* Finished.  */
1626                     HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1627                     if (HvKEYS(hv) == 0)
1628                         HvHASKFLAGS_off(hv);
1629                     HvPLACEHOLDERS_set(hv, 0);
1630                     return;
1631                 }
1632             } else {
1633                 oentry = &HeNEXT(entry);
1634                 first = 0;
1635             }
1636         }
1637     } while (--i >= 0);
1638     /* You can't get here, hence assertion should always fail.  */
1639     assert (items == 0);
1640     assert (0);
1641 }
1642
1643 STATIC void
1644 S_hfreeentries(pTHX_ HV *hv)
1645 {
1646     register HE **array;
1647     register HE *entry;
1648     I32 riter;
1649     I32 max;
1650     struct xpvhv_aux *iter;
1651
1652     if (!HvARRAY(hv))
1653         return;
1654
1655     iter =  SvOOK(hv) ? HvAUX(hv) : 0;
1656
1657     riter = 0;
1658     max = HvMAX(hv);
1659     array = HvARRAY(hv);
1660     /* make everyone else think the array is empty, so that the destructors
1661      * called for freed entries can't recusively mess with us */
1662     HvARRAY(hv) = Null(HE**); 
1663     SvFLAGS(hv) &= ~SVf_OOK;
1664
1665     HvFILL(hv) = 0;
1666     ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1667
1668     entry = array[0];
1669     for (;;) {
1670         if (entry) {
1671             register HE * const oentry = entry;
1672             entry = HeNEXT(entry);
1673             hv_free_ent(hv, oentry);
1674         }
1675         if (!entry) {
1676             if (++riter > max)
1677                 break;
1678             entry = array[riter];
1679         }
1680     }
1681
1682     if (SvOOK(hv)) {
1683         /* Someone attempted to iterate or set the hash name while we had
1684            the array set to 0.  */
1685         assert(HvARRAY(hv));
1686
1687         if (HvAUX(hv)->xhv_name)
1688             unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1689         /* SvOOK_off calls sv_backoff, which isn't correct.  */
1690
1691         Safefree(HvARRAY(hv));
1692         HvARRAY(hv) = 0;
1693         SvFLAGS(hv) &= ~SVf_OOK;
1694     }
1695
1696     /* FIXME - things will still go horribly wrong (or at least leak) if
1697        people attempt to add elements to the hash while we're undef()ing it  */
1698     if (iter) {
1699         entry = iter->xhv_eiter; /* HvEITER(hv) */
1700         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1701             HvLAZYDEL_off(hv);
1702             hv_free_ent(hv, entry);
1703         }
1704         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1705         iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1706         SvFLAGS(hv) |= SVf_OOK;
1707     }
1708
1709     HvARRAY(hv) = array;
1710 }
1711
1712 /*
1713 =for apidoc hv_undef
1714
1715 Undefines the hash.
1716
1717 =cut
1718 */
1719
1720 void
1721 Perl_hv_undef(pTHX_ HV *hv)
1722 {
1723     register XPVHV* xhv;
1724     const char *name;
1725     if (!hv)
1726         return;
1727     DEBUG_A(Perl_hv_assert(aTHX_ hv));
1728     xhv = (XPVHV*)SvANY(hv);
1729     hfreeentries(hv);
1730     if ((name = HvNAME_get(hv))) {
1731         if(PL_stashcache)
1732             hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
1733         hv_name_set(hv, Nullch, 0, 0);
1734     }
1735     SvFLAGS(hv) &= ~SVf_OOK;
1736     Safefree(HvARRAY(hv));
1737     xhv->xhv_max   = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1738     HvARRAY(hv) = 0;
1739     HvPLACEHOLDERS_set(hv, 0);
1740
1741     if (SvRMAGICAL(hv))
1742         mg_clear((SV*)hv);
1743 }
1744
1745 static struct xpvhv_aux*
1746 S_hv_auxinit(pTHX_ HV *hv) {
1747     struct xpvhv_aux *iter;
1748     char *array;
1749
1750     if (!HvARRAY(hv)) {
1751         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1752             + sizeof(struct xpvhv_aux), char);
1753     } else {
1754         array = (char *) HvARRAY(hv);
1755         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1756               + sizeof(struct xpvhv_aux), char);
1757     }
1758     HvARRAY(hv) = (HE**) array;
1759     /* SvOOK_on(hv) attacks the IV flags.  */
1760     SvFLAGS(hv) |= SVf_OOK;
1761     iter = HvAUX(hv);
1762
1763     iter->xhv_riter = -1;       /* HvRITER(hv) = -1 */
1764     iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1765     iter->xhv_name = 0;
1766
1767     return iter;
1768 }
1769
1770 /*
1771 =for apidoc hv_iterinit
1772
1773 Prepares a starting point to traverse a hash table.  Returns the number of
1774 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1775 currently only meaningful for hashes without tie magic.
1776
1777 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1778 hash buckets that happen to be in use.  If you still need that esoteric
1779 value, you can get it through the macro C<HvFILL(tb)>.
1780
1781
1782 =cut
1783 */
1784
1785 I32
1786 Perl_hv_iterinit(pTHX_ HV *hv)
1787 {
1788     if (!hv)
1789         Perl_croak(aTHX_ "Bad hash");
1790
1791     if (SvOOK(hv)) {
1792         struct xpvhv_aux *iter = HvAUX(hv);
1793         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
1794         if (entry && HvLAZYDEL(hv)) {   /* was deleted earlier? */
1795             HvLAZYDEL_off(hv);
1796             hv_free_ent(hv, entry);
1797         }
1798         iter->xhv_riter = -1;   /* HvRITER(hv) = -1 */
1799         iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1800     } else {
1801         S_hv_auxinit(aTHX_ hv);
1802     }
1803
1804     /* used to be xhv->xhv_fill before 5.004_65 */
1805     return HvTOTALKEYS(hv);
1806 }
1807
1808 I32 *
1809 Perl_hv_riter_p(pTHX_ HV *hv) {
1810     struct xpvhv_aux *iter;
1811
1812     if (!hv)
1813         Perl_croak(aTHX_ "Bad hash");
1814
1815     iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv);
1816     return &(iter->xhv_riter);
1817 }
1818
1819 HE **
1820 Perl_hv_eiter_p(pTHX_ HV *hv) {
1821     struct xpvhv_aux *iter;
1822
1823     if (!hv)
1824         Perl_croak(aTHX_ "Bad hash");
1825
1826     iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv);
1827     return &(iter->xhv_eiter);
1828 }
1829
1830 void
1831 Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1832     struct xpvhv_aux *iter;
1833
1834     if (!hv)
1835         Perl_croak(aTHX_ "Bad hash");
1836
1837     if (SvOOK(hv)) {
1838         iter = HvAUX(hv);
1839     } else {
1840         if (riter == -1)
1841             return;
1842
1843         iter = S_hv_auxinit(aTHX_ hv);
1844     }
1845     iter->xhv_riter = riter;
1846 }
1847
1848 void
1849 Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1850     struct xpvhv_aux *iter;
1851
1852     if (!hv)
1853         Perl_croak(aTHX_ "Bad hash");
1854
1855     if (SvOOK(hv)) {
1856         iter = HvAUX(hv);
1857     } else {
1858         /* 0 is the default so don't go malloc()ing a new structure just to
1859            hold 0.  */
1860         if (!eiter)
1861             return;
1862
1863         iter = S_hv_auxinit(aTHX_ hv);
1864     }
1865     iter->xhv_eiter = eiter;
1866 }
1867
1868 void
1869 Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags)
1870 {
1871     struct xpvhv_aux *iter;
1872     U32 hash;
1873
1874     PERL_UNUSED_ARG(flags);
1875
1876     if (SvOOK(hv)) {
1877         iter = HvAUX(hv);
1878         if (iter->xhv_name) {
1879             unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
1880         }
1881     } else {
1882         if (name == 0)
1883             return;
1884
1885         iter = S_hv_auxinit(aTHX_ hv);
1886     }
1887     PERL_HASH(hash, name, len);
1888     iter->xhv_name = name ? share_hek(name, len, hash) : 0;
1889 }
1890
1891 /*
1892 hv_iternext is implemented as a macro in hv.h
1893
1894 =for apidoc hv_iternext
1895
1896 Returns entries from a hash iterator.  See C<hv_iterinit>.
1897
1898 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1899 iterator currently points to, without losing your place or invalidating your
1900 iterator.  Note that in this case the current entry is deleted from the hash
1901 with your iterator holding the last reference to it.  Your iterator is flagged
1902 to free the entry on the next call to C<hv_iternext>, so you must not discard
1903 your iterator immediately else the entry will leak - call C<hv_iternext> to
1904 trigger the resource deallocation.
1905
1906 =for apidoc hv_iternext_flags
1907
1908 Returns entries from a hash iterator.  See C<hv_iterinit> and C<hv_iternext>.
1909 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1910 set the placeholders keys (for restricted hashes) will be returned in addition
1911 to normal keys. By default placeholders are automatically skipped over.
1912 Currently a placeholder is implemented with a value that is
1913 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1914 restricted hashes may change, and the implementation currently is
1915 insufficiently abstracted for any change to be tidy.
1916
1917 =cut
1918 */
1919
1920 HE *
1921 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1922 {
1923     dVAR;
1924     register XPVHV* xhv;
1925     register HE *entry;
1926     HE *oldentry;
1927     MAGIC* mg;
1928     struct xpvhv_aux *iter;
1929
1930     if (!hv)
1931         Perl_croak(aTHX_ "Bad hash");
1932     xhv = (XPVHV*)SvANY(hv);
1933
1934     if (!SvOOK(hv)) {
1935         /* Too many things (well, pp_each at least) merrily assume that you can
1936            call iv_iternext without calling hv_iterinit, so we'll have to deal
1937            with it.  */
1938         hv_iterinit(hv);
1939     }
1940     iter = HvAUX(hv);
1941
1942     oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
1943
1944     if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1945         SV * const key = sv_newmortal();
1946         if (entry) {
1947             sv_setsv(key, HeSVKEY_force(entry));
1948             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1949         }
1950         else {
1951             char *k;
1952             HEK *hek;
1953
1954             /* one HE per MAGICAL hash */
1955             iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1956             Zero(entry, 1, HE);
1957             Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
1958             hek = (HEK*)k;
1959             HeKEY_hek(entry) = hek;
1960             HeKLEN(entry) = HEf_SVKEY;
1961         }
1962         magic_nextpack((SV*) hv,mg,key);
1963         if (SvOK(key)) {
1964             /* force key to stay around until next time */
1965             HeSVKEY_set(entry, SvREFCNT_inc(key));
1966             return entry;               /* beware, hent_val is not set */
1967         }
1968         if (HeVAL(entry))
1969             SvREFCNT_dec(HeVAL(entry));
1970         Safefree(HeKEY_hek(entry));
1971         del_HE(entry);
1972         iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1973         return Null(HE*);
1974     }
1975 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1976     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1977         prime_env_iter();
1978 #ifdef VMS
1979         /* The prime_env_iter() on VMS just loaded up new hash values
1980          * so the iteration count needs to be reset back to the beginning
1981          */
1982         hv_iterinit(hv);
1983         iter = HvAUX(hv);
1984         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
1985 #endif
1986     }
1987 #endif
1988
1989     /* hv_iterint now ensures this.  */
1990     assert (HvARRAY(hv));
1991
1992     /* At start of hash, entry is NULL.  */
1993     if (entry)
1994     {
1995         entry = HeNEXT(entry);
1996         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1997             /*
1998              * Skip past any placeholders -- don't want to include them in
1999              * any iteration.
2000              */
2001             while (entry && HeVAL(entry) == &PL_sv_placeholder) {
2002                 entry = HeNEXT(entry);
2003             }
2004         }
2005     }
2006     while (!entry) {
2007         /* OK. Come to the end of the current list.  Grab the next one.  */
2008
2009         iter->xhv_riter++; /* HvRITER(hv)++ */
2010         if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2011             /* There is no next one.  End of the hash.  */
2012             iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2013             break;
2014         }
2015         entry = (HvARRAY(hv))[iter->xhv_riter];
2016
2017         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2018             /* If we have an entry, but it's a placeholder, don't count it.
2019                Try the next.  */
2020             while (entry && HeVAL(entry) == &PL_sv_placeholder)
2021                 entry = HeNEXT(entry);
2022         }
2023         /* Will loop again if this linked list starts NULL
2024            (for HV_ITERNEXT_WANTPLACEHOLDERS)
2025            or if we run through it and find only placeholders.  */
2026     }
2027
2028     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
2029         HvLAZYDEL_off(hv);
2030         hv_free_ent(hv, oldentry);
2031     }
2032
2033     /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
2034       PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
2035
2036     iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2037     return entry;
2038 }
2039
2040 /*
2041 =for apidoc hv_iterkey
2042
2043 Returns the key from the current position of the hash iterator.  See
2044 C<hv_iterinit>.
2045
2046 =cut
2047 */
2048
2049 char *
2050 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
2051 {
2052     if (HeKLEN(entry) == HEf_SVKEY) {
2053         STRLEN len;
2054         char * const p = SvPV(HeKEY_sv(entry), len);
2055         *retlen = len;
2056         return p;
2057     }
2058     else {
2059         *retlen = HeKLEN(entry);
2060         return HeKEY(entry);
2061     }
2062 }
2063
2064 /* unlike hv_iterval(), this always returns a mortal copy of the key */
2065 /*
2066 =for apidoc hv_iterkeysv
2067
2068 Returns the key as an C<SV*> from the current position of the hash
2069 iterator.  The return value will always be a mortal copy of the key.  Also
2070 see C<hv_iterinit>.
2071
2072 =cut
2073 */
2074
2075 SV *
2076 Perl_hv_iterkeysv(pTHX_ register HE *entry)
2077 {
2078     return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2079 }
2080
2081 /*
2082 =for apidoc hv_iterval
2083
2084 Returns the value from the current position of the hash iterator.  See
2085 C<hv_iterkey>.
2086
2087 =cut
2088 */
2089
2090 SV *
2091 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
2092 {
2093     if (SvRMAGICAL(hv)) {
2094         if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
2095             SV* const sv = sv_newmortal();
2096             if (HeKLEN(entry) == HEf_SVKEY)
2097                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2098             else
2099                 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
2100             return sv;
2101         }
2102     }
2103     return HeVAL(entry);
2104 }
2105
2106 /*
2107 =for apidoc hv_iternextsv
2108
2109 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2110 operation.
2111
2112 =cut
2113 */
2114
2115 SV *
2116 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2117 {
2118     HE * const he = hv_iternext_flags(hv, 0);
2119
2120     if (!he)
2121         return NULL;
2122     *key = hv_iterkey(he, retlen);
2123     return hv_iterval(hv, he);
2124 }
2125
2126 /*
2127
2128 Now a macro in hv.h
2129
2130 =for apidoc hv_magic
2131
2132 Adds magic to a hash.  See C<sv_magic>.
2133
2134 =cut
2135 */
2136
2137 /* possibly free a shared string if no one has access to it
2138  * len and hash must both be valid for str.
2139  */
2140 void
2141 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2142 {
2143     unshare_hek_or_pvn (NULL, str, len, hash);
2144 }
2145
2146
2147 void
2148 Perl_unshare_hek(pTHX_ HEK *hek)
2149 {
2150     unshare_hek_or_pvn(hek, NULL, 0, 0);
2151 }
2152
2153 /* possibly free a shared string if no one has access to it
2154    hek if non-NULL takes priority over the other 3, else str, len and hash
2155    are used.  If so, len and hash must both be valid for str.
2156  */
2157 STATIC void
2158 S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2159 {
2160     register XPVHV* xhv;
2161     HE *entry;
2162     register HE **oentry;
2163     HE **first;
2164     bool found = 0;
2165     bool is_utf8 = FALSE;
2166     int k_flags = 0;
2167     const char * const save = str;
2168     struct shared_he *he = 0;
2169
2170     if (hek) {
2171         /* Find the shared he which is just before us in memory.  */
2172         he = (struct shared_he *)(((char *)hek)
2173                                   - STRUCT_OFFSET(struct shared_he,
2174                                                   shared_he_hek));
2175
2176         /* Assert that the caller passed us a genuine (or at least consistent)
2177            shared hek  */
2178         assert (he->shared_he_he.hent_hek == hek);
2179
2180         LOCK_STRTAB_MUTEX;
2181         if (he->shared_he_he.hent_val - 1) {
2182             --he->shared_he_he.hent_val;
2183             UNLOCK_STRTAB_MUTEX;
2184             return;
2185         }
2186         UNLOCK_STRTAB_MUTEX;
2187
2188         hash = HEK_HASH(hek);
2189     } else if (len < 0) {
2190         STRLEN tmplen = -len;
2191         is_utf8 = TRUE;
2192         /* See the note in hv_fetch(). --jhi */
2193         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2194         len = tmplen;
2195         if (is_utf8)
2196             k_flags = HVhek_UTF8;
2197         if (str != save)
2198             k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2199     }
2200
2201     /* what follows is the moral equivalent of:
2202     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2203         if (--*Svp == Nullsv)
2204             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2205     } */
2206     xhv = (XPVHV*)SvANY(PL_strtab);
2207     /* assert(xhv_array != 0) */
2208     LOCK_STRTAB_MUTEX;
2209     first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2210     if (he) {
2211         const HE *const he_he = &(he->shared_he_he);
2212         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2213             if (entry != he_he)
2214                 continue;
2215             found = 1;
2216             break;
2217         }
2218     } else {
2219         const int flags_masked = k_flags & HVhek_MASK;
2220         for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2221             if (HeHASH(entry) != hash)          /* strings can't be equal */
2222                 continue;
2223             if (HeKLEN(entry) != len)
2224                 continue;
2225             if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len))     /* is this it? */
2226                 continue;
2227             if (HeKFLAGS(entry) != flags_masked)
2228                 continue;
2229             found = 1;
2230             break;
2231         }
2232     }
2233
2234     if (found) {
2235         if (--HeVAL(entry) == Nullsv) {
2236             *oentry = HeNEXT(entry);
2237             if (!*first) {
2238                 /* There are now no entries in our slot.  */
2239                 xhv->xhv_fill--; /* HvFILL(hv)-- */
2240             }
2241             Safefree(entry);
2242             xhv->xhv_keys--; /* HvKEYS(hv)-- */
2243         }
2244     }
2245
2246     UNLOCK_STRTAB_MUTEX;
2247     if (!found && ckWARN_d(WARN_INTERNAL))
2248         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2249                     "Attempt to free non-existent shared string '%s'%s"
2250                     pTHX__FORMAT,
2251                     hek ? HEK_KEY(hek) : str,
2252                     ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2253     if (k_flags & HVhek_FREEKEY)
2254         Safefree(str);
2255 }
2256
2257 /* get a (constant) string ptr from the global string table
2258  * string will get added if it is not already there.
2259  * len and hash must both be valid for str.
2260  */
2261 HEK *
2262 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2263 {
2264     bool is_utf8 = FALSE;
2265     int flags = 0;
2266     const char * const save = str;
2267
2268     if (len < 0) {
2269       STRLEN tmplen = -len;
2270       is_utf8 = TRUE;
2271       /* See the note in hv_fetch(). --jhi */
2272       str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2273       len = tmplen;
2274       /* If we were able to downgrade here, then than means that we were passed
2275          in a key which only had chars 0-255, but was utf8 encoded.  */
2276       if (is_utf8)
2277           flags = HVhek_UTF8;
2278       /* If we found we were able to downgrade the string to bytes, then
2279          we should flag that it needs upgrading on keys or each.  Also flag
2280          that we need share_hek_flags to free the string.  */
2281       if (str != save)
2282           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2283     }
2284
2285     return share_hek_flags (str, len, hash, flags);
2286 }
2287
2288 STATIC HEK *
2289 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2290 {
2291     register HE *entry;
2292     register HE **oentry;
2293     I32 found = 0;
2294     const int flags_masked = flags & HVhek_MASK;
2295
2296     /* what follows is the moral equivalent of:
2297
2298     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2299         hv_store(PL_strtab, str, len, Nullsv, hash);
2300
2301         Can't rehash the shared string table, so not sure if it's worth
2302         counting the number of entries in the linked list
2303     */
2304     register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2305     /* assert(xhv_array != 0) */
2306     LOCK_STRTAB_MUTEX;
2307     oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2308     for (entry = *oentry; entry; entry = HeNEXT(entry)) {
2309         if (HeHASH(entry) != hash)              /* strings can't be equal */
2310             continue;
2311         if (HeKLEN(entry) != len)
2312             continue;
2313         if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2314             continue;
2315         if (HeKFLAGS(entry) != flags_masked)
2316             continue;
2317         found = 1;
2318         break;
2319     }
2320     if (!found) {
2321         /* What used to be head of the list.
2322            If this is NULL, then we're the first entry for this slot, which
2323            means we need to increate fill.  */
2324         const HE *old_first = *oentry;
2325         struct shared_he *new_entry;
2326         HEK *hek;
2327         char *k;
2328
2329         /* We don't actually store a HE from the arena and a regular HEK.
2330            Instead we allocate one chunk of memory big enough for both,
2331            and put the HEK straight after the HE. This way we can find the
2332            HEK directly from the HE.
2333         */
2334
2335         Newx(k, STRUCT_OFFSET(struct shared_he,
2336                                 shared_he_hek.hek_key[0]) + len + 2, char);
2337         new_entry = (struct shared_he *)k;
2338         entry = &(new_entry->shared_he_he);
2339         hek = &(new_entry->shared_he_hek);
2340
2341         Copy(str, HEK_KEY(hek), len, char);
2342         HEK_KEY(hek)[len] = 0;
2343         HEK_LEN(hek) = len;
2344         HEK_HASH(hek) = hash;
2345         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2346
2347         /* Still "point" to the HEK, so that other code need not know what
2348            we're up to.  */
2349         HeKEY_hek(entry) = hek;
2350         HeVAL(entry) = Nullsv;
2351         HeNEXT(entry) = *oentry;
2352         *oentry = entry;
2353
2354         xhv->xhv_keys++; /* HvKEYS(hv)++ */
2355         if (!old_first) {                       /* initial entry? */
2356             xhv->xhv_fill++; /* HvFILL(hv)++ */
2357         } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2358                 hsplit(PL_strtab);
2359         }
2360     }
2361
2362     ++HeVAL(entry);                             /* use value slot as REFCNT */
2363     UNLOCK_STRTAB_MUTEX;
2364
2365     if (flags & HVhek_FREEKEY)
2366         Safefree(str);
2367
2368     return HeKEY_hek(entry);
2369 }
2370
2371 I32 *
2372 Perl_hv_placeholders_p(pTHX_ HV *hv)
2373 {
2374     dVAR;
2375     MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2376
2377     if (!mg) {
2378         mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2379
2380         if (!mg) {
2381             Perl_die(aTHX_ "panic: hv_placeholders_p");
2382         }
2383     }
2384     return &(mg->mg_len);
2385 }
2386
2387
2388 I32
2389 Perl_hv_placeholders_get(pTHX_ HV *hv)
2390 {
2391     dVAR;
2392     MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2393
2394     return mg ? mg->mg_len : 0;
2395 }
2396
2397 void
2398 Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2399 {
2400     dVAR;
2401     MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2402
2403     if (mg) {
2404         mg->mg_len = ph;
2405     } else if (ph) {
2406         if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2407             Perl_die(aTHX_ "panic: hv_placeholders_set");
2408     }
2409     /* else we don't need to add magic to record 0 placeholders.  */
2410 }
2411
2412 /*
2413 =for apidoc hv_assert
2414
2415 Check that a hash is in an internally consistent state.
2416
2417 =cut
2418 */
2419
2420 void
2421 Perl_hv_assert(pTHX_ HV *hv)
2422 {
2423   dVAR;
2424   HE* entry;
2425   int withflags = 0;
2426   int placeholders = 0;
2427   int real = 0;
2428   int bad = 0;
2429   const I32 riter = HvRITER_get(hv);
2430   HE *eiter = HvEITER_get(hv);
2431
2432   (void)hv_iterinit(hv);
2433
2434   while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2435     /* sanity check the values */
2436     if (HeVAL(entry) == &PL_sv_placeholder) {
2437       placeholders++;
2438     } else {
2439       real++;
2440     }
2441     /* sanity check the keys */
2442     if (HeSVKEY(entry)) {
2443       /* Don't know what to check on SV keys.  */
2444     } else if (HeKUTF8(entry)) {
2445       withflags++;
2446        if (HeKWASUTF8(entry)) {
2447          PerlIO_printf(Perl_debug_log,
2448                        "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2449                        (int) HeKLEN(entry),  HeKEY(entry));
2450          bad = 1;
2451        }
2452     } else if (HeKWASUTF8(entry)) {
2453       withflags++;
2454     }
2455   }
2456   if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2457     if (HvUSEDKEYS(hv) != real) {
2458       PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2459                     (int) real, (int) HvUSEDKEYS(hv));
2460       bad = 1;
2461     }
2462     if (HvPLACEHOLDERS_get(hv) != placeholders) {
2463       PerlIO_printf(Perl_debug_log,
2464                     "Count %d placeholder(s), but hash reports %d\n",
2465                     (int) placeholders, (int) HvPLACEHOLDERS_get(hv));
2466       bad = 1;
2467     }
2468   }
2469   if (withflags && ! HvHASKFLAGS(hv)) {
2470     PerlIO_printf(Perl_debug_log,
2471                   "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2472                   withflags);
2473     bad = 1;
2474   }
2475   if (bad) {
2476     sv_dump((SV *)hv);
2477   }
2478   HvRITER_set(hv, riter);               /* Restore hash iterator state */
2479   HvEITER_set(hv, eiter);
2480 }
2481
2482 /*
2483  * Local variables:
2484  * c-indentation-style: bsd
2485  * c-basic-offset: 4
2486  * indent-tabs-mode: t
2487  * End:
2488  *
2489  * ex: set ts=8 sts=4 sw=4 noet:
2490  */