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