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