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