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