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