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