This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Re: new C3 MRO patch
[perl5.git] / hv.c
CommitLineData
a0d0e21e 1/* hv.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
7272f7c1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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/*
12 * "I sit beside the fire and think of all that I have seen." --Bilbo
79072805
LW		 13 */
14
d5afce77
RB		 15/*
16=head1 Hash Manipulation Functions
166f8a29
DM		 17
18A HV structure represents a Perl hash. It consists mainly of an array
19of pointers, each of which points to a linked list of HE structures. The
20array is indexed by the hash function of the key, so each linked list
21represents all the hash entries with the same hash value. Each HE contains
22a pointer to the actual value, plus a pointer to a HEK structure which
23holds the key and hash value.
24
25=cut
26
d5afce77
RB		 27*/
28
79072805 29#include "EXTERN.h"
864dbfa3 30#define PERL_IN_HV_C
3d78eb94 31#define PERL_HASH_INTERNAL_ACCESS
79072805
LW		 32#include "perl.h"
33
d8012aaf 34#define HV_MAX_LENGTH_BEFORE_SPLIT 14
fdcd69b6 35
d75ce684 36static const char S_strtab_error[]
5d2b1485
NC		 37 = "Cannot modify shared string table in hv_%s";
38
cac9b346
NC		 39STATIC void
40S_more_he(pTHX)
41{
97aff369 42 dVAR;
cac9b346
NC		 43 HE* he;
44 HE* heend;
5e258f8c 45
0a848332 46 he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT);
cac9b346
NC		 47
48 heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
d2a0f284 49 PL_body_roots[HE_SVSLOT] = he;
cac9b346
NC		 50 while (he < heend) {
51 HeNEXT(he) = (HE*)(he + 1);
52 he++;
53 }
54 HeNEXT(he) = 0;
55}
56
c941fb51
NC		 57#ifdef PURIFY
58
59#define new_HE() (HE*)safemalloc(sizeof(HE))
60#define del_HE(p) safefree((char*)p)
61
62#else
63
76e3520e 64STATIC HE*
cea2e8a9 65S_new_he(pTHX)
4633a7c4 66{
97aff369 67 dVAR;
4633a7c4 68 HE* he;
0bd48802 69 void ** const root = &PL_body_roots[HE_SVSLOT];
6a93a7e5 70
6a93a7e5 71 if (!*root)
cac9b346 72 S_more_he(aTHX);
10edeb5d 73 he = (HE*) *root;
ce3e5c45 74 assert(he);
6a93a7e5 75 *root = HeNEXT(he);
333f433b 76 return he;
4633a7c4
LW		 77}
78
c941fb51
NC		 79#define new_HE() new_he()
80#define del_HE(p) \
81 STMT_START { \
6a93a7e5
NC		 82 HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \
83 PL_body_roots[HE_SVSLOT] = p; \
c941fb51 84 } STMT_END
d33b2eba 85
d33b2eba 86
d33b2eba
GS		 87
88#endif
89
76e3520e 90STATIC HEK *
5f66b61c 91S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
bbce6d69 92{
35a4481c 93 const int flags_masked = flags & HVhek_MASK;
bbce6d69 94 char *k;
95 register HEK *hek;
1c846c1f 96
a02a5408 97 Newx(k, HEK_BASESIZE + len + 2, char);
bbce6d69 98 hek = (HEK*)k;
ff68c719 99 Copy(str, HEK_KEY(hek), len, char);
e05949c7 100 HEK_KEY(hek)[len] = 0;
ff68c719 101 HEK_LEN(hek) = len;
102 HEK_HASH(hek) = hash;
45e34800 103 HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
dcf933a4
NC		 104
105 if (flags & HVhek_FREEKEY)
106 Safefree(str);
bbce6d69 107 return hek;
108}
109
4a31713e 110/* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
dd28f7bb
DM		 111 * for tied hashes */
112
113void
114Perl_free_tied_hv_pool(pTHX)
115{
97aff369 116 dVAR;
dd28f7bb
DM		 117 HE *he = PL_hv_fetch_ent_mh;
118 while (he) {
9d4ba2ae 119 HE * const ohe = he;
dd28f7bb 120 Safefree(HeKEY_hek(he));
dd28f7bb
DM		 121 he = HeNEXT(he);
122 del_HE(ohe);
123 }
4608196e 124 PL_hv_fetch_ent_mh = NULL;
dd28f7bb
DM		 125}
126
d18c6117 127#if defined(USE_ITHREADS)
0bff533c
NC		 128HEK *
129Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
130{
658b4a4a 131 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
9d4ba2ae
AL		 132
133 PERL_UNUSED_ARG(param);
0bff533c
NC		 134
135 if (shared) {
136 /* We already shared this hash key. */
454f1e26 137 (void)share_hek_hek(shared);
0bff533c
NC		 138 }
139 else {
658b4a4a 140 shared
6e838c70
NC		 141 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
142 HEK_HASH(source), HEK_FLAGS(source));
658b4a4a 143 ptr_table_store(PL_ptr_table, source, shared);
0bff533c 144 }
658b4a4a 145 return shared;
0bff533c
NC		 146}
147
d18c6117 148HE *
5c4138a0 149Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
d18c6117
GS		 150{
151 HE *ret;
152
153 if (!e)
4608196e 154 return NULL;
7766f137
GS		 155 /* look for it in the table first */
156 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
157 if (ret)
158 return ret;
159
160 /* create anew and remember what it is */
d33b2eba 161 ret = new_HE();
7766f137
GS		 162 ptr_table_store(PL_ptr_table, e, ret);
163
d2d73c3e 164 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
dd28f7bb
DM		 165 if (HeKLEN(e) == HEf_SVKEY) {
166 char *k;
a02a5408 167 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
dd28f7bb 168 HeKEY_hek(ret) = (HEK*)k;
d2d73c3e 169 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
dd28f7bb 170 }
c21d1a0f 171 else if (shared) {
0bff533c
NC		 172 /* This is hek_dup inlined, which seems to be important for speed
173 reasons. */
1b6737cc 174 HEK * const source = HeKEY_hek(e);
658b4a4a 175 HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
c21d1a0f
NC		 176
177 if (shared) {
178 /* We already shared this hash key. */
454f1e26 179 (void)share_hek_hek(shared);
c21d1a0f
NC		 180 }
181 else {
658b4a4a 182 shared
6e838c70
NC		 183 = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
184 HEK_HASH(source), HEK_FLAGS(source));
658b4a4a 185 ptr_table_store(PL_ptr_table, source, shared);
c21d1a0f 186 }
658b4a4a 187 HeKEY_hek(ret) = shared;
c21d1a0f 188 }
d18c6117 189 else
19692e8d
NC		 190 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
191 HeKFLAGS(e));
d2d73c3e 192 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
d18c6117
GS		 193 return ret;
194}
195#endif /* USE_ITHREADS */
196
1b1f1335 197static void
2393f1b9
JH		 198S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
199 const char *msg)
1b1f1335 200{
1b6737cc 201 SV * const sv = sv_newmortal();
19692e8d 202 if (!(flags & HVhek_FREEKEY)) {
1b1f1335
NIS		 203 sv_setpvn(sv, key, klen);
204 }
205 else {
206 /* Need to free saved eventually assign to mortal SV */
34c3c4e3 207 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
1b1f1335
NIS		 208 sv_usepvn(sv, (char *) key, klen);
209 }
19692e8d 210 if (flags & HVhek_UTF8) {
1b1f1335
NIS		 211 SvUTF8_on(sv);
212 }
be2597df 213 Perl_croak(aTHX_ msg, SVfARG(sv));
1b1f1335
NIS		 214}
215
fde52b5c 216/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
217 * contains an SV* */
218
34a6f7b4
NC		 219#define HV_FETCH_ISSTORE 0x01
220#define HV_FETCH_ISEXISTS 0x02
221#define HV_FETCH_LVALUE 0x04
222#define HV_FETCH_JUST_SV 0x08
223
224/*
225=for apidoc hv_store
226
227Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
228the length of the key. The C<hash> parameter is the precomputed hash
229value; if it is zero then Perl will compute it. The return value will be
230NULL if the operation failed or if the value did not need to be actually
231stored within the hash (as in the case of tied hashes). Otherwise it can
232be dereferenced to get the original C<SV*>. Note that the caller is
233responsible for suitably incrementing the reference count of C<val> before
234the call, and decrementing it if the function returned NULL. Effectively
235a successful hv_store takes ownership of one reference to C<val>. This is
236usually what you want; a newly created SV has a reference count of one, so
237if all your code does is create SVs then store them in a hash, hv_store
238will own the only reference to the new SV, and your code doesn't need to do
239anything further to tidy up. hv_store is not implemented as a call to
240hv_store_ent, and does not create a temporary SV for the key, so if your
241key data is not already in SV form then use hv_store in preference to
242hv_store_ent.
243
244See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
245information on how to use this function on tied hashes.
246
247=cut
248*/
249
250SV**
251Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
252{
253 HE *hek;
254 STRLEN klen;
255 int flags;
256
257 if (klen_i32 < 0) {
258 klen = -klen_i32;
259 flags = HVhek_UTF8;
260 } else {
261 klen = klen_i32;
262 flags = 0;
263 }
264 hek = hv_fetch_common (hv, NULL, key, klen, flags,
52d01cc2 265 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
34a6f7b4
NC		 266 return hek ? &HeVAL(hek) : NULL;
267}
268
fabdb6c0 269/* XXX This looks like an ideal candidate to inline */
34a6f7b4
NC		 270SV**
271Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
272 register U32 hash, int flags)
273{
9d4ba2ae 274 HE * const hek = hv_fetch_common (hv, NULL, key, klen, flags,
34a6f7b4
NC		 275 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
276 return hek ? &HeVAL(hek) : NULL;
277}
278
279/*
280=for apidoc hv_store_ent
281
282Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
283parameter is the precomputed hash value; if it is zero then Perl will
284compute it. The return value is the new hash entry so created. It will be
285NULL if the operation failed or if the value did not need to be actually
286stored within the hash (as in the case of tied hashes). Otherwise the
287contents of the return value can be accessed using the C<He?> macros
288described here. Note that the caller is responsible for suitably
289incrementing the reference count of C<val> before the call, and
290decrementing it if the function returned NULL. Effectively a successful
291hv_store_ent takes ownership of one reference to C<val>. This is
292usually what you want; a newly created SV has a reference count of one, so
293if all your code does is create SVs then store them in a hash, hv_store
294will own the only reference to the new SV, and your code doesn't need to do
295anything further to tidy up. Note that hv_store_ent only reads the C<key>;
296unlike C<val> it does not take ownership of it, so maintaining the correct
297reference count on C<key> is entirely the caller's responsibility. hv_store
298is not implemented as a call to hv_store_ent, and does not create a temporary
299SV for the key, so if your key data is not already in SV form then use
300hv_store in preference to hv_store_ent.
301
302See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
303information on how to use this function on tied hashes.
304
305=cut
306*/
307
fabdb6c0 308/* XXX This looks like an ideal candidate to inline */
34a6f7b4
NC		 309HE *
310Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
311{
312 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
313}
314
315/*
316=for apidoc hv_exists
317
318Returns a boolean indicating whether the specified hash key exists. The
319C<klen> is the length of the key.
320
321=cut
322*/
323
324bool
325Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
326{
327 STRLEN klen;
328 int flags;
329
330 if (klen_i32 < 0) {
331 klen = -klen_i32;
332 flags = HVhek_UTF8;
333 } else {
334 klen = klen_i32;
335 flags = 0;
336 }
337 return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
338 ? TRUE : FALSE;
339}
340
954c1994
GS		 341/*
342=for apidoc hv_fetch
343
344Returns the SV which corresponds to the specified key in the hash. The
345C<klen> is the length of the key. If C<lval> is set then the fetch will be
346part of a store. Check that the return value is non-null before
d1be9408 347dereferencing it to an C<SV*>.
954c1994 348
96f1132b 349See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS		 350information on how to use this function on tied hashes.
351
352=cut
353*/
354
79072805 355SV**
c1fe5510 356Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
79072805 357{
c1fe5510
NC		 358 HE *hek;
359 STRLEN klen;
360 int flags;
361
362 if (klen_i32 < 0) {
363 klen = -klen_i32;
364 flags = HVhek_UTF8;
365 } else {
366 klen = klen_i32;
367 flags = 0;
368 }
369 hek = hv_fetch_common (hv, NULL, key, klen, flags,
c445ea15 370 lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) : HV_FETCH_JUST_SV,
a0714e2c 371 NULL, 0);
113738bb 372 return hek ? &HeVAL(hek) : NULL;
79072805
LW		 373}
374
34a6f7b4
NC		 375/*
376=for apidoc hv_exists_ent
377
378Returns a boolean indicating whether the specified hash key exists. C<hash>
379can be a valid precomputed hash value, or 0 to ask for it to be
380computed.
381
382=cut
383*/
384
fabdb6c0 385/* XXX This looks like an ideal candidate to inline */
34a6f7b4
NC		 386bool
387Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
388{
389 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
390 ? TRUE : FALSE;
391}
392
d1be9408 393/* returns an HE * structure with the all fields set */
fde52b5c 394/* note that hent_val will be a mortal sv for MAGICAL hashes */
954c1994
GS		 395/*
396=for apidoc hv_fetch_ent
397
398Returns the hash entry which corresponds to the specified key in the hash.
399C<hash> must be a valid precomputed hash number for the given C<key>, or 0
400if you want the function to compute it. IF C<lval> is set then the fetch
401will be part of a store. Make sure the return value is non-null before
402accessing it. The return value when C<tb> is a tied hash is a pointer to a
403static location, so be sure to make a copy of the structure if you need to
1c846c1f 404store it somewhere.
954c1994 405
96f1132b 406See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS		 407information on how to use this function on tied hashes.
408
409=cut
410*/
411
fde52b5c 412HE *
864dbfa3 413Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
fde52b5c 414{
7f66fda2 415 return hv_fetch_common(hv, keysv, NULL, 0, 0,
a0714e2c 416 (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
113738bb
NC		 417}
418
8f8d40ab 419STATIC HE *
c1fe5510 420S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
b2c64049 421 int flags, int action, SV *val, register U32 hash)
113738bb 422{
27da23d5 423 dVAR;
b2c64049 424 XPVHV* xhv;
b2c64049
NC		 425 HE *entry;
426 HE **oentry;
fde52b5c 427 SV *sv;
da58a35d 428 bool is_utf8;
113738bb 429 int masked_flags;
fde52b5c 430
431 if (!hv)
a4fc7abc 432 return NULL;
fde52b5c 433
113738bb 434 if (keysv) {
1e73acc8
AS		 435 if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
436 keysv = hv_magic_uvar_xkey(hv, keysv, action);
e593d2fe
AE		 437 if (flags & HVhek_FREEKEY)
438 Safefree(key);
5c144d81 439 key = SvPV_const(keysv, klen);
c1fe5510 440 flags = 0;
113738bb
NC		 441 is_utf8 = (SvUTF8(keysv) != 0);
442 } else {
c1fe5510 443 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
113738bb 444 }
113738bb 445
b2c64049 446 xhv = (XPVHV*)SvANY(hv);
7f66fda2 447 if (SvMAGICAL(hv)) {
6136c704 448 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
44a2ac75 449 if ( mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv))
e62cc96a 450 {
7f66fda2
NC		 451 /* XXX should be able to skimp on the HE/HEK here when
452 HV_FETCH_JUST_SV is true. */
7f66fda2
NC		 453 if (!keysv) {
454 keysv = newSVpvn(key, klen);
455 if (is_utf8) {
456 SvUTF8_on(keysv);
457 }
458 } else {
459 keysv = newSVsv(keysv);
113738bb 460 }
44a2ac75
YO		 461 sv = sv_newmortal();
462 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
7f66fda2
NC		 463
464 /* grab a fake HE/HEK pair from the pool or make a new one */
465 entry = PL_hv_fetch_ent_mh;
466 if (entry)
467 PL_hv_fetch_ent_mh = HeNEXT(entry);
468 else {
469 char *k;
470 entry = new_HE();
a02a5408 471 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
7f66fda2
NC		 472 HeKEY_hek(entry) = (HEK*)k;
473 }
4608196e 474 HeNEXT(entry) = NULL;
7f66fda2
NC		 475 HeSVKEY_set(entry, keysv);
476 HeVAL(entry) = sv;
477 sv_upgrade(sv, SVt_PVLV);
478 LvTYPE(sv) = 'T';
479 /* so we can free entry when freeing sv */
480 LvTARG(sv) = (SV*)entry;
481
482 /* XXX remove at some point? */
483 if (flags & HVhek_FREEKEY)
484 Safefree(key);
485
486 return entry;
113738bb 487 }
7f66fda2
NC		 488#ifdef ENV_IS_CASELESS
489 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
490 U32 i;
491 for (i = 0; i < klen; ++i)
492 if (isLOWER(key[i])) {
086cb327
NC		 493 /* Would be nice if we had a routine to do the
494 copy and upercase in a single pass through. */
0bd48802 495 const char * const nkey = strupr(savepvn(key,klen));
086cb327
NC		 496 /* Note that this fetch is for nkey (the uppercased
497 key) whereas the store is for key (the original) */
a0714e2c 498 entry = hv_fetch_common(hv, NULL, nkey, klen,
086cb327
NC		 499 HVhek_FREEKEY, /* free nkey */
500 0 /* non-LVAL fetch */,
a0714e2c 501 NULL /* no value */,
086cb327
NC		 502 0 /* compute hash */);
503 if (!entry && (action & HV_FETCH_LVALUE)) {
504 /* This call will free key if necessary.
505 Do it this way to encourage compiler to tail
506 call optimise. */
507 entry = hv_fetch_common(hv, keysv, key, klen,
508 flags, HV_FETCH_ISSTORE,
561b68a9 509 newSV(0), hash);
086cb327
NC		 510 } else {
511 if (flags & HVhek_FREEKEY)
512 Safefree(key);
513 }
514 return entry;
7f66fda2 515 }
902173a3 516 }
7f66fda2
NC		 517#endif
518 } /* ISFETCH */
519 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
520 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
b2c64049
NC		 521 /* I don't understand why hv_exists_ent has svret and sv,
522 whereas hv_exists only had one. */
9d4ba2ae 523 SV * const svret = sv_newmortal();
b2c64049 524 sv = sv_newmortal();
7f66fda2
NC		 525
526 if (keysv || is_utf8) {
527 if (!keysv) {
528 keysv = newSVpvn(key, klen);
529 SvUTF8_on(keysv);
530 } else {
531 keysv = newSVsv(keysv);
532 }
b2c64049
NC		 533 mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
534 } else {
535 mg_copy((SV*)hv, sv, key, klen);
7f66fda2 536 }
b2c64049
NC		 537 if (flags & HVhek_FREEKEY)
538 Safefree(key);
7f66fda2
NC		 539 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
540 /* This cast somewhat evil, but I'm merely using NULL/
541 not NULL to return the boolean exists.
542 And I know hv is not NULL. */
543 return SvTRUE(svret) ? (HE *)hv : NULL;
e7152ba2 544 }
7f66fda2
NC		 545#ifdef ENV_IS_CASELESS
546 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
547 /* XXX This code isn't UTF8 clean. */
a15d23f8 548 char * const keysave = (char * const)key;
b2c64049
NC		 549 /* Will need to free this, so set FREEKEY flag. */
550 key = savepvn(key,klen);
551 key = (const char*)strupr((char*)key);
6136c704 552 is_utf8 = FALSE;
7f66fda2 553 hash = 0;
8b4f7dd5 554 keysv = 0;
b2c64049
NC		 555
556 if (flags & HVhek_FREEKEY) {
557 Safefree(keysave);
558 }
559 flags |= HVhek_FREEKEY;
7f66fda2 560 }
902173a3 561#endif
7f66fda2 562 } /* ISEXISTS */
b2c64049
NC		 563 else if (action & HV_FETCH_ISSTORE) {
564 bool needs_copy;
565 bool needs_store;
566 hv_magic_check (hv, &needs_copy, &needs_store);
567 if (needs_copy) {
a3b680e6 568 const bool save_taint = PL_tainted;
b2c64049
NC		 569 if (keysv || is_utf8) {
570 if (!keysv) {
571 keysv = newSVpvn(key, klen);
572 SvUTF8_on(keysv);
573 }
574 if (PL_tainting)
575 PL_tainted = SvTAINTED(keysv);
576 keysv = sv_2mortal(newSVsv(keysv));
577 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
578 } else {
579 mg_copy((SV*)hv, val, key, klen);
580 }
581
582 TAINT_IF(save_taint);
1baaf5d7 583 if (!needs_store) {
b2c64049
NC		 584 if (flags & HVhek_FREEKEY)
585 Safefree(key);
4608196e 586 return NULL;
b2c64049
NC		 587 }
588#ifdef ENV_IS_CASELESS
589 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
590 /* XXX This code isn't UTF8 clean. */
591 const char *keysave = key;
592 /* Will need to free this, so set FREEKEY flag. */
593 key = savepvn(key,klen);
594 key = (const char*)strupr((char*)key);
6136c704 595 is_utf8 = FALSE;
b2c64049 596 hash = 0;
8b4f7dd5 597 keysv = 0;
b2c64049
NC		 598
599 if (flags & HVhek_FREEKEY) {
600 Safefree(keysave);
601 }
602 flags |= HVhek_FREEKEY;
603 }
604#endif
605 }
606 } /* ISSTORE */
7f66fda2 607 } /* SvMAGICAL */
fde52b5c 608
7b2c381c 609 if (!HvARRAY(hv)) {
b2c64049 610 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
fde52b5c 611#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
8aacddc1 612 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
fde52b5c 613#endif
d58e6666
NC		 614 ) {
615 char *array;
a02a5408 616 Newxz(array,
cbec9347 617 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
d58e6666
NC		 618 char);
619 HvARRAY(hv) = (HE**)array;
620 }
7f66fda2
NC		 621#ifdef DYNAMIC_ENV_FETCH
622 else if (action & HV_FETCH_ISEXISTS) {
623 /* for an %ENV exists, if we do an insert it's by a recursive
624 store call, so avoid creating HvARRAY(hv) right now. */
625 }
626#endif
113738bb
NC		 627 else {
628 /* XXX remove at some point? */
629 if (flags & HVhek_FREEKEY)
630 Safefree(key);
631
fde52b5c 632 return 0;
113738bb 633 }
fde52b5c 634 }
635
19692e8d 636 if (is_utf8) {
41d88b63 637 char * const keysave = (char *)key;
f9a63242 638 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
19692e8d 639 if (is_utf8)
c1fe5510
NC		 640 flags |= HVhek_UTF8;
641 else
642 flags &= ~HVhek_UTF8;
7f66fda2
NC		 643 if (key != keysave) {
644 if (flags & HVhek_FREEKEY)
645 Safefree(keysave);
19692e8d 646 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
7f66fda2 647 }
19692e8d 648 }
f9a63242 649
4b5190b5
NC		 650 if (HvREHASH(hv)) {
651 PERL_HASH_INTERNAL(hash, key, klen);
b2c64049
NC		 652 /* We don't have a pointer to the hv, so we have to replicate the
653 flag into every HEK, so that hv_iterkeysv can see it. */
654 /* And yes, you do need this even though you are not "storing" because
fdcd69b6
NC		 655 you can flip the flags below if doing an lval lookup. (And that
656 was put in to give the semantics Andreas was expecting.) */
657 flags |= HVhek_REHASH;
4b5190b5 658 } else if (!hash) {
113738bb 659 if (keysv && (SvIsCOW_shared_hash(keysv))) {
c158a4fd 660 hash = SvSHARED_HASH(keysv);
46187eeb
NC		 661 } else {
662 PERL_HASH(hash, key, klen);
663 }
664 }
effa1e2d 665
113738bb
NC		 666 masked_flags = (flags & HVhek_MASK);
667
7f66fda2 668#ifdef DYNAMIC_ENV_FETCH
4608196e 669 if (!HvARRAY(hv)) entry = NULL;
7f66fda2
NC		 670 else
671#endif
b2c64049 672 {
7b2c381c 673 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
b2c64049 674 }
0298d7b9 675 for (; entry; entry = HeNEXT(entry)) {
fde52b5c 676 if (HeHASH(entry) != hash) /* strings can't be equal */
677 continue;
eb160463 678 if (HeKLEN(entry) != (I32)klen)
fde52b5c 679 continue;
1c846c1f 680 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 681 continue;
113738bb 682 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 683 continue;
b2c64049
NC		 684
685 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
686 if (HeKFLAGS(entry) != masked_flags) {
687 /* We match if HVhek_UTF8 bit in our flags and hash key's
688 match. But if entry was set previously with HVhek_WASUTF8
689 and key now doesn't (or vice versa) then we should change
690 the key's flag, as this is assignment. */
691 if (HvSHAREKEYS(hv)) {
692 /* Need to swap the key we have for a key with the flags we
693 need. As keys are shared we can't just write to the
694 flag, so we share the new one, unshare the old one. */
6136c704 695 HEK * const new_hek = share_hek_flags(key, klen, hash,
6e838c70 696 masked_flags);
b2c64049
NC		 697 unshare_hek (HeKEY_hek(entry));
698 HeKEY_hek(entry) = new_hek;
699 }
5d2b1485
NC		 700 else if (hv == PL_strtab) {
701 /* PL_strtab is usually the only hash without HvSHAREKEYS,
702 so putting this test here is cheap */
703 if (flags & HVhek_FREEKEY)
704 Safefree(key);
705 Perl_croak(aTHX_ S_strtab_error,
706 action & HV_FETCH_LVALUE ? "fetch" : "store");
707 }
b2c64049
NC		 708 else
709 HeKFLAGS(entry) = masked_flags;
710 if (masked_flags & HVhek_ENABLEHVKFLAGS)
711 HvHASKFLAGS_on(hv);
712 }
713 if (HeVAL(entry) == &PL_sv_placeholder) {
714 /* yes, can store into placeholder slot */
715 if (action & HV_FETCH_LVALUE) {
716 if (SvMAGICAL(hv)) {
717 /* This preserves behaviour with the old hv_fetch
718 implementation which at this point would bail out
719 with a break; (at "if we find a placeholder, we
720 pretend we haven't found anything")
721
722 That break mean that if a placeholder were found, it
723 caused a call into hv_store, which in turn would
724 check magic, and if there is no magic end up pretty
725 much back at this point (in hv_store's code). */
726 break;
727 }
728 /* LVAL fetch which actaully needs a store. */
561b68a9 729 val = newSV(0);
ca732855 730 HvPLACEHOLDERS(hv)--;
b2c64049
NC		 731 } else {
732 /* store */
733 if (val != &PL_sv_placeholder)
ca732855 734 HvPLACEHOLDERS(hv)--;
b2c64049
NC		 735 }
736 HeVAL(entry) = val;
737 } else if (action & HV_FETCH_ISSTORE) {
738 SvREFCNT_dec(HeVAL(entry));
739 HeVAL(entry) = val;
740 }
27bcc0a7 741 } else if (HeVAL(entry) == &PL_sv_placeholder) {
b2c64049
NC		 742 /* if we find a placeholder, we pretend we haven't found
743 anything */
8aacddc1 744 break;
b2c64049 745 }
113738bb
NC		 746 if (flags & HVhek_FREEKEY)
747 Safefree(key);
fde52b5c 748 return entry;
749 }
750#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
0ed29950
NC		 751 if (!(action & HV_FETCH_ISSTORE)
752 && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364 753 unsigned long len;
9d4ba2ae 754 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
a6c40364
GS		 755 if (env) {
756 sv = newSVpvn(env,len);
757 SvTAINTED_on(sv);
7fd3d16e 758 return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
b2c64049 759 hash);
a6c40364 760 }
fde52b5c 761 }
762#endif
7f66fda2
NC		 763
764 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
c445ea15 765 hv_notallowed(flags, key, klen,
c8cd6465
NC		 766 "Attempt to access disallowed key '%"SVf"' in"
767 " a restricted hash");
1b1f1335 768 }
b2c64049
NC		 769 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
770 /* Not doing some form of store, so return failure. */
771 if (flags & HVhek_FREEKEY)
772 Safefree(key);
773 return 0;
774 }
113738bb 775 if (action & HV_FETCH_LVALUE) {
561b68a9 776 val = newSV(0);
b2c64049
NC		 777 if (SvMAGICAL(hv)) {
778 /* At this point the old hv_fetch code would call to hv_store,
779 which in turn might do some tied magic. So we need to make that
780 magic check happen. */
781 /* gonna assign to this, so it better be there */
782 return hv_fetch_common(hv, keysv, key, klen, flags,
783 HV_FETCH_ISSTORE, val, hash);
784 /* XXX Surely that could leak if the fetch-was-store fails?
785 Just like the hv_fetch. */
113738bb
NC		 786 }
787 }
788
b2c64049
NC		 789 /* Welcome to hv_store... */
790
7b2c381c 791 if (!HvARRAY(hv)) {
b2c64049
NC		 792 /* Not sure if we can get here. I think the only case of oentry being
793 NULL is for %ENV with dynamic env fetch. But that should disappear
794 with magic in the previous code. */
d58e6666 795 char *array;
a02a5408 796 Newxz(array,
b2c64049 797 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
d58e6666
NC		 798 char);
799 HvARRAY(hv) = (HE**)array;
b2c64049
NC		 800 }
801
7b2c381c 802 oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
ab4af705 803
b2c64049
NC		 804 entry = new_HE();
805 /* share_hek_flags will do the free for us. This might be considered
806 bad API design. */
807 if (HvSHAREKEYS(hv))
6e838c70 808 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
5d2b1485
NC		 809 else if (hv == PL_strtab) {
810 /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
811 this test here is cheap */
812 if (flags & HVhek_FREEKEY)
813 Safefree(key);
814 Perl_croak(aTHX_ S_strtab_error,
815 action & HV_FETCH_LVALUE ? "fetch" : "store");
816 }
b2c64049
NC		 817 else /* gotta do the real thing */
818 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
819 HeVAL(entry) = val;
820 HeNEXT(entry) = *oentry;
821 *oentry = entry;
822
823 if (val == &PL_sv_placeholder)
ca732855 824 HvPLACEHOLDERS(hv)++;
b2c64049
NC		 825 if (masked_flags & HVhek_ENABLEHVKFLAGS)
826 HvHASKFLAGS_on(hv);
827
0298d7b9
NC		 828 {
829 const HE *counter = HeNEXT(entry);
830
4c7185a0 831 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
0298d7b9
NC		 832 if (!counter) { /* initial entry? */
833 xhv->xhv_fill++; /* HvFILL(hv)++ */
834 } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
835 hsplit(hv);
836 } else if(!HvREHASH(hv)) {
837 U32 n_links = 1;
838
839 while ((counter = HeNEXT(counter)))
840 n_links++;
841
842 if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
843 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
844 bucket splits on a rehashed hash, as we're not going to
845 split it again, and if someone is lucky (evil) enough to
846 get all the keys in one list they could exhaust our memory
847 as we repeatedly double the number of buckets on every
848 entry. Linear search feels a less worse thing to do. */
849 hsplit(hv);
850 }
851 }
fde52b5c 852 }
b2c64049
NC		 853
854 return entry;
fde52b5c 855}
856
864dbfa3 857STATIC void
b0e6ae5b 858S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
d0066dc7 859{
a3b680e6 860 const MAGIC *mg = SvMAGIC(hv);
d0066dc7
OT		 861 *needs_copy = FALSE;
862 *needs_store = TRUE;
863 while (mg) {
864 if (isUPPER(mg->mg_type)) {
865 *needs_copy = TRUE;
d60c5a05 866 if (mg->mg_type == PERL_MAGIC_tied) {
d0066dc7 867 *needs_store = FALSE;
4ab2a30b 868 return; /* We've set all there is to set. */
d0066dc7
OT		 869 }
870 }
871 mg = mg->mg_moremagic;
872 }
873}
874
954c1994 875/*
a3bcc51e
TP		 876=for apidoc hv_scalar
877
878Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
879
880=cut
881*/
882
883SV *
884Perl_hv_scalar(pTHX_ HV *hv)
885{
a3bcc51e 886 SV *sv;
823a54a3
AL		 887
888 if (SvRMAGICAL(hv)) {
889 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
890 if (mg)
891 return magic_scalarpack(hv, mg);
892 }
a3bcc51e
TP		 893
894 sv = sv_newmortal();
895 if (HvFILL((HV*)hv))
896 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
897 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
898 else
899 sv_setiv(sv, 0);
900
901 return sv;
902}
903
904/*
954c1994
GS		 905=for apidoc hv_delete
906
907Deletes a key/value pair in the hash. The value SV is removed from the
1c846c1f 908hash and returned to the caller. The C<klen> is the length of the key.
954c1994
GS		 909The C<flags> value will normally be zero; if set to G_DISCARD then NULL
910will be returned.
911
912=cut
913*/
914
79072805 915SV *
cd6d36ac 916Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
79072805 917{
cd6d36ac 918 STRLEN klen;
6136c704 919 int k_flags;
cd6d36ac
NC		 920
921 if (klen_i32 < 0) {
922 klen = -klen_i32;
6136c704 923 k_flags = HVhek_UTF8;
cd6d36ac
NC		 924 } else {
925 klen = klen_i32;
6136c704 926 k_flags = 0;
cd6d36ac
NC		 927 }
928 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
fde52b5c 929}
930
954c1994
GS		 931/*
932=for apidoc hv_delete_ent
933
934Deletes a key/value pair in the hash. The value SV is removed from the
935hash and returned to the caller. The C<flags> value will normally be zero;
936if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
937precomputed hash value, or 0 to ask for it to be computed.
938
939=cut
940*/
941
fabdb6c0 942/* XXX This looks like an ideal candidate to inline */
fde52b5c 943SV *
864dbfa3 944Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
fde52b5c 945{
cd6d36ac 946 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
f1317c8d
NC		 947}
948
8f8d40ab 949STATIC SV *
cd6d36ac
NC		 950S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
951 int k_flags, I32 d_flags, U32 hash)
f1317c8d 952{
27da23d5 953 dVAR;
cbec9347 954 register XPVHV* xhv;
fde52b5c 955 register HE *entry;
956 register HE **oentry;
9e720f71 957 HE *const *first_entry;
da58a35d 958 bool is_utf8;
7a9669ca 959 int masked_flags;
1c846c1f 960
fde52b5c 961 if (!hv)
a0714e2c 962 return NULL;
f1317c8d
NC		 963
964 if (keysv) {
1e73acc8
AS		 965 if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
966 keysv = hv_magic_uvar_xkey(hv, keysv, -1);
e593d2fe
AE		 967 if (k_flags & HVhek_FREEKEY)
968 Safefree(key);
5c144d81 969 key = SvPV_const(keysv, klen);
cd6d36ac 970 k_flags = 0;
f1317c8d
NC		 971 is_utf8 = (SvUTF8(keysv) != 0);
972 } else {
cd6d36ac 973 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
f1317c8d 974 }
f1317c8d 975
fde52b5c 976 if (SvRMAGICAL(hv)) {
0a0bb7c7
OT		 977 bool needs_copy;
978 bool needs_store;
979 hv_magic_check (hv, &needs_copy, &needs_store);
980
f1317c8d 981 if (needs_copy) {
6136c704 982 SV *sv;
7a9669ca
NC		 983 entry = hv_fetch_common(hv, keysv, key, klen,
984 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
a0714e2c 985 NULL, hash);
7a9669ca 986 sv = entry ? HeVAL(entry) : NULL;
f1317c8d
NC		 987 if (sv) {
988 if (SvMAGICAL(sv)) {
989 mg_clear(sv);
990 }
991 if (!needs_store) {
992 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
993 /* No longer an element */
994 sv_unmagic(sv, PERL_MAGIC_tiedelem);
995 return sv;
996 }
a0714e2c 997 return NULL; /* element cannot be deleted */
f1317c8d 998 }
902173a3 999#ifdef ENV_IS_CASELESS
8167a60a
NC		 1000 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
1001 /* XXX This code isn't UTF8 clean. */
1002 keysv = sv_2mortal(newSVpvn(key,klen));
1003 if (k_flags & HVhek_FREEKEY) {
1004 Safefree(key);
1005 }
1006 key = strupr(SvPVX(keysv));
1007 is_utf8 = 0;
1008 k_flags = 0;
1009 hash = 0;
7f66fda2 1010 }
510ac311 1011#endif
2fd1c6b8 1012 }
2fd1c6b8 1013 }
fde52b5c 1014 }
cbec9347 1015 xhv = (XPVHV*)SvANY(hv);
7b2c381c 1016 if (!HvARRAY(hv))
a0714e2c 1017 return NULL;
fde52b5c 1018
19692e8d 1019 if (is_utf8) {
c445ea15 1020 const char * const keysave = key;
b464bac0 1021 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
cd6d36ac 1022
19692e8d 1023 if (is_utf8)
cd6d36ac
NC		 1024 k_flags |= HVhek_UTF8;
1025 else
1026 k_flags &= ~HVhek_UTF8;
7f66fda2
NC		 1027 if (key != keysave) {
1028 if (k_flags & HVhek_FREEKEY) {
1029 /* This shouldn't happen if our caller does what we expect,
1030 but strictly the API allows it. */
1031 Safefree(keysave);
1032 }
1033 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1034 }
cd6d36ac 1035 HvHASKFLAGS_on((SV*)hv);
19692e8d 1036 }
f9a63242 1037
4b5190b5
NC		 1038 if (HvREHASH(hv)) {
1039 PERL_HASH_INTERNAL(hash, key, klen);
1040 } else if (!hash) {
7a9669ca 1041 if (keysv && (SvIsCOW_shared_hash(keysv))) {
c158a4fd 1042 hash = SvSHARED_HASH(keysv);
7a9669ca
NC		 1043 } else {
1044 PERL_HASH(hash, key, klen);
1045 }
4b5190b5 1046 }
fde52b5c 1047
7a9669ca
NC		 1048 masked_flags = (k_flags & HVhek_MASK);
1049
9e720f71 1050 first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
fde52b5c 1051 entry = *oentry;
9e720f71 1052 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
6136c704 1053 SV *sv;
fde52b5c 1054 if (HeHASH(entry) != hash) /* strings can't be equal */
1055 continue;
eb160463 1056 if (HeKLEN(entry) != (I32)klen)
fde52b5c 1057 continue;
1c846c1f 1058 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 1059 continue;
7a9669ca 1060 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 1061 continue;
8aacddc1 1062
5d2b1485
NC		 1063 if (hv == PL_strtab) {
1064 if (k_flags & HVhek_FREEKEY)
1065 Safefree(key);
1066 Perl_croak(aTHX_ S_strtab_error, "delete");
1067 }
1068
8aacddc1 1069 /* if placeholder is here, it's already been deleted.... */
6136c704
AL		 1070 if (HeVAL(entry) == &PL_sv_placeholder) {
1071 if (k_flags & HVhek_FREEKEY)
1072 Safefree(key);
1073 return NULL;
8aacddc1 1074 }
6136c704 1075 if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
d4c19fe8 1076 hv_notallowed(k_flags, key, klen,
c8cd6465
NC		 1077 "Attempt to delete readonly key '%"SVf"' from"
1078 " a restricted hash");
8aacddc1 1079 }
b84d0860
NC		 1080 if (k_flags & HVhek_FREEKEY)
1081 Safefree(key);
8aacddc1 1082
cd6d36ac 1083 if (d_flags & G_DISCARD)
a0714e2c 1084 sv = NULL;
94f7643d 1085 else {
79d01fbf 1086 sv = sv_2mortal(HeVAL(entry));
7996736c 1087 HeVAL(entry) = &PL_sv_placeholder;
94f7643d 1088 }
8aacddc1
NIS		 1089
1090 /*
1091 * If a restricted hash, rather than really deleting the entry, put
1092 * a placeholder there. This marks the key as being "approved", so
1093 * we can still access via not-really-existing key without raising
1094 * an error.
1095 */
1096 if (SvREADONLY(hv)) {
754604c4 1097 SvREFCNT_dec(HeVAL(entry));
7996736c 1098 HeVAL(entry) = &PL_sv_placeholder;
8aacddc1
NIS		 1099 /* We'll be saving this slot, so the number of allocated keys
1100 * doesn't go down, but the number placeholders goes up */
ca732855 1101 HvPLACEHOLDERS(hv)++;
8aacddc1 1102 } else {
a26e96df 1103 *oentry = HeNEXT(entry);
9e720f71 1104 if(!*first_entry) {
a26e96df 1105 xhv->xhv_fill--; /* HvFILL(hv)-- */
9e720f71 1106 }
b79f7545 1107 if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
8aacddc1
NIS		 1108 HvLAZYDEL_on(hv);
1109 else
1110 hv_free_ent(hv, entry);
4c7185a0 1111 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
574c8022 1112 if (xhv->xhv_keys == 0)
19692e8d 1113 HvHASKFLAGS_off(hv);
8aacddc1 1114 }
79072805
LW		 1115 return sv;
1116 }
8aacddc1 1117 if (SvREADONLY(hv)) {
d4c19fe8 1118 hv_notallowed(k_flags, key, klen,
c8cd6465
NC		 1119 "Attempt to delete disallowed key '%"SVf"' from"
1120 " a restricted hash");
8aacddc1
NIS		 1121 }
1122
19692e8d 1123 if (k_flags & HVhek_FREEKEY)
f9a63242 1124 Safefree(key);
a0714e2c 1125 return NULL;
79072805
LW		 1126}
1127
76e3520e 1128STATIC void
cea2e8a9 1129S_hsplit(pTHX_ HV *hv)
79072805 1130{
97aff369 1131 dVAR;
cbec9347 1132 register XPVHV* xhv = (XPVHV*)SvANY(hv);
a3b680e6 1133 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
79072805
LW		 1134 register I32 newsize = oldsize * 2;
1135 register I32 i;
7b2c381c 1136 char *a = (char*) HvARRAY(hv);
72311751 1137 register HE **aep;
79072805 1138 register HE **oentry;
4b5190b5
NC		 1139 int longest_chain = 0;
1140 int was_shared;
79072805 1141
18026298 1142 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
6c9570dc 1143 (void*)hv, (int) oldsize);*/
18026298 1144
5d88ecd7 1145 if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
18026298
NC		 1146 /* Can make this clear any placeholders first for non-restricted hashes,
1147 even though Storable rebuilds restricted hashes by putting in all the
1148 placeholders (first) before turning on the readonly flag, because
1149 Storable always pre-splits the hash. */
1150 hv_clear_placeholders(hv);
1151 }
1152
3280af22 1153 PL_nomemok = TRUE;
8d6dde3e 1154#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
b79f7545
NC		 1155 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1156 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
422a93e5 1157 if (!a) {
4a33f861 1158 PL_nomemok = FALSE;
422a93e5
GA		 1159 return;
1160 }
b79f7545 1161 if (SvOOK(hv)) {
7a9b70e9 1162 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
b79f7545 1163 }
4633a7c4 1164#else
a02a5408 1165 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545 1166 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
422a93e5 1167 if (!a) {
3280af22 1168 PL_nomemok = FALSE;
422a93e5
GA		 1169 return;
1170 }
7b2c381c 1171 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
b79f7545
NC		 1172 if (SvOOK(hv)) {
1173 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1174 }
fba3b22e 1175 if (oldsize >= 64) {
7b2c381c 1176 offer_nice_chunk(HvARRAY(hv),
b79f7545
NC		 1177 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1178 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
4633a7c4
LW		 1179 }
1180 else
7b2c381c 1181 Safefree(HvARRAY(hv));
4633a7c4
LW		 1182#endif
1183
3280af22 1184 PL_nomemok = FALSE;
72311751 1185 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
cbec9347 1186 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
7b2c381c 1187 HvARRAY(hv) = (HE**) a;
72311751 1188 aep = (HE**)a;
79072805 1189
72311751 1190 for (i=0; i<oldsize; i++,aep++) {
4b5190b5
NC		 1191 int left_length = 0;
1192 int right_length = 0;
a3b680e6
AL		 1193 register HE *entry;
1194 register HE **bep;
4b5190b5 1195
72311751 1196 if (!*aep) /* non-existent */
79072805 1197 continue;
72311751
GS		 1198 bep = aep+oldsize;
1199 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
eb160463 1200 if ((HeHASH(entry) & newsize) != (U32)i) {
fde52b5c 1201 *oentry = HeNEXT(entry);
72311751
GS		 1202 HeNEXT(entry) = *bep;
1203 if (!*bep)
cbec9347 1204 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1205 *bep = entry;
4b5190b5 1206 right_length++;
79072805
LW		 1207 continue;
1208 }
4b5190b5 1209 else {
fde52b5c 1210 oentry = &HeNEXT(entry);
4b5190b5
NC		 1211 left_length++;
1212 }
79072805 1213 }
72311751 1214 if (!*aep) /* everything moved */
cbec9347 1215 xhv->xhv_fill--; /* HvFILL(hv)-- */
4b5190b5
NC		 1216 /* I think we don't actually need to keep track of the longest length,
1217 merely flag if anything is too long. But for the moment while
1218 developing this code I'll track it. */
1219 if (left_length > longest_chain)
1220 longest_chain = left_length;
1221 if (right_length > longest_chain)
1222 longest_chain = right_length;
1223 }
1224
1225
1226 /* Pick your policy for "hashing isn't working" here: */
fdcd69b6 1227 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
4b5190b5
NC		 1228 || HvREHASH(hv)) {
1229 return;
79072805 1230 }
4b5190b5
NC		 1231
1232 if (hv == PL_strtab) {
1233 /* Urg. Someone is doing something nasty to the string table.
1234 Can't win. */
1235 return;
1236 }
1237
1238 /* Awooga. Awooga. Pathological data. */
6c9570dc 1239 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
4b5190b5
NC		 1240 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1241
1242 ++newsize;
a02a5408 1243 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545
NC		 1244 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1245 if (SvOOK(hv)) {
1246 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1247 }
1248
4b5190b5
NC		 1249 was_shared = HvSHAREKEYS(hv);
1250
1251 xhv->xhv_fill = 0;
1252 HvSHAREKEYS_off(hv);
1253 HvREHASH_on(hv);
1254
7b2c381c 1255 aep = HvARRAY(hv);
4b5190b5
NC		 1256
1257 for (i=0; i<newsize; i++,aep++) {
a3b680e6 1258 register HE *entry = *aep;
4b5190b5
NC		 1259 while (entry) {
1260 /* We're going to trash this HE's next pointer when we chain it
1261 into the new hash below, so store where we go next. */
9d4ba2ae 1262 HE * const next = HeNEXT(entry);
4b5190b5 1263 UV hash;
a3b680e6 1264 HE **bep;
4b5190b5
NC		 1265
1266 /* Rehash it */
1267 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1268
1269 if (was_shared) {
1270 /* Unshare it. */
aec46f14 1271 HEK * const new_hek
4b5190b5
NC		 1272 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1273 hash, HeKFLAGS(entry));
1274 unshare_hek (HeKEY_hek(entry));
1275 HeKEY_hek(entry) = new_hek;
1276 } else {
1277 /* Not shared, so simply write the new hash in. */
1278 HeHASH(entry) = hash;
1279 }
1280 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1281 HEK_REHASH_on(HeKEY_hek(entry));
1282 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1283
1284 /* Copy oentry to the correct new chain. */
1285 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1286 if (!*bep)
1287 xhv->xhv_fill++; /* HvFILL(hv)++ */
1288 HeNEXT(entry) = *bep;
1289 *bep = entry;
1290
1291 entry = next;
1292 }
1293 }
7b2c381c
NC		 1294 Safefree (HvARRAY(hv));
1295 HvARRAY(hv) = (HE **)a;
79072805
LW		 1296}
1297
72940dca 1298void
864dbfa3 1299Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
72940dca 1300{
97aff369 1301 dVAR;
cbec9347 1302 register XPVHV* xhv = (XPVHV*)SvANY(hv);
a3b680e6 1303 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
72940dca 1304 register I32 newsize;
1305 register I32 i;
72311751
GS		 1306 register char *a;
1307 register HE **aep;
72940dca 1308 register HE *entry;
1309 register HE **oentry;
1310
1311 newsize = (I32) newmax; /* possible truncation here */
1312 if (newsize != newmax || newmax <= oldsize)
1313 return;
1314 while ((newsize & (1 + ~newsize)) != newsize) {
1315 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1316 }
1317 if (newsize < newmax)
1318 newsize *= 2;
1319 if (newsize < newmax)
1320 return; /* overflow detection */
1321
7b2c381c 1322 a = (char *) HvARRAY(hv);
72940dca 1323 if (a) {
3280af22 1324 PL_nomemok = TRUE;
8d6dde3e 1325#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
b79f7545
NC		 1326 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1327 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
8aacddc1 1328 if (!a) {
4a33f861 1329 PL_nomemok = FALSE;
422a93e5
GA		 1330 return;
1331 }
b79f7545 1332 if (SvOOK(hv)) {
7a9b70e9 1333 Copy(&a[oldsize * sizeof(HE*)], &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
b79f7545 1334 }
72940dca 1335#else
a02a5408 1336 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
b79f7545 1337 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
8aacddc1 1338 if (!a) {
3280af22 1339 PL_nomemok = FALSE;
422a93e5
GA		 1340 return;
1341 }
7b2c381c 1342 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
b79f7545
NC		 1343 if (SvOOK(hv)) {
1344 Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
1345 }
fba3b22e 1346 if (oldsize >= 64) {
7b2c381c 1347 offer_nice_chunk(HvARRAY(hv),
b79f7545
NC		 1348 PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
1349 + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
72940dca 1350 }
1351 else
7b2c381c 1352 Safefree(HvARRAY(hv));
72940dca 1353#endif
3280af22 1354 PL_nomemok = FALSE;
72311751 1355 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
72940dca 1356 }
1357 else {
a02a5408 1358 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
72940dca 1359 }
cbec9347 1360 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
7b2c381c 1361 HvARRAY(hv) = (HE **) a;
cbec9347 1362 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
72940dca 1363 return;
1364
72311751
GS		 1365 aep = (HE**)a;
1366 for (i=0; i<oldsize; i++,aep++) {
1367 if (!*aep) /* non-existent */
72940dca 1368 continue;
72311751 1369 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
6136c704
AL		 1370 register I32 j = (HeHASH(entry) & newsize);
1371
1372 if (j != i) {
72940dca 1373 j -= i;
1374 *oentry = HeNEXT(entry);
72311751 1375 if (!(HeNEXT(entry) = aep[j]))
cbec9347 1376 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1377 aep[j] = entry;
72940dca 1378 continue;
1379 }
1380 else
1381 oentry = &HeNEXT(entry);
1382 }
72311751 1383 if (!*aep) /* everything moved */
cbec9347 1384 xhv->xhv_fill--; /* HvFILL(hv)-- */
72940dca 1385 }
1386}
1387
954c1994
GS		 1388/*
1389=for apidoc newHV
1390
1391Creates a new HV. The reference count is set to 1.
1392
1393=cut
1394*/
1395
79072805 1396HV *
864dbfa3 1397Perl_newHV(pTHX)
79072805 1398{
cbec9347 1399 register XPVHV* xhv;
b9f83d2f 1400 HV * const hv = (HV*)newSV_type(SVt_PVHV);
cbec9347 1401 xhv = (XPVHV*)SvANY(hv);
ce5d0612 1402 assert(!SvOK(hv));
1c846c1f 1403#ifndef NODEFAULT_SHAREKEYS
fde52b5c 1404 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1c846c1f 1405#endif
4b5190b5 1406
cbec9347
JH		 1407 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1408 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
79072805
LW		 1409 return hv;
1410}
1411
b3ac6de7 1412HV *
864dbfa3 1413Perl_newHVhv(pTHX_ HV *ohv)
b3ac6de7 1414{
9d4ba2ae 1415 HV * const hv = newHV();
4beac62f 1416 STRLEN hv_max, hv_fill;
4beac62f
AMS		 1417
1418 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1419 return hv;
4beac62f 1420 hv_max = HvMAX(ohv);
b3ac6de7 1421
b56ba0bf
AMS		 1422 if (!SvMAGICAL((SV *)ohv)) {
1423 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
eb160463 1424 STRLEN i;
a3b680e6 1425 const bool shared = !!HvSHAREKEYS(ohv);
aec46f14 1426 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
ff875642 1427 char *a;
a02a5408 1428 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
ff875642 1429 ents = (HE**)a;
b56ba0bf
AMS		 1430
1431 /* In each bucket... */
1432 for (i = 0; i <= hv_max; i++) {
6136c704 1433 HE *prev = NULL;
aec46f14 1434 HE *oent = oents[i];
b56ba0bf
AMS		 1435
1436 if (!oent) {
1437 ents[i] = NULL;
1438 continue;
1439 }
1440
1441 /* Copy the linked list of entries. */
aec46f14 1442 for (; oent; oent = HeNEXT(oent)) {
a3b680e6
AL		 1443 const U32 hash = HeHASH(oent);
1444 const char * const key = HeKEY(oent);
1445 const STRLEN len = HeKLEN(oent);
1446 const int flags = HeKFLAGS(oent);
6136c704 1447 HE * const ent = new_HE();
b56ba0bf 1448
45dea987 1449 HeVAL(ent) = newSVsv(HeVAL(oent));
19692e8d 1450 HeKEY_hek(ent)
6e838c70 1451 = shared ? share_hek_flags(key, len, hash, flags)
19692e8d 1452 : save_hek_flags(key, len, hash, flags);
b56ba0bf
AMS		 1453 if (prev)
1454 HeNEXT(prev) = ent;
1455 else
1456 ents[i] = ent;
1457 prev = ent;
1458 HeNEXT(ent) = NULL;
1459 }
1460 }
1461
1462 HvMAX(hv) = hv_max;
1463 HvFILL(hv) = hv_fill;
8aacddc1 1464 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
b56ba0bf 1465 HvARRAY(hv) = ents;
aec46f14 1466 } /* not magical */
b56ba0bf
AMS		 1467 else {
1468 /* Iterate over ohv, copying keys and values one at a time. */
b3ac6de7 1469 HE *entry;
bfcb3514
NC		 1470 const I32 riter = HvRITER_get(ohv);
1471 HE * const eiter = HvEITER_get(ohv);
b56ba0bf
AMS		 1472
1473 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1474 while (hv_max && hv_max + 1 >= hv_fill * 2)
1475 hv_max = hv_max / 2;
1476 HvMAX(hv) = hv_max;
1477
4a76a316 1478 hv_iterinit(ohv);
e16e2ff8 1479 while ((entry = hv_iternext_flags(ohv, 0))) {
19692e8d
NC		 1480 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1481 newSVsv(HeVAL(entry)), HeHASH(entry),
1482 HeKFLAGS(entry));
b3ac6de7 1483 }
bfcb3514
NC		 1484 HvRITER_set(ohv, riter);
1485 HvEITER_set(ohv, eiter);
b3ac6de7 1486 }
1c846c1f 1487
b3ac6de7
IZ		 1488 return hv;
1489}
1490
5b9c0671
NC		 1491/* A rather specialised version of newHVhv for copying %^H, ensuring all the
1492 magic stays on it. */
1493HV *
1494Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1495{
1496 HV * const hv = newHV();
1497 STRLEN hv_fill;
1498
1499 if (ohv && (hv_fill = HvFILL(ohv))) {
1500 STRLEN hv_max = HvMAX(ohv);
1501 HE *entry;
1502 const I32 riter = HvRITER_get(ohv);
1503 HE * const eiter = HvEITER_get(ohv);
1504
1505 while (hv_max && hv_max + 1 >= hv_fill * 2)
1506 hv_max = hv_max / 2;
1507 HvMAX(hv) = hv_max;
1508
1509 hv_iterinit(ohv);
1510 while ((entry = hv_iternext_flags(ohv, 0))) {
1511 SV *const sv = newSVsv(HeVAL(entry));
1512 sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1513 (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
1514 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1515 sv, HeHASH(entry), HeKFLAGS(entry));
1516 }
1517 HvRITER_set(ohv, riter);
1518 HvEITER_set(ohv, eiter);
1519 }
1520 hv_magic(hv, NULL, PERL_MAGIC_hints);
1521 return hv;
1522}
1523
79072805 1524void
864dbfa3 1525Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
79072805 1526{
97aff369 1527 dVAR;
16bdeea2
GS		 1528 SV *val;
1529
68dc0745 1530 if (!entry)
79072805 1531 return;
16bdeea2 1532 val = HeVAL(entry);
bfcb3514 1533 if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
e1a479c5 1534 mro_method_changed_in(hv); /* deletion of method from stash */
16bdeea2 1535 SvREFCNT_dec(val);
68dc0745 1536 if (HeKLEN(entry) == HEf_SVKEY) {
1537 SvREFCNT_dec(HeKEY_sv(entry));
8aacddc1 1538 Safefree(HeKEY_hek(entry));
44a8e56a 1539 }
1540 else if (HvSHAREKEYS(hv))
68dc0745 1541 unshare_hek(HeKEY_hek(entry));
fde52b5c 1542 else
68dc0745 1543 Safefree(HeKEY_hek(entry));
d33b2eba 1544 del_HE(entry);
79072805
LW		 1545}
1546
1547void
864dbfa3 1548Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
79072805 1549{
97aff369 1550 dVAR;
68dc0745 1551 if (!entry)
79072805 1552 return;
bc4947fc
NC		 1553 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1554 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
68dc0745 1555 if (HeKLEN(entry) == HEf_SVKEY) {
bc4947fc 1556 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
44a8e56a 1557 }
bc4947fc 1558 hv_free_ent(hv, entry);
79072805
LW		 1559}
1560
954c1994
GS		 1561/*
1562=for apidoc hv_clear
1563
1564Clears a hash, making it empty.
1565
1566=cut
1567*/
1568
79072805 1569void
864dbfa3 1570Perl_hv_clear(pTHX_ HV *hv)
79072805 1571{
27da23d5 1572 dVAR;
cbec9347 1573 register XPVHV* xhv;
79072805
LW		 1574 if (!hv)
1575 return;
49293501 1576
ecae49c0
NC		 1577 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1578
34c3c4e3
DM		 1579 xhv = (XPVHV*)SvANY(hv);
1580
7b2c381c 1581 if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
34c3c4e3 1582 /* restricted hash: convert all keys to placeholders */
b464bac0
AL		 1583 STRLEN i;
1584 for (i = 0; i <= xhv->xhv_max; i++) {
7b2c381c 1585 HE *entry = (HvARRAY(hv))[i];
3a676441
JH		 1586 for (; entry; entry = HeNEXT(entry)) {
1587 /* not already placeholder */
7996736c 1588 if (HeVAL(entry) != &PL_sv_placeholder) {
3a676441 1589 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
6136c704 1590 SV* const keysv = hv_iterkeysv(entry);
3a676441 1591 Perl_croak(aTHX_
95b63a38
JH		 1592 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1593 (void*)keysv);
3a676441
JH		 1594 }
1595 SvREFCNT_dec(HeVAL(entry));
7996736c 1596 HeVAL(entry) = &PL_sv_placeholder;
ca732855 1597 HvPLACEHOLDERS(hv)++;
3a676441 1598 }
34c3c4e3
DM		 1599 }
1600 }
df8c6964 1601 goto reset;
49293501
MS		 1602 }
1603
463ee0b2 1604 hfreeentries(hv);
ca732855 1605 HvPLACEHOLDERS_set(hv, 0);
7b2c381c 1606 if (HvARRAY(hv))
41f62432 1607 Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
a0d0e21e
LW		 1608
1609 if (SvRMAGICAL(hv))
1c846c1f 1610 mg_clear((SV*)hv);
574c8022 1611
19692e8d 1612 HvHASKFLAGS_off(hv);
bb443f97 1613 HvREHASH_off(hv);
df8c6964 1614 reset:
b79f7545 1615 if (SvOOK(hv)) {
bfcb3514
NC		 1616 HvEITER_set(hv, NULL);
1617 }
79072805
LW		 1618}
1619
3540d4ce
AB		 1620/*
1621=for apidoc hv_clear_placeholders
1622
1623Clears any placeholders from a hash. If a restricted hash has any of its keys
1624marked as readonly and the key is subsequently deleted, the key is not actually
1625deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1626it so it will be ignored by future operations such as iterating over the hash,
4cdaeff7 1627but will still allow the hash to have a value reassigned to the key at some
3540d4ce
AB		 1628future point. This function clears any such placeholder keys from the hash.
1629See Hash::Util::lock_keys() for an example of its use.
1630
1631=cut
1632*/
1633
1634void
1635Perl_hv_clear_placeholders(pTHX_ HV *hv)
1636{
27da23d5 1637 dVAR;
b3ca2e83
NC		 1638 const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1639
1640 if (items)
1641 clear_placeholders(hv, items);
1642}
1643
1644static void
1645S_clear_placeholders(pTHX_ HV *hv, U32 items)
1646{
1647 dVAR;
b464bac0 1648 I32 i;
d3677389
NC		 1649
1650 if (items == 0)
1651 return;
1652
b464bac0 1653 i = HvMAX(hv);
d3677389
NC		 1654 do {
1655 /* Loop down the linked list heads */
6136c704 1656 bool first = TRUE;
d3677389 1657 HE **oentry = &(HvARRAY(hv))[i];
cf6db12b 1658 HE *entry;
d3677389 1659
cf6db12b 1660 while ((entry = *oentry)) {
d3677389
NC		 1661 if (HeVAL(entry) == &PL_sv_placeholder) {
1662 *oentry = HeNEXT(entry);
1663 if (first && !*oentry)
1664 HvFILL(hv)--; /* This linked list is now empty. */
2e58978b 1665 if (entry == HvEITER_get(hv))
d3677389
NC		 1666 HvLAZYDEL_on(hv);
1667 else
1668 hv_free_ent(hv, entry);
1669
1670 if (--items == 0) {
1671 /* Finished. */
5d88ecd7 1672 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
d3677389
NC		 1673 if (HvKEYS(hv) == 0)
1674 HvHASKFLAGS_off(hv);
5d88ecd7 1675 HvPLACEHOLDERS_set(hv, 0);
d3677389
NC		 1676 return;
1677 }
213ce8b3
NC		 1678 } else {
1679 oentry = &HeNEXT(entry);
6136c704 1680 first = FALSE;
d3677389
NC		 1681 }
1682 }
1683 } while (--i >= 0);
1684 /* You can't get here, hence assertion should always fail. */
1685 assert (items == 0);
1686 assert (0);
3540d4ce
AB		 1687}
1688
76e3520e 1689STATIC void
cea2e8a9 1690S_hfreeentries(pTHX_ HV *hv)
79072805 1691{
23976bdd 1692 /* This is the array that we're going to restore */
fd7de8a8 1693 HE **const orig_array = HvARRAY(hv);
23976bdd
NC		 1694 HEK *name;
1695 int attempts = 100;
3abe233e 1696
fd7de8a8 1697 if (!orig_array)
79072805 1698 return;
a0d0e21e 1699
23976bdd
NC		 1700 if (SvOOK(hv)) {
1701 /* If the hash is actually a symbol table with a name, look after the
1702 name. */
1703 struct xpvhv_aux *iter = HvAUX(hv);
1704
1705 name = iter->xhv_name;
1706 iter->xhv_name = NULL;
1707 } else {
1708 name = NULL;
1709 }
1710
23976bdd
NC		 1711 /* orig_array remains unchanged throughout the loop. If after freeing all
1712 the entries it turns out that one of the little blighters has triggered
1713 an action that has caused HvARRAY to be re-allocated, then we set
1714 array to the new HvARRAY, and try again. */
1715
1716 while (1) {
1717 /* This is the one we're going to try to empty. First time round
1718 it's the original array. (Hopefully there will only be 1 time
1719 round) */
6136c704 1720 HE ** const array = HvARRAY(hv);
7440661e 1721 I32 i = HvMAX(hv);
23976bdd
NC		 1722
1723 /* Because we have taken xhv_name out, the only allocated pointer
1724 in the aux structure that might exist is the backreference array.
1725 */
1726
1727 if (SvOOK(hv)) {
7440661e 1728 HE *entry;
e1a479c5 1729 struct mro_meta *meta;
23976bdd
NC		 1730 struct xpvhv_aux *iter = HvAUX(hv);
1731 /* If there are weak references to this HV, we need to avoid
1732 freeing them up here. In particular we need to keep the AV
1733 visible as what we're deleting might well have weak references
1734 back to this HV, so the for loop below may well trigger
1735 the removal of backreferences from this array. */
1736
1737 if (iter->xhv_backreferences) {
1738 /* So donate them to regular backref magic to keep them safe.
1739 The sv_magic will increase the reference count of the AV,
1740 so we need to drop it first. */
5b285ea4 1741 SvREFCNT_dec(iter->xhv_backreferences);
23976bdd
NC		 1742 if (AvFILLp(iter->xhv_backreferences) == -1) {
1743 /* Turns out that the array is empty. Just free it. */
1744 SvREFCNT_dec(iter->xhv_backreferences);
1b8791d1 1745
23976bdd
NC		 1746 } else {
1747 sv_magic((SV*)hv, (SV*)iter->xhv_backreferences,
1748 PERL_MAGIC_backref, NULL, 0);
1749 }
1750 iter->xhv_backreferences = NULL;
5b285ea4 1751 }
86f55936 1752
23976bdd
NC		 1753 entry = iter->xhv_eiter; /* HvEITER(hv) */
1754 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1755 HvLAZYDEL_off(hv);
1756 hv_free_ent(hv, entry);
1757 }
1758 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1759 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
b79f7545 1760
e1a479c5
BB		 1761 if((meta = iter->xhv_mro_meta)) {
1762 if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs);
1763 if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3);
1764 if(meta->mro_isarev) SvREFCNT_dec(meta->mro_isarev);
1765 if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
1766 Safefree(meta);
1767 iter->xhv_mro_meta = NULL;
1768 }
1769
23976bdd 1770 /* There are now no allocated pointers in the aux structure. */
2f86008e 1771
23976bdd
NC		 1772 SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
1773 /* What aux structure? */
a0d0e21e 1774 }
bfcb3514 1775
23976bdd
NC		 1776 /* make everyone else think the array is empty, so that the destructors
1777 * called for freed entries can't recusively mess with us */
1778 HvARRAY(hv) = NULL;
1779 HvFILL(hv) = 0;
1780 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1781
7440661e
NC		 1782
1783 do {
1784 /* Loop down the linked list heads */
1785 HE *entry = array[i];
1786
1787 while (entry) {
23976bdd
NC		 1788 register HE * const oentry = entry;
1789 entry = HeNEXT(entry);
1790 hv_free_ent(hv, oentry);
1791 }
7440661e 1792 } while (--i >= 0);
b79f7545 1793
23976bdd
NC		 1794 /* As there are no allocated pointers in the aux structure, it's now
1795 safe to free the array we just cleaned up, if it's not the one we're
1796 going to put back. */
1797 if (array != orig_array) {
1798 Safefree(array);
1799 }
b79f7545 1800
23976bdd
NC		 1801 if (!HvARRAY(hv)) {
1802 /* Good. No-one added anything this time round. */
1803 break;
bfcb3514 1804 }
b79f7545 1805
23976bdd
NC		 1806 if (SvOOK(hv)) {
1807 /* Someone attempted to iterate or set the hash name while we had
1808 the array set to 0. We'll catch backferences on the next time
1809 round the while loop. */
1810 assert(HvARRAY(hv));
1b8791d1 1811
23976bdd
NC		 1812 if (HvAUX(hv)->xhv_name) {
1813 unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
1814 }
1815 }
1816
1817 if (--attempts == 0) {
1818 Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
1819 }
6136c704 1820 }
23976bdd
NC		 1821
1822 HvARRAY(hv) = orig_array;
1823
1824 /* If the hash was actually a symbol table, put the name back. */
1825 if (name) {
1826 /* We have restored the original array. If name is non-NULL, then
1827 the original array had an aux structure at the end. So this is
1828 valid: */
1829 SvFLAGS(hv) |= SVf_OOK;
1830 HvAUX(hv)->xhv_name = name;
1b8791d1 1831 }
79072805
LW		 1832}
1833
954c1994
GS		 1834/*
1835=for apidoc hv_undef
1836
1837Undefines the hash.
1838
1839=cut
1840*/
1841
79072805 1842void
864dbfa3 1843Perl_hv_undef(pTHX_ HV *hv)
79072805 1844{
97aff369 1845 dVAR;
cbec9347 1846 register XPVHV* xhv;
bfcb3514 1847 const char *name;
86f55936 1848
79072805
LW		 1849 if (!hv)
1850 return;
ecae49c0 1851 DEBUG_A(Perl_hv_assert(aTHX_ hv));
cbec9347 1852 xhv = (XPVHV*)SvANY(hv);
463ee0b2 1853 hfreeentries(hv);
bfcb3514 1854 if ((name = HvNAME_get(hv))) {
7e8961ec 1855 if(PL_stashcache)
7423f6db 1856 hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
bd61b366 1857 hv_name_set(hv, NULL, 0, 0);
85e6fe83 1858 }
b79f7545
NC		 1859 SvFLAGS(hv) &= ~SVf_OOK;
1860 Safefree(HvARRAY(hv));
cbec9347 1861 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
7b2c381c 1862 HvARRAY(hv) = 0;
ca732855 1863 HvPLACEHOLDERS_set(hv, 0);
a0d0e21e
LW		 1864
1865 if (SvRMAGICAL(hv))
1c846c1f 1866 mg_clear((SV*)hv);
79072805
LW		 1867}
1868
b464bac0 1869static struct xpvhv_aux*
5f66b61c 1870S_hv_auxinit(HV *hv) {
bfcb3514 1871 struct xpvhv_aux *iter;
b79f7545 1872 char *array;
bfcb3514 1873
b79f7545 1874 if (!HvARRAY(hv)) {
a02a5408 1875 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
b79f7545
NC		 1876 + sizeof(struct xpvhv_aux), char);
1877 } else {
1878 array = (char *) HvARRAY(hv);
1879 Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1880 + sizeof(struct xpvhv_aux), char);
1881 }
1882 HvARRAY(hv) = (HE**) array;
1883 /* SvOOK_on(hv) attacks the IV flags. */
1884 SvFLAGS(hv) |= SVf_OOK;
1885 iter = HvAUX(hv);
bfcb3514
NC		 1886
1887 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1888 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
bfcb3514 1889 iter->xhv_name = 0;
86f55936 1890 iter->xhv_backreferences = 0;
e1a479c5 1891 iter->xhv_mro_meta = NULL;
bfcb3514
NC		 1892 return iter;
1893}
1894
954c1994
GS		 1895/*
1896=for apidoc hv_iterinit
1897
1898Prepares a starting point to traverse a hash table. Returns the number of
1899keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1c846c1f 1900currently only meaningful for hashes without tie magic.
954c1994
GS		 1901
1902NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1903hash buckets that happen to be in use. If you still need that esoteric
1904value, you can get it through the macro C<HvFILL(tb)>.
1905
e16e2ff8 1906
954c1994
GS		 1907=cut
1908*/
1909
79072805 1910I32
864dbfa3 1911Perl_hv_iterinit(pTHX_ HV *hv)
79072805 1912{
aa689395 1913 if (!hv)
cea2e8a9 1914 Perl_croak(aTHX_ "Bad hash");
bfcb3514 1915
b79f7545 1916 if (SvOOK(hv)) {
6136c704 1917 struct xpvhv_aux * const iter = HvAUX(hv);
0bd48802 1918 HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
bfcb3514
NC		 1919 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1920 HvLAZYDEL_off(hv);
1921 hv_free_ent(hv, entry);
1922 }
1923 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
4608196e 1924 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
bfcb3514 1925 } else {
6136c704 1926 hv_auxinit(hv);
72940dca 1927 }
44a2ac75 1928
cbec9347 1929 /* used to be xhv->xhv_fill before 5.004_65 */
5d88ecd7 1930 return HvTOTALKEYS(hv);
79072805 1931}
bfcb3514
NC		 1932
1933I32 *
1934Perl_hv_riter_p(pTHX_ HV *hv) {
1935 struct xpvhv_aux *iter;
1936
1937 if (!hv)
1938 Perl_croak(aTHX_ "Bad hash");
1939
6136c704 1940 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
bfcb3514
NC		 1941 return &(iter->xhv_riter);
1942}
1943
1944HE **
1945Perl_hv_eiter_p(pTHX_ HV *hv) {
1946 struct xpvhv_aux *iter;
1947
1948 if (!hv)
1949 Perl_croak(aTHX_ "Bad hash");
1950
6136c704 1951 iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
bfcb3514
NC		 1952 return &(iter->xhv_eiter);
1953}
1954
1955void
1956Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
1957 struct xpvhv_aux *iter;
1958
1959 if (!hv)
1960 Perl_croak(aTHX_ "Bad hash");
1961
b79f7545
NC		 1962 if (SvOOK(hv)) {
1963 iter = HvAUX(hv);
1964 } else {
bfcb3514
NC		 1965 if (riter == -1)
1966 return;
1967
6136c704 1968 iter = hv_auxinit(hv);
bfcb3514
NC		 1969 }
1970 iter->xhv_riter = riter;
1971}
1972
1973void
1974Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
1975 struct xpvhv_aux *iter;
1976
1977 if (!hv)
1978 Perl_croak(aTHX_ "Bad hash");
1979
b79f7545
NC		 1980 if (SvOOK(hv)) {
1981 iter = HvAUX(hv);
1982 } else {
bfcb3514
NC		 1983 /* 0 is the default so don't go malloc()ing a new structure just to
1984 hold 0. */
1985 if (!eiter)
1986 return;
1987
6136c704 1988 iter = hv_auxinit(hv);
bfcb3514
NC		 1989 }
1990 iter->xhv_eiter = eiter;
1991}
1992
bfcb3514 1993void
4164be69 1994Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
bfcb3514 1995{
97aff369 1996 dVAR;
b79f7545 1997 struct xpvhv_aux *iter;
7423f6db 1998 U32 hash;
46c461b5
AL		 1999
2000 PERL_UNUSED_ARG(flags);
bfcb3514 2001
4164be69
NC		 2002 if (len > I32_MAX)
2003 Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2004
b79f7545
NC		 2005 if (SvOOK(hv)) {
2006 iter = HvAUX(hv);
7423f6db
NC		 2007 if (iter->xhv_name) {
2008 unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
2009 }
16580ff5 2010 } else {
bfcb3514
NC		 2011 if (name == 0)
2012 return;
2013
6136c704 2014 iter = hv_auxinit(hv);
bfcb3514 2015 }
7423f6db
NC		 2016 PERL_HASH(hash, name, len);
2017 iter->xhv_name = name ? share_hek(name, len, hash) : 0;
bfcb3514
NC		 2018}
2019
86f55936
NC		 2020AV **
2021Perl_hv_backreferences_p(pTHX_ HV *hv) {
6136c704 2022 struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
96a5add6 2023 PERL_UNUSED_CONTEXT;
86f55936
NC		 2024 return &(iter->xhv_backreferences);
2025}
2026
2027void
2028Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2029 AV *av;
2030
2031 if (!SvOOK(hv))
2032 return;
2033
2034 av = HvAUX(hv)->xhv_backreferences;
2035
2036 if (av) {
2037 HvAUX(hv)->xhv_backreferences = 0;
2038 Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av);
2039 }
2040}
2041
954c1994 2042/*
7a7b9979
NC		 2043hv_iternext is implemented as a macro in hv.h
2044
954c1994
GS		 2045=for apidoc hv_iternext
2046
2047Returns entries from a hash iterator. See C<hv_iterinit>.
2048
fe7bca90
NC		 2049You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
2050iterator currently points to, without losing your place or invalidating your
2051iterator. Note that in this case the current entry is deleted from the hash
2052with your iterator holding the last reference to it. Your iterator is flagged
2053to free the entry on the next call to C<hv_iternext>, so you must not discard
2054your iterator immediately else the entry will leak - call C<hv_iternext> to
2055trigger the resource deallocation.
2056
fe7bca90
NC		 2057=for apidoc hv_iternext_flags
2058
2059Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
2060The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2061set the placeholders keys (for restricted hashes) will be returned in addition
2062to normal keys. By default placeholders are automatically skipped over.
7996736c
MHM		 2063Currently a placeholder is implemented with a value that is
2064C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
fe7bca90
NC		 2065restricted hashes may change, and the implementation currently is
2066insufficiently abstracted for any change to be tidy.
e16e2ff8 2067
fe7bca90 2068=cut
e16e2ff8
NC		 2069*/
2070
2071HE *
2072Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2073{
27da23d5 2074 dVAR;
cbec9347 2075 register XPVHV* xhv;
79072805 2076 register HE *entry;
a0d0e21e 2077 HE *oldentry;
463ee0b2 2078 MAGIC* mg;
bfcb3514 2079 struct xpvhv_aux *iter;
79072805
LW		 2080
2081 if (!hv)
cea2e8a9 2082 Perl_croak(aTHX_ "Bad hash");
81714fb9 2083
cbec9347 2084 xhv = (XPVHV*)SvANY(hv);
bfcb3514 2085
b79f7545 2086 if (!SvOOK(hv)) {
bfcb3514
NC		 2087 /* Too many things (well, pp_each at least) merrily assume that you can
2088 call iv_iternext without calling hv_iterinit, so we'll have to deal
2089 with it. */
2090 hv_iterinit(hv);
bfcb3514 2091 }
b79f7545 2092 iter = HvAUX(hv);
bfcb3514
NC		 2093
2094 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
e62cc96a 2095 if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
44a2ac75 2096 if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
e62cc96a
YO		 2097 SV * const key = sv_newmortal();
2098 if (entry) {
2099 sv_setsv(key, HeSVKEY_force(entry));
2100 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
2101 }
2102 else {
2103 char *k;
2104 HEK *hek;
2105
2106 /* one HE per MAGICAL hash */
2107 iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2108 Zero(entry, 1, HE);
2109 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
2110 hek = (HEK*)k;
2111 HeKEY_hek(entry) = hek;
2112 HeKLEN(entry) = HEf_SVKEY;
2113 }
2114 magic_nextpack((SV*) hv,mg,key);
2115 if (SvOK(key)) {
2116 /* force key to stay around until next time */
2117 HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2118 return entry; /* beware, hent_val is not set */
2119 }
2120 if (HeVAL(entry))
2121 SvREFCNT_dec(HeVAL(entry));
2122 Safefree(HeKEY_hek(entry));
2123 del_HE(entry);
2124 iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2125 return NULL;
81714fb9 2126 }
79072805 2127 }
7ee146b1 2128#if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
03026e68 2129 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
f675dbe5 2130 prime_env_iter();
03026e68
JM		 2131#ifdef VMS
2132 /* The prime_env_iter() on VMS just loaded up new hash values
2133 * so the iteration count needs to be reset back to the beginning
2134 */
2135 hv_iterinit(hv);
2136 iter = HvAUX(hv);
2137 oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2138#endif
2139 }
f675dbe5 2140#endif
463ee0b2 2141
b79f7545
NC		 2142 /* hv_iterint now ensures this. */
2143 assert (HvARRAY(hv));
2144
015a5f36 2145 /* At start of hash, entry is NULL. */
fde52b5c 2146 if (entry)
8aacddc1 2147 {
fde52b5c 2148 entry = HeNEXT(entry);
e16e2ff8
NC		 2149 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2150 /*
2151 * Skip past any placeholders -- don't want to include them in
2152 * any iteration.
2153 */
7996736c 2154 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
e16e2ff8
NC		 2155 entry = HeNEXT(entry);
2156 }
8aacddc1
NIS		 2157 }
2158 }
fde52b5c 2159 while (!entry) {
015a5f36
NC		 2160 /* OK. Come to the end of the current list. Grab the next one. */
2161
bfcb3514
NC		 2162 iter->xhv_riter++; /* HvRITER(hv)++ */
2163 if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
015a5f36 2164 /* There is no next one. End of the hash. */
bfcb3514 2165 iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
fde52b5c 2166 break;
79072805 2167 }
7b2c381c 2168 entry = (HvARRAY(hv))[iter->xhv_riter];
8aacddc1 2169
e16e2ff8 2170 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
015a5f36
NC		 2171 /* If we have an entry, but it's a placeholder, don't count it.
2172 Try the next. */
7996736c 2173 while (entry && HeVAL(entry) == &PL_sv_placeholder)
015a5f36
NC		 2174 entry = HeNEXT(entry);
2175 }
2176 /* Will loop again if this linked list starts NULL
2177 (for HV_ITERNEXT_WANTPLACEHOLDERS)
2178 or if we run through it and find only placeholders. */
fde52b5c 2179 }
79072805 2180
72940dca 2181 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
2182 HvLAZYDEL_off(hv);
68dc0745 2183 hv_free_ent(hv, oldentry);
72940dca 2184 }
a0d0e21e 2185
fdcd69b6 2186 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
6c9570dc 2187 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
fdcd69b6 2188
bfcb3514 2189 iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
79072805
LW		 2190 return entry;
2191}
2192
954c1994
GS		 2193/*
2194=for apidoc hv_iterkey
2195
2196Returns the key from the current position of the hash iterator. See
2197C<hv_iterinit>.
2198
2199=cut
2200*/
2201
79072805 2202char *
864dbfa3 2203Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 2204{
fde52b5c 2205 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a 2206 STRLEN len;
0bd48802 2207 char * const p = SvPV(HeKEY_sv(entry), len);
fb73857a 2208 *retlen = len;
2209 return p;
fde52b5c 2210 }
2211 else {
2212 *retlen = HeKLEN(entry);
2213 return HeKEY(entry);
2214 }
2215}
2216
2217/* unlike hv_iterval(), this always returns a mortal copy of the key */
954c1994
GS		 2218/*
2219=for apidoc hv_iterkeysv
2220
2221Returns the key as an C<SV*> from the current position of the hash
2222iterator. The return value will always be a mortal copy of the key. Also
2223see C<hv_iterinit>.
2224
2225=cut
2226*/
2227
fde52b5c 2228SV *
864dbfa3 2229Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c 2230{
c1b02ed8 2231 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
79072805
LW		 2232}
2233
954c1994
GS		 2234/*
2235=for apidoc hv_iterval
2236
2237Returns the value from the current position of the hash iterator. See
2238C<hv_iterkey>.
2239
2240=cut
2241*/
2242
79072805 2243SV *
864dbfa3 2244Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 2245{
8990e307 2246 if (SvRMAGICAL(hv)) {
14befaf4 2247 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
c4420975 2248 SV* const sv = sv_newmortal();
bbce6d69 2249 if (HeKLEN(entry) == HEf_SVKEY)
2250 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
a3b680e6
AL		 2251 else
2252 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
463ee0b2
LW		 2253 return sv;
2254 }
79072805 2255 }
fde52b5c 2256 return HeVAL(entry);
79072805
LW		 2257}
2258
954c1994
GS		 2259/*
2260=for apidoc hv_iternextsv
2261
2262Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
2263operation.
2264
2265=cut
2266*/
2267
a0d0e21e 2268SV *
864dbfa3 2269Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e 2270{
0bd48802
AL		 2271 HE * const he = hv_iternext_flags(hv, 0);
2272
2273 if (!he)
a0d0e21e
LW		 2274 return NULL;
2275 *key = hv_iterkey(he, retlen);
2276 return hv_iterval(hv, he);
2277}
2278
954c1994 2279/*
bc5cdc23
NC		 2280
2281Now a macro in hv.h
2282
954c1994
GS		 2283=for apidoc hv_magic
2284
2285Adds magic to a hash. See C<sv_magic>.
2286
2287=cut
2288*/
2289
bbce6d69 2290/* possibly free a shared string if no one has access to it
fde52b5c 2291 * len and hash must both be valid for str.
2292 */
bbce6d69 2293void
864dbfa3 2294Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 2295{
19692e8d
NC		 2296 unshare_hek_or_pvn (NULL, str, len, hash);
2297}
2298
2299
2300void
2301Perl_unshare_hek(pTHX_ HEK *hek)
2302{
bf11fd37 2303 assert(hek);
19692e8d
NC		 2304 unshare_hek_or_pvn(hek, NULL, 0, 0);
2305}
2306
2307/* possibly free a shared string if no one has access to it
2308 hek if non-NULL takes priority over the other 3, else str, len and hash
2309 are used. If so, len and hash must both be valid for str.
2310 */
df132699 2311STATIC void
97ddebaf 2312S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
19692e8d 2313{
97aff369 2314 dVAR;
cbec9347 2315 register XPVHV* xhv;
20454177 2316 HE *entry;
fde52b5c 2317 register HE **oentry;
45d1cc86 2318 HE **first;
c3654f1a 2319 bool is_utf8 = FALSE;
19692e8d 2320 int k_flags = 0;
aec46f14 2321 const char * const save = str;
cbbf8932 2322 struct shared_he *he = NULL;
c3654f1a 2323
19692e8d 2324 if (hek) {
cbae3960
NC		 2325 /* Find the shared he which is just before us in memory. */
2326 he = (struct shared_he *)(((char *)hek)
2327 - STRUCT_OFFSET(struct shared_he,
2328 shared_he_hek));
2329
2330 /* Assert that the caller passed us a genuine (or at least consistent)
2331 shared hek */
2332 assert (he->shared_he_he.hent_hek == hek);
29404ae0
NC		 2333
2334 LOCK_STRTAB_MUTEX;
de616631
NC		 2335 if (he->shared_he_he.he_valu.hent_refcount - 1) {
2336 --he->shared_he_he.he_valu.hent_refcount;
29404ae0
NC		 2337 UNLOCK_STRTAB_MUTEX;
2338 return;
2339 }
2340 UNLOCK_STRTAB_MUTEX;
2341
19692e8d
NC		 2342 hash = HEK_HASH(hek);
2343 } else if (len < 0) {
2344 STRLEN tmplen = -len;
2345 is_utf8 = TRUE;
2346 /* See the note in hv_fetch(). --jhi */
2347 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2348 len = tmplen;
2349 if (is_utf8)
2350 k_flags = HVhek_UTF8;
2351 if (str != save)
2352 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
c3654f1a 2353 }
1c846c1f 2354
de616631 2355 /* what follows was the moral equivalent of:
6b88bc9c 2356 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
a0714e2c 2357 if (--*Svp == NULL)
6b88bc9c 2358 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 2359 } */
cbec9347 2360 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2361 /* assert(xhv_array != 0) */
5f08fbcd 2362 LOCK_STRTAB_MUTEX;
45d1cc86 2363 first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
6c1b96a1
NC		 2364 if (he) {
2365 const HE *const he_he = &(he->shared_he_he);
45d1cc86 2366 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
35ab5632
NC		 2367 if (entry == he_he)
2368 break;
19692e8d
NC		 2369 }
2370 } else {
35a4481c 2371 const int flags_masked = k_flags & HVhek_MASK;
45d1cc86 2372 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
19692e8d
NC		 2373 if (HeHASH(entry) != hash) /* strings can't be equal */
2374 continue;
2375 if (HeKLEN(entry) != len)
2376 continue;
2377 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2378 continue;
2379 if (HeKFLAGS(entry) != flags_masked)
2380 continue;
19692e8d
NC		 2381 break;
2382 }
2383 }
2384
35ab5632
NC		 2385 if (entry) {
2386 if (--entry->he_valu.hent_refcount == 0) {
19692e8d 2387 *oentry = HeNEXT(entry);
45d1cc86
NC		 2388 if (!*first) {
2389 /* There are now no entries in our slot. */
19692e8d 2390 xhv->xhv_fill--; /* HvFILL(hv)-- */
45d1cc86 2391 }
cbae3960 2392 Safefree(entry);
4c7185a0 2393 xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
19692e8d 2394 }
fde52b5c 2395 }
19692e8d 2396
333f433b 2397 UNLOCK_STRTAB_MUTEX;
35ab5632 2398 if (!entry && ckWARN_d(WARN_INTERNAL))
19692e8d 2399 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
472d47bc
SB		 2400 "Attempt to free non-existent shared string '%s'%s"
2401 pTHX__FORMAT,
19692e8d 2402 hek ? HEK_KEY(hek) : str,
472d47bc 2403 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
19692e8d
NC		 2404 if (k_flags & HVhek_FREEKEY)
2405 Safefree(str);
fde52b5c 2406}
2407
bbce6d69 2408/* get a (constant) string ptr from the global string table
2409 * string will get added if it is not already there.
fde52b5c 2410 * len and hash must both be valid for str.
2411 */
bbce6d69 2412HEK *
864dbfa3 2413Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 2414{
da58a35d 2415 bool is_utf8 = FALSE;
19692e8d 2416 int flags = 0;
aec46f14 2417 const char * const save = str;
da58a35d
JH		 2418
2419 if (len < 0) {
77caf834 2420 STRLEN tmplen = -len;
da58a35d 2421 is_utf8 = TRUE;
77caf834
JH		 2422 /* See the note in hv_fetch(). --jhi */
2423 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2424 len = tmplen;
19692e8d
NC		 2425 /* If we were able to downgrade here, then than means that we were passed
2426 in a key which only had chars 0-255, but was utf8 encoded. */
2427 if (is_utf8)
2428 flags = HVhek_UTF8;
2429 /* If we found we were able to downgrade the string to bytes, then
2430 we should flag that it needs upgrading on keys or each. Also flag
2431 that we need share_hek_flags to free the string. */
2432 if (str != save)
2433 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2434 }
2435
6e838c70 2436 return share_hek_flags (str, len, hash, flags);
19692e8d
NC		 2437}
2438
6e838c70 2439STATIC HEK *
19692e8d
NC		 2440S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2441{
97aff369 2442 dVAR;
19692e8d 2443 register HE *entry;
35a4481c 2444 const int flags_masked = flags & HVhek_MASK;
263cb4a6 2445 const U32 hindex = hash & (I32) HvMAX(PL_strtab);
bbce6d69 2446
fde52b5c 2447 /* what follows is the moral equivalent of:
1c846c1f 2448
6b88bc9c 2449 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
a0714e2c 2450 hv_store(PL_strtab, str, len, NULL, hash);
fdcd69b6
NC		 2451
2452 Can't rehash the shared string table, so not sure if it's worth
2453 counting the number of entries in the linked list
bbce6d69 2454 */
1b6737cc 2455 register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2456 /* assert(xhv_array != 0) */
5f08fbcd 2457 LOCK_STRTAB_MUTEX;
263cb4a6
NC		 2458 entry = (HvARRAY(PL_strtab))[hindex];
2459 for (;entry; entry = HeNEXT(entry)) {
fde52b5c 2460 if (HeHASH(entry) != hash) /* strings can't be equal */
2461 continue;
2462 if (HeKLEN(entry) != len)
2463 continue;
1c846c1f 2464 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 2465 continue;
19692e8d 2466 if (HeKFLAGS(entry) != flags_masked)
c3654f1a 2467 continue;
fde52b5c 2468 break;
2469 }
263cb4a6
NC		 2470
2471 if (!entry) {
45d1cc86
NC		 2472 /* What used to be head of the list.
2473 If this is NULL, then we're the first entry for this slot, which
2474 means we need to increate fill. */
cbae3960
NC		 2475 struct shared_he *new_entry;
2476 HEK *hek;
2477 char *k;
263cb4a6
NC		 2478 HE **const head = &HvARRAY(PL_strtab)[hindex];
2479 HE *const next = *head;
cbae3960
NC		 2480
2481 /* We don't actually store a HE from the arena and a regular HEK.
2482 Instead we allocate one chunk of memory big enough for both,
2483 and put the HEK straight after the HE. This way we can find the
2484 HEK directly from the HE.
2485 */
2486
a02a5408 2487 Newx(k, STRUCT_OFFSET(struct shared_he,
cbae3960
NC		 2488 shared_he_hek.hek_key[0]) + len + 2, char);
2489 new_entry = (struct shared_he *)k;
2490 entry = &(new_entry->shared_he_he);
2491 hek = &(new_entry->shared_he_hek);
2492
2493 Copy(str, HEK_KEY(hek), len, char);
2494 HEK_KEY(hek)[len] = 0;
2495 HEK_LEN(hek) = len;
2496 HEK_HASH(hek) = hash;
2497 HEK_FLAGS(hek) = (unsigned char)flags_masked;
2498
2499 /* Still "point" to the HEK, so that other code need not know what
2500 we're up to. */
2501 HeKEY_hek(entry) = hek;
de616631 2502 entry->he_valu.hent_refcount = 0;
263cb4a6
NC		 2503 HeNEXT(entry) = next;
2504 *head = entry;
cbae3960 2505
4c7185a0 2506 xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
263cb4a6 2507 if (!next) { /* initial entry? */
cbec9347 2508 xhv->xhv_fill++; /* HvFILL(hv)++ */
4c9cc595 2509 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
cbec9347 2510 hsplit(PL_strtab);
bbce6d69 2511 }
2512 }
2513
de616631 2514 ++entry->he_valu.hent_refcount;
5f08fbcd 2515 UNLOCK_STRTAB_MUTEX;
19692e8d
NC		 2516
2517 if (flags & HVhek_FREEKEY)
f9a63242 2518 Safefree(str);
19692e8d 2519
6e838c70 2520 return HeKEY_hek(entry);
fde52b5c 2521}
ecae49c0 2522
1e73acc8
AS		 2523STATIC SV *
2524S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action)
2525{
2526 MAGIC* mg;
2527 if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
2528 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2529 if (uf->uf_set == NULL) {
2530 SV* obj = mg->mg_obj;
2531 mg->mg_obj = keysv; /* pass key */
2532 uf->uf_index = action; /* pass action */
2533 magic_getuvar((SV*)hv, mg);
2534 keysv = mg->mg_obj; /* may have changed */
2535 mg->mg_obj = obj;
2536 }
2537 }
2538 return keysv;
2539}
2540
ca732855
NC		 2541I32 *
2542Perl_hv_placeholders_p(pTHX_ HV *hv)
2543{
2544 dVAR;
2545 MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
2546
2547 if (!mg) {
2548 mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
2549
2550 if (!mg) {
2551 Perl_die(aTHX_ "panic: hv_placeholders_p");
2552 }
2553 }
2554 return &(mg->mg_len);
2555}
2556
2557
2558I32
2559Perl_hv_placeholders_get(pTHX_ HV *hv)
2560{
2561 dVAR;
b464bac0 2562 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
ca732855
NC		 2563
2564 return mg ? mg->mg_len : 0;
2565}
2566
2567void
ac1e784a 2568Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
ca732855
NC		 2569{
2570 dVAR;
b464bac0 2571 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
ca732855
NC		 2572
2573 if (mg) {
2574 mg->mg_len = ph;
2575 } else if (ph) {
2576 if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph))
2577 Perl_die(aTHX_ "panic: hv_placeholders_set");
2578 }
2579 /* else we don't need to add magic to record 0 placeholders. */
2580}
ecae49c0 2581
2a49f0f5 2582STATIC SV *
7b0bddfa
NC		 2583S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2584{
0b2d3faa 2585 dVAR;
7b0bddfa
NC		 2586 SV *value;
2587 switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2588 case HVrhek_undef:
2589 value = newSV(0);
2590 break;
2591 case HVrhek_delete:
2592 value = &PL_sv_placeholder;
2593 break;
2594 case HVrhek_IV:
44ebaf21
NC		 2595 value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2596 break;
2597 case HVrhek_UV:
2598 value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
7b0bddfa
NC		 2599 break;
2600 case HVrhek_PV:
44ebaf21 2601 case HVrhek_PV_UTF8:
7b0bddfa
NC		 2602 /* Create a string SV that directly points to the bytes in our
2603 structure. */
b9f83d2f 2604 value = newSV_type(SVt_PV);
7b0bddfa
NC		 2605 SvPV_set(value, (char *) he->refcounted_he_data + 1);
2606 SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2607 /* This stops anything trying to free it */
2608 SvLEN_set(value, 0);
2609 SvPOK_on(value);
2610 SvREADONLY_on(value);
44ebaf21 2611 if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
7b0bddfa
NC		 2612 SvUTF8_on(value);
2613 break;
2614 default:
2615 Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
2616 he->refcounted_he_data[0]);
2617 }
2618 return value;
2619}
2620
ecae49c0 2621/*
b3ca2e83
NC		 2622=for apidoc refcounted_he_chain_2hv
2623
abc25d8c 2624Generates and returns a C<HV *> by walking up the tree starting at the passed
b3ca2e83
NC		 2625in C<struct refcounted_he *>.
2626
2627=cut
2628*/
2629HV *
2630Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
2631{
7a89be66 2632 dVAR;
b3ca2e83
NC		 2633 HV *hv = newHV();
2634 U32 placeholders = 0;
2635 /* We could chase the chain once to get an idea of the number of keys,
2636 and call ksplit. But for now we'll make a potentially inefficient
2637 hash with only 8 entries in its array. */
2638 const U32 max = HvMAX(hv);
2639
2640 if (!HvARRAY(hv)) {
2641 char *array;
2642 Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
2643 HvARRAY(hv) = (HE**)array;
2644 }
2645
2646 while (chain) {
cbb1fbea 2647#ifdef USE_ITHREADS
b6bbf3fa 2648 U32 hash = chain->refcounted_he_hash;
cbb1fbea
NC		 2649#else
2650 U32 hash = HEK_HASH(chain->refcounted_he_hek);
2651#endif
b3ca2e83
NC		 2652 HE **oentry = &((HvARRAY(hv))[hash & max]);
2653 HE *entry = *oentry;
b6bbf3fa 2654 SV *value;
cbb1fbea 2655
b3ca2e83
NC		 2656 for (; entry; entry = HeNEXT(entry)) {
2657 if (HeHASH(entry) == hash) {
9f769845
NC		 2658 /* We might have a duplicate key here. If so, entry is older
2659 than the key we've already put in the hash, so if they are
2660 the same, skip adding entry. */
2661#ifdef USE_ITHREADS
2662 const STRLEN klen = HeKLEN(entry);
2663 const char *const key = HeKEY(entry);
2664 if (klen == chain->refcounted_he_keylen
2665 && (!!HeKUTF8(entry)
2666 == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2667 && memEQ(key, REF_HE_KEY(chain), klen))
2668 goto next_please;
2669#else
2670 if (HeKEY_hek(entry) == chain->refcounted_he_hek)
2671 goto next_please;
2672 if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
2673 && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
2674 && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
2675 HeKLEN(entry)))
2676 goto next_please;
2677#endif
b3ca2e83
NC		 2678 }
2679 }
2680 assert (!entry);
2681 entry = new_HE();
2682
cbb1fbea
NC		 2683#ifdef USE_ITHREADS
2684 HeKEY_hek(entry)
7b0bddfa 2685 = share_hek_flags(REF_HE_KEY(chain),
b6bbf3fa
NC		 2686 chain->refcounted_he_keylen,
2687 chain->refcounted_he_hash,
2688 (chain->refcounted_he_data[0]
2689 & (HVhek_UTF8|HVhek_WASUTF8)));
cbb1fbea 2690#else
71ad1b0c 2691 HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
cbb1fbea 2692#endif
7b0bddfa
NC		 2693 value = refcounted_he_value(chain);
2694 if (value == &PL_sv_placeholder)
b3ca2e83 2695 placeholders++;
b6bbf3fa 2696 HeVAL(entry) = value;
b3ca2e83
NC		 2697
2698 /* Link it into the chain. */
2699 HeNEXT(entry) = *oentry;
2700 if (!HeNEXT(entry)) {
2701 /* initial entry. */
2702 HvFILL(hv)++;
2703 }
2704 *oentry = entry;
2705
2706 HvTOTALKEYS(hv)++;
2707
2708 next_please:
71ad1b0c 2709 chain = chain->refcounted_he_next;
b3ca2e83
NC		 2710 }
2711
2712 if (placeholders) {
2713 clear_placeholders(hv, placeholders);
2714 HvTOTALKEYS(hv) -= placeholders;
2715 }
2716
2717 /* We could check in the loop to see if we encounter any keys with key
2718 flags, but it's probably not worth it, as this per-hash flag is only
2719 really meant as an optimisation for things like Storable. */
2720 HvHASKFLAGS_on(hv);
def9038f 2721 DEBUG_A(Perl_hv_assert(aTHX_ hv));
b3ca2e83
NC		 2722
2723 return hv;
2724}
2725
7b0bddfa
NC		 2726SV *
2727Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
2728 const char *key, STRLEN klen, int flags, U32 hash)
2729{
0b2d3faa 2730 dVAR;
7b0bddfa
NC		 2731 /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
2732 of your key has to exactly match that which is stored. */
2733 SV *value = &PL_sv_placeholder;
d8c5b3c5 2734 bool is_utf8;
7b0bddfa
NC		 2735
2736 if (keysv) {
2737 if (flags & HVhek_FREEKEY)
2738 Safefree(key);
2739 key = SvPV_const(keysv, klen);
2740 flags = 0;
d8c5b3c5
NC		 2741 is_utf8 = (SvUTF8(keysv) != 0);
2742 } else {
2743 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
7b0bddfa
NC		 2744 }
2745
2746 if (!hash) {
2747 if (keysv && (SvIsCOW_shared_hash(keysv))) {
2748 hash = SvSHARED_HASH(keysv);
2749 } else {
2750 PERL_HASH(hash, key, klen);
2751 }
2752 }
2753
2754 for (; chain; chain = chain->refcounted_he_next) {
2755#ifdef USE_ITHREADS
2756 if (hash != chain->refcounted_he_hash)
2757 continue;
2758 if (klen != chain->refcounted_he_keylen)
2759 continue;
2760 if (memNE(REF_HE_KEY(chain),key,klen))
2761 continue;
d8c5b3c5
NC		 2762 if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
2763 continue;
7b0bddfa
NC		 2764#else
2765 if (hash != HEK_HASH(chain->refcounted_he_hek))
2766 continue;
670f1322 2767 if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
7b0bddfa
NC		 2768 continue;
2769 if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
2770 continue;
d8c5b3c5
NC		 2771 if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
2772 continue;
7b0bddfa
NC		 2773#endif
2774
2775 value = sv_2mortal(refcounted_he_value(chain));
2776 break;
2777 }
2778
2779 if (flags & HVhek_FREEKEY)
2780 Safefree(key);
2781
2782 return value;
2783}
2784
b3ca2e83
NC		 2785/*
2786=for apidoc refcounted_he_new
2787
ec2a1de7
NC		 2788Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
2789stored in a compact form, all references remain the property of the caller.
2790The C<struct refcounted_he> is returned with a reference count of 1.
b3ca2e83
NC		 2791
2792=cut
2793*/
2794
2795struct refcounted_he *
2796Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
2797 SV *const key, SV *const value) {
7a89be66 2798 dVAR;
b3ca2e83 2799 struct refcounted_he *he;
b6bbf3fa
NC		 2800 STRLEN key_len;
2801 const char *key_p = SvPV_const(key, key_len);
2802 STRLEN value_len = 0;
95b63a38 2803 const char *value_p = NULL;
b6bbf3fa
NC		 2804 char value_type;
2805 char flags;
2806 STRLEN key_offset;
b3ca2e83 2807 U32 hash;
d8c5b3c5 2808 bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
b6bbf3fa
NC		 2809
2810 if (SvPOK(value)) {
2811 value_type = HVrhek_PV;
2812 } else if (SvIOK(value)) {
2813 value_type = HVrhek_IV;
2814 } else if (value == &PL_sv_placeholder) {
2815 value_type = HVrhek_delete;
2816 } else if (!SvOK(value)) {
2817 value_type = HVrhek_undef;
2818 } else {
2819 value_type = HVrhek_PV;
2820 }
b3ca2e83 2821
b6bbf3fa
NC		 2822 if (value_type == HVrhek_PV) {
2823 value_p = SvPV_const(value, value_len);
2824 key_offset = value_len + 2;
2825 } else {
2826 value_len = 0;
2827 key_offset = 1;
2828 }
b6bbf3fa 2829
b6bbf3fa 2830#ifdef USE_ITHREADS
10edeb5d
JH		 2831 he = (struct refcounted_he*)
2832 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2833 + key_len
2834 + key_offset);
6cef672b 2835#else
10edeb5d
JH		 2836 he = (struct refcounted_he*)
2837 PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
2838 + key_offset);
6cef672b 2839#endif
b3ca2e83 2840
b3ca2e83 2841
71ad1b0c 2842 he->refcounted_he_next = parent;
b6bbf3fa
NC		 2843
2844 if (value_type == HVrhek_PV) {
2845 Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
2846 he->refcounted_he_val.refcounted_he_u_len = value_len;
44ebaf21
NC		 2847 /* Do it this way so that the SvUTF8() test is after the SvPV, in case
2848 the value is overloaded, and doesn't yet have the UTF-8flag set. */
2849 if (SvUTF8(value))
2850 value_type = HVrhek_PV_UTF8;
b6bbf3fa
NC		 2851 } else if (value_type == HVrhek_IV) {
2852 if (SvUOK(value)) {
2853 he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
44ebaf21 2854 value_type = HVrhek_UV;
b6bbf3fa
NC		 2855 } else {
2856 he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
2857 }
2858 }
44ebaf21 2859 flags = value_type;
b6bbf3fa
NC		 2860
2861 if (is_utf8) {
2862 /* Hash keys are always stored normalised to (yes) ISO-8859-1.
2863 As we're going to be building hash keys from this value in future,
2864 normalise it now. */
2865 key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
2866 flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
2867 }
2868 PERL_HASH(hash, key_p, key_len);
2869
cbb1fbea 2870#ifdef USE_ITHREADS
b6bbf3fa
NC		 2871 he->refcounted_he_hash = hash;
2872 he->refcounted_he_keylen = key_len;
2873 Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
cbb1fbea 2874#else
b6bbf3fa 2875 he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
cbb1fbea 2876#endif
b6bbf3fa
NC		 2877
2878 if (flags & HVhek_WASUTF8) {
2879 /* If it was downgraded from UTF-8, then the pointer returned from
2880 bytes_from_utf8 is an allocated pointer that we must free. */
2881 Safefree(key_p);
2882 }
2883
2884 he->refcounted_he_data[0] = flags;
b3ca2e83
NC		 2885 he->refcounted_he_refcnt = 1;
2886
2887 return he;
2888}
2889
2890/*
2891=for apidoc refcounted_he_free
2892
2893Decrements the reference count of the passed in C<struct refcounted_he *>
2894by one. If the reference count reaches zero the structure's memory is freed,
2895and C<refcounted_he_free> iterates onto the parent node.
2896
2897=cut
2898*/
2899
2900void
2901Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
53d44271 2902 dVAR;
57ca3b03
AL		 2903 PERL_UNUSED_CONTEXT;
2904
b3ca2e83
NC		 2905 while (he) {
2906 struct refcounted_he *copy;
cbb1fbea 2907 U32 new_count;
b3ca2e83 2908
cbb1fbea
NC		 2909 HINTS_REFCNT_LOCK;
2910 new_count = --he->refcounted_he_refcnt;
2911 HINTS_REFCNT_UNLOCK;
2912
2913 if (new_count) {
b3ca2e83 2914 return;
cbb1fbea 2915 }
b3ca2e83 2916
b6bbf3fa 2917#ifndef USE_ITHREADS
71ad1b0c 2918 unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
cbb1fbea 2919#endif
b3ca2e83 2920 copy = he;
71ad1b0c 2921 he = he->refcounted_he_next;
b6bbf3fa 2922 PerlMemShared_free(copy);
b3ca2e83
NC		 2923 }
2924}
2925
b3ca2e83 2926/*
ecae49c0
NC		 2927=for apidoc hv_assert
2928
2929Check that a hash is in an internally consistent state.
2930
2931=cut
2932*/
2933
943795c2
NC		 2934#ifdef DEBUGGING
2935
ecae49c0
NC		 2936void
2937Perl_hv_assert(pTHX_ HV *hv)
2938{
57ca3b03
AL		 2939 dVAR;
2940 HE* entry;
2941 int withflags = 0;
2942 int placeholders = 0;
2943 int real = 0;
2944 int bad = 0;
2945 const I32 riter = HvRITER_get(hv);
2946 HE *eiter = HvEITER_get(hv);
2947
2948 (void)hv_iterinit(hv);
2949
2950 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2951 /* sanity check the values */
2952 if (HeVAL(entry) == &PL_sv_placeholder)
2953 placeholders++;
2954 else
2955 real++;
2956 /* sanity check the keys */
2957 if (HeSVKEY(entry)) {
6f207bd3 2958 NOOP; /* Don't know what to check on SV keys. */
57ca3b03
AL		 2959 } else if (HeKUTF8(entry)) {
2960 withflags++;
2961 if (HeKWASUTF8(entry)) {
2962 PerlIO_printf(Perl_debug_log,
d2a455e7 2963 "hash key has both WASUTF8 and UTF8: '%.*s'\n",
57ca3b03
AL		 2964 (int) HeKLEN(entry), HeKEY(entry));
2965 bad = 1;
2966 }
2967 } else if (HeKWASUTF8(entry))
2968 withflags++;
2969 }
2970 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2971 static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
2972 const int nhashkeys = HvUSEDKEYS(hv);
2973 const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
2974
2975 if (nhashkeys != real) {
2976 PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
2977 bad = 1;
2978 }
2979 if (nhashplaceholders != placeholders) {
2980 PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
2981 bad = 1;
2982 }
2983 }
2984 if (withflags && ! HvHASKFLAGS(hv)) {
2985 PerlIO_printf(Perl_debug_log,
2986 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2987 withflags);
2988 bad = 1;
2989 }
2990 if (bad) {
2991 sv_dump((SV *)hv);
2992 }
2993 HvRITER_set(hv, riter); /* Restore hash iterator state */
2994 HvEITER_set(hv, eiter);
ecae49c0 2995}
af3babe4 2996
943795c2
NC		 2997#endif
2998
af3babe4
NC		 2999/*
3000 * Local variables:
3001 * c-indentation-style: bsd
3002 * c-basic-offset: 4
3003 * indent-tabs-mode: t
3004 * End:
3005 *
37442d52
RGS		 3006 * ex: set ts=8 sts=4 sw=4 noet:
3007 */
Unnamed repository; edit this file 'description' to name the repository.