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