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