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