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