This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Shift negative klen/flags games from hv_store_common out to hv_store
[perl5.git] / hv.c
CommitLineData
a0d0e21e 1/* hv.c
79072805 2 *
4bb101f2
JH
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 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
17*/
18
79072805 19#include "EXTERN.h"
864dbfa3 20#define PERL_IN_HV_C
3d78eb94 21#define PERL_HASH_INTERNAL_ACCESS
79072805
LW
22#include "perl.h"
23
d8012aaf 24#define HV_MAX_LENGTH_BEFORE_SPLIT 14
fdcd69b6 25
76e3520e 26STATIC HE*
cea2e8a9 27S_new_he(pTHX)
4633a7c4
LW
28{
29 HE* he;
333f433b
DG
30 LOCK_SV_MUTEX;
31 if (!PL_he_root)
8aacddc1 32 more_he();
333f433b
DG
33 he = PL_he_root;
34 PL_he_root = HeNEXT(he);
35 UNLOCK_SV_MUTEX;
36 return he;
4633a7c4
LW
37}
38
76e3520e 39STATIC void
cea2e8a9 40S_del_he(pTHX_ HE *p)
4633a7c4 41{
333f433b 42 LOCK_SV_MUTEX;
3280af22
NIS
43 HeNEXT(p) = (HE*)PL_he_root;
44 PL_he_root = p;
333f433b 45 UNLOCK_SV_MUTEX;
4633a7c4
LW
46}
47
333f433b 48STATIC void
cea2e8a9 49S_more_he(pTHX)
4633a7c4
LW
50{
51 register HE* he;
52 register HE* heend;
612f20c3
GS
53 XPV *ptr;
54 New(54, ptr, 1008/sizeof(XPV), XPV);
55 ptr->xpv_pv = (char*)PL_he_arenaroot;
56 PL_he_arenaroot = ptr;
57
58 he = (HE*)ptr;
4633a7c4 59 heend = &he[1008 / sizeof(HE) - 1];
612f20c3 60 PL_he_root = ++he;
4633a7c4 61 while (he < heend) {
8aacddc1
NIS
62 HeNEXT(he) = (HE*)(he + 1);
63 he++;
4633a7c4 64 }
fde52b5c 65 HeNEXT(he) = 0;
4633a7c4
LW
66}
67
d33b2eba
GS
68#ifdef PURIFY
69
70#define new_HE() (HE*)safemalloc(sizeof(HE))
71#define del_HE(p) safefree((char*)p)
72
73#else
74
75#define new_HE() new_he()
76#define del_HE(p) del_he(p)
77
78#endif
79
76e3520e 80STATIC HEK *
19692e8d 81S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
bbce6d69
PP
82{
83 char *k;
84 register HEK *hek;
1c846c1f 85
e05949c7 86 New(54, k, HEK_BASESIZE + len + 2, char);
bbce6d69 87 hek = (HEK*)k;
ff68c719 88 Copy(str, HEK_KEY(hek), len, char);
e05949c7 89 HEK_KEY(hek)[len] = 0;
ff68c719
PP
90 HEK_LEN(hek) = len;
91 HEK_HASH(hek) = hash;
19692e8d 92 HEK_FLAGS(hek) = (unsigned char)flags;
bbce6d69
PP
93 return hek;
94}
95
dd28f7bb
DM
96/* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
97 * for tied hashes */
98
99void
100Perl_free_tied_hv_pool(pTHX)
101{
102 HE *ohe;
103 HE *he = PL_hv_fetch_ent_mh;
104 while (he) {
105 Safefree(HeKEY_hek(he));
106 ohe = he;
107 he = HeNEXT(he);
108 del_HE(ohe);
109 }
bf9cdc68 110 PL_hv_fetch_ent_mh = Nullhe;
dd28f7bb
DM
111}
112
d18c6117
GS
113#if defined(USE_ITHREADS)
114HE *
a8fc9800 115Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
d18c6117
GS
116{
117 HE *ret;
118
119 if (!e)
120 return Nullhe;
7766f137
GS
121 /* look for it in the table first */
122 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
123 if (ret)
124 return ret;
125
126 /* create anew and remember what it is */
d33b2eba 127 ret = new_HE();
7766f137
GS
128 ptr_table_store(PL_ptr_table, e, ret);
129
d2d73c3e 130 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
dd28f7bb
DM
131 if (HeKLEN(e) == HEf_SVKEY) {
132 char *k;
133 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
134 HeKEY_hek(ret) = (HEK*)k;
d2d73c3e 135 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
dd28f7bb 136 }
d18c6117 137 else if (shared)
19692e8d
NC
138 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
139 HeKFLAGS(e));
d18c6117 140 else
19692e8d
NC
141 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
142 HeKFLAGS(e));
d2d73c3e 143 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
d18c6117
GS
144 return ret;
145}
146#endif /* USE_ITHREADS */
147
1b1f1335 148static void
2393f1b9
JH
149S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
150 const char *msg)
1b1f1335 151{
2393f1b9 152 SV *sv = sv_newmortal(), *esv = sv_newmortal();
19692e8d 153 if (!(flags & HVhek_FREEKEY)) {
1b1f1335
NIS
154 sv_setpvn(sv, key, klen);
155 }
156 else {
157 /* Need to free saved eventually assign to mortal SV */
34c3c4e3 158 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
1b1f1335
NIS
159 sv_usepvn(sv, (char *) key, klen);
160 }
19692e8d 161 if (flags & HVhek_UTF8) {
1b1f1335
NIS
162 SvUTF8_on(sv);
163 }
2393f1b9
JH
164 Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg);
165 Perl_croak(aTHX_ SvPVX(esv), sv);
1b1f1335
NIS
166}
167
fde52b5c
PP
168/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
169 * contains an SV* */
170
954c1994
GS
171/*
172=for apidoc hv_fetch
173
174Returns the SV which corresponds to the specified key in the hash. The
175C<klen> is the length of the key. If C<lval> is set then the fetch will be
176part of a store. Check that the return value is non-null before
d1be9408 177dereferencing it to an C<SV*>.
954c1994 178
96f1132b 179See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
180information on how to use this function on tied hashes.
181
182=cut
183*/
184
113738bb
NC
185#define HV_FETCH_LVALUE 0x01
186#define HV_FETCH_JUST_SV 0x02
19692e8d 187
79072805 188SV**
c1fe5510 189Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
79072805 190{
c1fe5510
NC
191 HE *hek;
192 STRLEN klen;
193 int flags;
194
195 if (klen_i32 < 0) {
196 klen = -klen_i32;
197 flags = HVhek_UTF8;
198 } else {
199 klen = klen_i32;
200 flags = 0;
201 }
202 hek = hv_fetch_common (hv, NULL, key, klen, flags,
203 HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0), 0);
113738bb 204 return hek ? &HeVAL(hek) : NULL;
79072805
LW
205}
206
d1be9408 207/* returns an HE * structure with the all fields set */
fde52b5c 208/* note that hent_val will be a mortal sv for MAGICAL hashes */
954c1994
GS
209/*
210=for apidoc hv_fetch_ent
211
212Returns the hash entry which corresponds to the specified key in the hash.
213C<hash> must be a valid precomputed hash number for the given C<key>, or 0
214if you want the function to compute it. IF C<lval> is set then the fetch
215will be part of a store. Make sure the return value is non-null before
216accessing it. The return value when C<tb> is a tied hash is a pointer to a
217static location, so be sure to make a copy of the structure if you need to
1c846c1f 218store it somewhere.
954c1994 219
96f1132b 220See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
221information on how to use this function on tied hashes.
222
223=cut
224*/
225
fde52b5c 226HE *
864dbfa3 227Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
fde52b5c 228{
113738bb
NC
229 return hv_fetch_common(hv, keysv, NULL, 0, 0, lval ? HV_FETCH_LVALUE : 0,
230 hash);
231}
232
233HE *
c1fe5510 234S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
113738bb
NC
235 int flags, int action, register U32 hash)
236{
cbec9347 237 register XPVHV* xhv;
fde52b5c
PP
238 register HE *entry;
239 SV *sv;
da58a35d 240 bool is_utf8;
113738bb
NC
241 const char *keysave;
242 int masked_flags;
fde52b5c
PP
243
244 if (!hv)
245 return 0;
246
113738bb
NC
247 if (keysv) {
248 key = SvPV(keysv, klen);
c1fe5510 249 flags = 0;
113738bb
NC
250 is_utf8 = (SvUTF8(keysv) != 0);
251 } else {
c1fe5510 252 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
113738bb
NC
253 }
254 keysave = key;
255
902173a3 256 if (SvRMAGICAL(hv)) {
14befaf4 257 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
902173a3 258 sv = sv_newmortal();
113738bb
NC
259
260 /* XXX should be able to skimp on the HE/HEK here when
261 HV_FETCH_JUST_SV is true. */
262
263 if (!keysv) {
264 keysv = newSVpvn(key, klen);
265 if (is_utf8) {
266 SvUTF8_on(keysv);
267 }
268 } else {
269 keysv = newSVsv(keysv);
270 }
271 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
272
273
dd28f7bb
DM
274 /* grab a fake HE/HEK pair from the pool or make a new one */
275 entry = PL_hv_fetch_ent_mh;
276 if (entry)
277 PL_hv_fetch_ent_mh = HeNEXT(entry);
278 else {
902173a3 279 char *k;
dd28f7bb 280 entry = new_HE();
902173a3 281 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
dd28f7bb 282 HeKEY_hek(entry) = (HEK*)k;
902173a3 283 }
dd28f7bb
DM
284 HeNEXT(entry) = Nullhe;
285 HeSVKEY_set(entry, keysv);
286 HeVAL(entry) = sv;
287 sv_upgrade(sv, SVt_PVLV);
288 LvTYPE(sv) = 'T';
289 LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
113738bb
NC
290
291 /* XXX remove at some point? */
292 if (flags & HVhek_FREEKEY)
293 Safefree(key);
294
dd28f7bb
DM
295 return entry;
296 }
902173a3 297#ifdef ENV_IS_CASELESS
14befaf4 298 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
e7152ba2 299 U32 i;
e7152ba2
GS
300 for (i = 0; i < klen; ++i)
301 if (isLOWER(key[i])) {
79cb57f6 302 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
e7152ba2 303 (void)strupr(SvPVX(nkeysv));
113738bb
NC
304 entry = hv_fetch_common(hv, nkeysv, NULL, 0, 0, 0);
305 if (!entry && (action & HV_FETCH_LVALUE))
e7152ba2 306 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
113738bb
NC
307
308 /* XXX remove at some point? */
309 if (flags & HVhek_FREEKEY)
310 Safefree(key);
311
e7152ba2
GS
312 return entry;
313 }
902173a3
GS
314 }
315#endif
fde52b5c
PP
316 }
317
cbec9347
JH
318 xhv = (XPVHV*)SvANY(hv);
319 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
113738bb 320 if ((action & HV_FETCH_LVALUE)
fde52b5c 321#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
8aacddc1 322 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
fde52b5c 323#endif
8aacddc1 324 )
cbec9347
JH
325 Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
326 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
327 char);
113738bb
NC
328 else {
329 /* XXX remove at some point? */
330 if (flags & HVhek_FREEKEY)
331 Safefree(key);
332
fde52b5c 333 return 0;
113738bb 334 }
fde52b5c
PP
335 }
336
19692e8d 337 if (is_utf8) {
113738bb 338 int oldflags = flags;
f9a63242 339 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
19692e8d 340 if (is_utf8)
c1fe5510
NC
341 flags |= HVhek_UTF8;
342 else
343 flags &= ~HVhek_UTF8;
19692e8d
NC
344 if (key != keysave)
345 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
113738bb
NC
346 if (oldflags & HVhek_FREEKEY)
347 Safefree(keysave);
348
19692e8d 349 }
f9a63242 350
4b5190b5
NC
351 if (HvREHASH(hv)) {
352 PERL_HASH_INTERNAL(hash, key, klen);
fdcd69b6
NC
353 /* Yes, you do need this even though you are not "storing" because
354 you can flip the flags below if doing an lval lookup. (And that
355 was put in to give the semantics Andreas was expecting.) */
356 flags |= HVhek_REHASH;
4b5190b5 357 } else if (!hash) {
113738bb 358 if (keysv && (SvIsCOW_shared_hash(keysv))) {
46187eeb
NC
359 hash = SvUVX(keysv);
360 } else {
361 PERL_HASH(hash, key, klen);
362 }
363 }
effa1e2d 364
113738bb
NC
365 masked_flags = (flags & HVhek_MASK);
366
cbec9347
JH
367 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
368 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
369 for (; entry; entry = HeNEXT(entry)) {
370 if (HeHASH(entry) != hash) /* strings can't be equal */
371 continue;
eb160463 372 if (HeKLEN(entry) != (I32)klen)
fde52b5c 373 continue;
1c846c1f 374 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 375 continue;
113738bb 376 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 377 continue;
113738bb 378 if ((action & HV_FETCH_LVALUE) && HeKFLAGS(entry) != masked_flags) {
19692e8d
NC
379 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
380 But if entry was set previously with HVhek_WASUTF8 and key now
381 doesn't (or vice versa) then we should change the key's flag,
382 as this is assignment. */
383 if (HvSHAREKEYS(hv)) {
384 /* Need to swap the key we have for a key with the flags we
385 need. As keys are shared we can't just write to the flag,
386 so we share the new one, unshare the old one. */
113738bb 387 HEK *new_hek = share_hek_flags(key, klen, hash, masked_flags);
19692e8d
NC
388 unshare_hek (HeKEY_hek(entry));
389 HeKEY_hek(entry) = new_hek;
390 }
391 else
113738bb
NC
392 HeKFLAGS(entry) = masked_flags;
393 if (masked_flags & HVhek_ENABLEHVKFLAGS)
27a3632d 394 HvHASKFLAGS_on(hv);
19692e8d 395 }
8aacddc1 396 /* if we find a placeholder, we pretend we haven't found anything */
7996736c 397 if (HeVAL(entry) == &PL_sv_placeholder)
8aacddc1 398 break;
113738bb
NC
399 if (flags & HVhek_FREEKEY)
400 Safefree(key);
fde52b5c
PP
401 return entry;
402 }
403#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
cbec9347 404 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364
GS
405 unsigned long len;
406 char *env = PerlEnv_ENVgetenv_len(key,&len);
407 if (env) {
113738bb
NC
408 /* XXX remove once common API complete */
409 if (!keysv) {
410 nkeysv = sv_2mortal(newSVpvn(key,klen));
411 }
412
a6c40364
GS
413 sv = newSVpvn(env,len);
414 SvTAINTED_on(sv);
113738bb
NC
415 if (flags & HVhek_FREEKEY)
416 Safefree(key);
a6c40364
GS
417 return hv_store_ent(hv,keysv,sv,hash);
418 }
fde52b5c
PP
419 }
420#endif
8aacddc1 421 if (!entry && SvREADONLY(hv)) {
2393f1b9
JH
422 S_hv_notallowed(aTHX_ flags, key, klen,
423 "access disallowed key '%"SVf"' in"
424 );
1b1f1335 425 }
113738bb
NC
426 if (action & HV_FETCH_LVALUE) {
427 /* XXX remove once common API complete */
428 if (!keysv) {
429 keysv = sv_2mortal(newSVpvn(key,klen));
430 }
431 }
432
19692e8d 433 if (flags & HVhek_FREEKEY)
f9a63242 434 Safefree(key);
113738bb
NC
435 if (action & HV_FETCH_LVALUE) {
436 /* gonna assign to this, so it better be there */
fde52b5c 437 sv = NEWSV(61,0);
e7152ba2 438 return hv_store_ent(hv,keysv,sv,hash);
fde52b5c
PP
439 }
440 return 0;
441}
442
864dbfa3 443STATIC void
cea2e8a9 444S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
d0066dc7
OT
445{
446 MAGIC *mg = SvMAGIC(hv);
447 *needs_copy = FALSE;
448 *needs_store = TRUE;
449 while (mg) {
450 if (isUPPER(mg->mg_type)) {
451 *needs_copy = TRUE;
452 switch (mg->mg_type) {
14befaf4
DM
453 case PERL_MAGIC_tied:
454 case PERL_MAGIC_sig:
d0066dc7 455 *needs_store = FALSE;
d0066dc7
OT
456 }
457 }
458 mg = mg->mg_moremagic;
459 }
460}
461
954c1994
GS
462/*
463=for apidoc hv_store
464
465Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
466the length of the key. The C<hash> parameter is the precomputed hash
467value; if it is zero then Perl will compute it. The return value will be
468NULL if the operation failed or if the value did not need to be actually
469stored within the hash (as in the case of tied hashes). Otherwise it can
470be dereferenced to get the original C<SV*>. Note that the caller is
471responsible for suitably incrementing the reference count of C<val> before
4f646c4b
NC
472the call, and decrementing it if the function returned NULL. Effectively
473a successful hv_store takes ownership of one reference to C<val>. This is
474usually what you want; a newly created SV has a reference count of one, so
475if all your code does is create SVs then store them in a hash, hv_store
476will own the only reference to the new SV, and your code doesn't need to do
477anything further to tidy up. hv_store is not implemented as a call to
478hv_store_ent, and does not create a temporary SV for the key, so if your
479key data is not already in SV form then use hv_store in preference to
480hv_store_ent.
954c1994 481
96f1132b 482See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
483information on how to use this function on tied hashes.
484
485=cut
486*/
487
79072805 488SV**
a8adfdb3 489Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
19692e8d 490{
a8adfdb3
NC
491 HE *hek;
492 STRLEN klen;
493 int flags;
494
495 if (klen_i32 < 0) {
496 klen = -klen_i32;
497 flags = HVhek_UTF8;
498 } else {
499 klen = klen_i32;
500 flags = 0;
501 }
502 hek = hv_store_common (hv, NULL, key, klen, flags, val, 0);
570c4e91 503 return hek ? &HeVAL(hek) : NULL;
19692e8d
NC
504}
505
506SV**
e16e2ff8 507Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
19692e8d 508 register U32 hash, int flags)
79072805 509{
570c4e91
NC
510 HE *hek = hv_store_common (hv, NULL, key, klen, flags, val, hash);
511 return hek ? &HeVAL(hek) : NULL;
fde52b5c
PP
512}
513
954c1994
GS
514/*
515=for apidoc hv_store_ent
516
517Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
518parameter is the precomputed hash value; if it is zero then Perl will
519compute it. The return value is the new hash entry so created. It will be
520NULL if the operation failed or if the value did not need to be actually
521stored within the hash (as in the case of tied hashes). Otherwise the
87324b0f 522contents of the return value can be accessed using the C<He?> macros
954c1994
GS
523described here. Note that the caller is responsible for suitably
524incrementing the reference count of C<val> before the call, and
4f646c4b
NC
525decrementing it if the function returned NULL. Effectively a successful
526hv_store_ent takes ownership of one reference to C<val>. This is
527usually what you want; a newly created SV has a reference count of one, so
528if all your code does is create SVs then store them in a hash, hv_store
529will own the only reference to the new SV, and your code doesn't need to do
530anything further to tidy up. Note that hv_store_ent only reads the C<key>;
531unlike C<val> it does not take ownership of it, so maintaining the correct
532reference count on C<key> is entirely the caller's responsibility. hv_store
533is not implemented as a call to hv_store_ent, and does not create a temporary
534SV for the key, so if your key data is not already in SV form then use
535hv_store in preference to hv_store_ent.
954c1994 536
96f1132b 537See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
954c1994
GS
538information on how to use this function on tied hashes.
539
540=cut
541*/
542
fde52b5c 543HE *
19692e8d 544Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
fde52b5c 545{
570c4e91
NC
546 return hv_store_common(hv, keysv, NULL, 0, 0, val, hash);
547}
548
549HE *
a8adfdb3 550S_hv_store_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
570c4e91
NC
551 int flags, SV *val, U32 hash)
552{
19692e8d 553 XPVHV* xhv;
fdcd69b6 554 U32 n_links;
19692e8d
NC
555 HE *entry;
556 HE **oentry;
da58a35d 557 bool is_utf8;
570c4e91 558 const char *keysave;
a8adfdb3 559 int masked_flags;
fde52b5c
PP
560
561 if (!hv)
562 return 0;
563
570c4e91
NC
564 if (keysv) {
565 key = SvPV(keysv, klen);
a8adfdb3 566 flags = 0;
570c4e91
NC
567 is_utf8 = (SvUTF8(keysv) != 0);
568 } else {
a8adfdb3 569 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
570c4e91
NC
570 }
571 keysave = key;
572
cbec9347 573 xhv = (XPVHV*)SvANY(hv);
fde52b5c 574 if (SvMAGICAL(hv)) {
8aacddc1
NIS
575 bool needs_copy;
576 bool needs_store;
577 hv_magic_check (hv, &needs_copy, &needs_store);
578 if (needs_copy) {
570c4e91
NC
579 bool save_taint = PL_tainted;
580 if (keysv || is_utf8) {
581 if (!keysv) {
582 keysv = newSVpvn(key, klen);
583 SvUTF8_on(keysv);
584 }
585 if (PL_tainting)
586 PL_tainted = SvTAINTED(keysv);
587 keysv = sv_2mortal(newSVsv(keysv));
588 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
589 } else {
590 mg_copy((SV*)hv, val, key, klen);
591 }
592
8aacddc1 593 TAINT_IF(save_taint);
570c4e91
NC
594 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) {
595 if (flags & HVhek_FREEKEY)
596 Safefree(key);
8aacddc1 597 return Nullhe;
570c4e91 598 }
902173a3 599#ifdef ENV_IS_CASELESS
14befaf4 600 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
570c4e91
NC
601 key = savepvn(key,klen);
602 key = (const char*)strupr((char*)key);
902173a3 603 hash = 0;
570c4e91
NC
604
605 if (flags & HVhek_FREEKEY)
606 Safefree(keysave);
607 keysave = key;
902173a3
GS
608 }
609#endif
610 }
fde52b5c
PP
611 }
612
570c4e91
NC
613
614 if (flags & HVhek_PLACEHOLD) {
615 /* We have been requested to insert a placeholder. Currently
616 only Storable is allowed to do this. */
617 val = &PL_sv_placeholder;
618 }
902173a3 619
574c8022 620 if (is_utf8) {
f9a63242 621 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
570c4e91
NC
622
623 if (flags & HVhek_FREEKEY) {
624 /* This shouldn't happen if our caller does what we expect,
625 but strictly the API allows it. */
626 Safefree(keysave);
627 }
628
19692e8d 629 if (is_utf8)
a8adfdb3
NC
630 flags |= HVhek_UTF8;
631 else
632 flags &= ~HVhek_UTF8;
19692e8d
NC
633 if (key != keysave)
634 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
635 HvHASKFLAGS_on((SV*)hv);
574c8022 636 }
f9a63242 637
4b5190b5
NC
638 if (HvREHASH(hv)) {
639 /* We don't have a pointer to the hv, so we have to replicate the
640 flag into every HEK, so that hv_iterkeysv can see it. */
641 flags |= HVhek_REHASH;
642 PERL_HASH_INTERNAL(hash, key, klen);
643 } else if (!hash) {
570c4e91 644 if (keysv && SvIsCOW_shared_hash(keysv)) {
46187eeb
NC
645 hash = SvUVX(keysv);
646 } else {
647 PERL_HASH(hash, key, klen);
648 }
649 }
fde52b5c 650
a8adfdb3
NC
651 masked_flags = (flags & HVhek_MASK);
652
cbec9347
JH
653 if (!xhv->xhv_array /* !HvARRAY(hv) */)
654 Newz(505, xhv->xhv_array /* HvARRAY(hv) */,
655 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
656 char);
79072805 657
cbec9347
JH
658 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
659 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fdcd69b6 660 n_links = 0;
19692e8d 661 entry = *oentry;
fdcd69b6 662 for (; entry; ++n_links, entry = HeNEXT(entry)) {
fde52b5c 663 if (HeHASH(entry) != hash) /* strings can't be equal */
79072805 664 continue;
eb160463 665 if (HeKLEN(entry) != (I32)klen)
79072805 666 continue;
1c846c1f 667 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
79072805 668 continue;
a8adfdb3 669 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 670 continue;
7996736c 671 if (HeVAL(entry) == &PL_sv_placeholder)
8aacddc1
NIS
672 xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
673 else
674 SvREFCNT_dec(HeVAL(entry));
fde52b5c 675 HeVAL(entry) = val;
570c4e91
NC
676 if (val == &PL_sv_placeholder)
677 xhv->xhv_placeholders++;
678
a8adfdb3 679 if (HeKFLAGS(entry) != masked_flags) {
19692e8d
NC
680 /* We match if HVhek_UTF8 bit in our flags and hash key's match.
681 But if entry was set previously with HVhek_WASUTF8 and key now
682 doesn't (or vice versa) then we should change the key's flag,
683 as this is assignment. */
684 if (HvSHAREKEYS(hv)) {
685 /* Need to swap the key we have for a key with the flags we
686 need. As keys are shared we can't just write to the flag,
687 so we share the new one, unshare the old one. */
a8adfdb3 688 HEK *new_hek = share_hek_flags(key, klen, hash, masked_flags);
19692e8d
NC
689 unshare_hek (HeKEY_hek(entry));
690 HeKEY_hek(entry) = new_hek;
691 }
692 else
a8adfdb3 693 HeKFLAGS(entry) = masked_flags;
19692e8d
NC
694 }
695 if (flags & HVhek_FREEKEY)
f9a63242 696 Safefree(key);
fde52b5c 697 return entry;
79072805 698 }
79072805 699
1b1f1335 700 if (SvREADONLY(hv)) {
2393f1b9
JH
701 S_hv_notallowed(aTHX_ flags, key, klen,
702 "access disallowed key '%"SVf"' to"
703 );
1b1f1335
NIS
704 }
705
d33b2eba 706 entry = new_HE();
19692e8d
NC
707 /* share_hek_flags will do the free for us. This might be considered
708 bad API design. */
fde52b5c 709 if (HvSHAREKEYS(hv))
19692e8d 710 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
fde52b5c 711 else /* gotta do the real thing */
19692e8d 712 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
fde52b5c 713 HeVAL(entry) = val;
fde52b5c 714 HeNEXT(entry) = *oentry;
79072805
LW
715 *oentry = entry;
716
570c4e91
NC
717 if (val == &PL_sv_placeholder)
718 xhv->xhv_placeholders++;
719
cbec9347 720 xhv->xhv_keys++; /* HvKEYS(hv)++ */
fdcd69b6 721 if (!n_links) { /* initial entry? */
cbec9347 722 xhv->xhv_fill++; /* HvFILL(hv)++ */
fdcd69b6
NC
723 } else if ((xhv->xhv_keys > (IV)xhv->xhv_max)
724 || ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) {
725 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket
726 splits on a rehashed hash, as we're not going to split it again,
727 and if someone is lucky (evil) enough to get all the keys in one
728 list they could exhaust our memory as we repeatedly double the
729 number of buckets on every entry. Linear search feels a less worse
730 thing to do. */
731 hsplit(hv);
79072805 732 }
79072805 733
fde52b5c 734 return entry;
79072805
LW
735}
736
954c1994
GS
737/*
738=for apidoc hv_delete
739
740Deletes a key/value pair in the hash. The value SV is removed from the
1c846c1f 741hash and returned to the caller. The C<klen> is the length of the key.
954c1994
GS
742The C<flags> value will normally be zero; if set to G_DISCARD then NULL
743will be returned.
744
745=cut
746*/
747
79072805 748SV *
cd6d36ac 749Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
79072805 750{
cd6d36ac
NC
751 STRLEN klen;
752 int k_flags = 0;
753
754 if (klen_i32 < 0) {
755 klen = -klen_i32;
756 k_flags |= HVhek_UTF8;
757 } else {
758 klen = klen_i32;
759 }
760 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
fde52b5c
PP
761}
762
954c1994
GS
763/*
764=for apidoc hv_delete_ent
765
766Deletes a key/value pair in the hash. The value SV is removed from the
767hash and returned to the caller. The C<flags> value will normally be zero;
768if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
769precomputed hash value, or 0 to ask for it to be computed.
770
771=cut
772*/
773
fde52b5c 774SV *
864dbfa3 775Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
fde52b5c 776{
cd6d36ac 777 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
f1317c8d
NC
778}
779
780SV *
cd6d36ac
NC
781S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
782 int k_flags, I32 d_flags, U32 hash)
f1317c8d 783{
cbec9347 784 register XPVHV* xhv;
fde52b5c 785 register I32 i;
fde52b5c
PP
786 register HE *entry;
787 register HE **oentry;
788 SV *sv;
da58a35d 789 bool is_utf8;
f1317c8d 790 const char *keysave;
7a9669ca 791 int masked_flags;
1c846c1f 792
fde52b5c
PP
793 if (!hv)
794 return Nullsv;
f1317c8d
NC
795
796 if (keysv) {
797 key = SvPV(keysv, klen);
cd6d36ac 798 k_flags = 0;
f1317c8d
NC
799 is_utf8 = (SvUTF8(keysv) != 0);
800 } else {
cd6d36ac 801 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
f1317c8d
NC
802 }
803 keysave = key;
804
fde52b5c 805 if (SvRMAGICAL(hv)) {
0a0bb7c7
OT
806 bool needs_copy;
807 bool needs_store;
808 hv_magic_check (hv, &needs_copy, &needs_store);
809
f1317c8d 810 if (needs_copy) {
7a9669ca
NC
811 entry = hv_fetch_common(hv, keysv, key, klen,
812 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
813 hash);
814 sv = entry ? HeVAL(entry) : NULL;
f1317c8d
NC
815 if (sv) {
816 if (SvMAGICAL(sv)) {
817 mg_clear(sv);
818 }
819 if (!needs_store) {
820 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
821 /* No longer an element */
822 sv_unmagic(sv, PERL_MAGIC_tiedelem);
823 return sv;
824 }
825 return Nullsv; /* element cannot be deleted */
826 }
0a0bb7c7 827 }
902173a3 828#ifdef ENV_IS_CASELESS
14befaf4 829 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
f1317c8d 830 /* XXX This code isn't UTF8 clean. */
79cb57f6 831 keysv = sv_2mortal(newSVpvn(key,klen));
f1317c8d
NC
832 keysave = key = strupr(SvPVX(keysv));
833 is_utf8 = 0;
cd6d36ac 834 k_flags = 0;
1c846c1f 835 hash = 0;
2fd1c6b8 836 }
902173a3 837#endif
2fd1c6b8 838 }
fde52b5c 839 }
cbec9347
JH
840 xhv = (XPVHV*)SvANY(hv);
841 if (!xhv->xhv_array /* !HvARRAY(hv) */)
fde52b5c
PP
842 return Nullsv;
843
19692e8d 844 if (is_utf8) {
f9a63242 845 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
cd6d36ac
NC
846
847 if (k_flags & HVhek_FREEKEY) {
848 /* This shouldn't happen if our caller does what we expect,
849 but strictly the API allows it. */
850 Safefree(keysave);
851 }
852
19692e8d 853 if (is_utf8)
cd6d36ac
NC
854 k_flags |= HVhek_UTF8;
855 else
856 k_flags &= ~HVhek_UTF8;
19692e8d 857 if (key != keysave)
cd6d36ac
NC
858 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
859 HvHASKFLAGS_on((SV*)hv);
19692e8d 860 }
f9a63242 861
4b5190b5
NC
862 if (HvREHASH(hv)) {
863 PERL_HASH_INTERNAL(hash, key, klen);
864 } else if (!hash) {
7a9669ca
NC
865 if (keysv && (SvIsCOW_shared_hash(keysv))) {
866 hash = SvUVX(keysv);
867 } else {
868 PERL_HASH(hash, key, klen);
869 }
5afd6d42 870 PERL_HASH(hash, key, klen);
4b5190b5 871 }
fde52b5c 872
7a9669ca
NC
873 masked_flags = (k_flags & HVhek_MASK);
874
cbec9347
JH
875 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
876 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
877 entry = *oentry;
878 i = 1;
879 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
880 if (HeHASH(entry) != hash) /* strings can't be equal */
881 continue;
eb160463 882 if (HeKLEN(entry) != (I32)klen)
fde52b5c 883 continue;
1c846c1f 884 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 885 continue;
7a9669ca 886 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 887 continue;
19692e8d
NC
888 if (k_flags & HVhek_FREEKEY)
889 Safefree(key);
8aacddc1
NIS
890
891 /* if placeholder is here, it's already been deleted.... */
7996736c 892 if (HeVAL(entry) == &PL_sv_placeholder)
8aacddc1
NIS
893 {
894 if (SvREADONLY(hv))
895 return Nullsv; /* if still SvREADONLY, leave it deleted. */
03fed38d
MB
896
897 /* okay, really delete the placeholder. */
898 *oentry = HeNEXT(entry);
899 if (i && !*oentry)
900 xhv->xhv_fill--; /* HvFILL(hv)-- */
901 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
902 HvLAZYDEL_on(hv);
903 else
904 hv_free_ent(hv, entry);
905 xhv->xhv_keys--; /* HvKEYS(hv)-- */
574c8022 906 if (xhv->xhv_keys == 0)
19692e8d 907 HvHASKFLAGS_off(hv);
03fed38d
MB
908 xhv->xhv_placeholders--;
909 return Nullsv;
8aacddc1
NIS
910 }
911 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
2393f1b9
JH
912 S_hv_notallowed(aTHX_ k_flags, key, klen,
913 "delete readonly key '%"SVf"' from"
914 );
8aacddc1
NIS
915 }
916
cd6d36ac 917 if (d_flags & G_DISCARD)
fde52b5c 918 sv = Nullsv;
94f7643d 919 else {
79d01fbf 920 sv = sv_2mortal(HeVAL(entry));
7996736c 921 HeVAL(entry) = &PL_sv_placeholder;
94f7643d 922 }
8aacddc1
NIS
923
924 /*
925 * If a restricted hash, rather than really deleting the entry, put
926 * a placeholder there. This marks the key as being "approved", so
927 * we can still access via not-really-existing key without raising
928 * an error.
929 */
930 if (SvREADONLY(hv)) {
7996736c 931 HeVAL(entry) = &PL_sv_placeholder;
8aacddc1
NIS
932 /* We'll be saving this slot, so the number of allocated keys
933 * doesn't go down, but the number placeholders goes up */
934 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
935 } else {
a26e96df
NIS
936 *oentry = HeNEXT(entry);
937 if (i && !*oentry)
938 xhv->xhv_fill--; /* HvFILL(hv)-- */
8aacddc1
NIS
939 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
940 HvLAZYDEL_on(hv);
941 else
942 hv_free_ent(hv, entry);
943 xhv->xhv_keys--; /* HvKEYS(hv)-- */
574c8022 944 if (xhv->xhv_keys == 0)
19692e8d 945 HvHASKFLAGS_off(hv);
8aacddc1 946 }
79072805
LW
947 return sv;
948 }
8aacddc1 949 if (SvREADONLY(hv)) {
2393f1b9
JH
950 S_hv_notallowed(aTHX_ k_flags, key, klen,
951 "delete disallowed key '%"SVf"' from"
952 );
8aacddc1
NIS
953 }
954
19692e8d 955 if (k_flags & HVhek_FREEKEY)
f9a63242 956 Safefree(key);
79072805 957 return Nullsv;
79072805
LW
958}
959
954c1994
GS
960/*
961=for apidoc hv_exists
962
963Returns a boolean indicating whether the specified hash key exists. The
964C<klen> is the length of the key.
965
966=cut
967*/
968
a0d0e21e 969bool
9b7c1c41 970Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
a0d0e21e 971{
9b7c1c41
NC
972 STRLEN klen;
973 int flags;
974
975 if (klen_i32 < 0) {
976 klen = -klen_i32;
977 flags = HVhek_UTF8;
978 } else {
979 klen = klen_i32;
980 flags = 0;
981 }
982 return hv_exists_common(hv, NULL, key, klen, flags, 0);
fde52b5c
PP
983}
984
954c1994
GS
985/*
986=for apidoc hv_exists_ent
987
988Returns a boolean indicating whether the specified hash key exists. C<hash>
989can be a valid precomputed hash value, or 0 to ask for it to be
990computed.
991
992=cut
993*/
994
fde52b5c 995bool
864dbfa3 996Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
fde52b5c 997{
9b7c1c41 998 return hv_exists_common(hv, keysv, NULL, 0, 0, hash);
71596152
NC
999}
1000
1001bool
9b7c1c41
NC
1002S_hv_exists_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
1003 int k_flags, U32 hash)
71596152 1004{
cbec9347 1005 register XPVHV* xhv;
fde52b5c
PP
1006 register HE *entry;
1007 SV *sv;
c3654f1a 1008 bool is_utf8;
71596152 1009 const char *keysave;
9b7c1c41 1010 int masked_flags;
fde52b5c
PP
1011
1012 if (!hv)
1013 return 0;
1014
71596152
NC
1015 if (keysv) {
1016 key = SvPV(keysv, klen);
9b7c1c41 1017 k_flags = 0;
71596152
NC
1018 is_utf8 = (SvUTF8(keysv) != 0);
1019 } else {
9b7c1c41 1020 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
71596152
NC
1021 }
1022 keysave = key;
1023
fde52b5c 1024 if (SvRMAGICAL(hv)) {
14befaf4 1025 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
71596152
NC
1026 SV* svret;
1027
1028 if (keysv || is_utf8) {
1029 if (!keysv) {
1030 keysv = newSVpvn(key, klen);
1031 SvUTF8_on(keysv);
1032 } else {
1033 keysv = newSVsv(keysv);
1034 }
1035 key = (char *)sv_2mortal(keysv);
1036 klen = HEf_SVKEY;
1037 }
1038
1039 /* I don't understand why hv_exists_ent has svret and sv,
1040 whereas hv_exists only had one. */
1041 svret = sv_newmortal();
fde52b5c 1042 sv = sv_newmortal();
71596152
NC
1043 mg_copy((SV*)hv, sv, key, klen);
1044 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
1045 return (bool)SvTRUE(svret);
fde52b5c 1046 }
902173a3 1047#ifdef ENV_IS_CASELESS
14befaf4 1048 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
71596152 1049 /* XXX This code isn't UTF8 clean. */
79cb57f6 1050 keysv = sv_2mortal(newSVpvn(key,klen));
71596152
NC
1051 keysave = key = strupr(SvPVX(keysv));
1052 is_utf8 = 0;
1c846c1f 1053 hash = 0;
902173a3
GS
1054 }
1055#endif
fde52b5c
PP
1056 }
1057
cbec9347 1058 xhv = (XPVHV*)SvANY(hv);
f675dbe5 1059#ifndef DYNAMIC_ENV_FETCH
cbec9347 1060 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1c846c1f 1061 return 0;
f675dbe5 1062#endif
fde52b5c 1063
19692e8d 1064 if (is_utf8) {
f9a63242 1065 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
9b7c1c41
NC
1066
1067 if (k_flags & HVhek_FREEKEY) {
1068 /* This shouldn't happen if our caller does what we expect,
1069 but strictly the API allows it. */
1070 Safefree(keysave);
1071 }
1072
19692e8d 1073 if (is_utf8)
9b7c1c41
NC
1074 k_flags |= HVhek_UTF8;
1075 else
1076 k_flags &= ~HVhek_UTF8;
19692e8d 1077 if (key != keysave)
9b7c1c41 1078 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
19692e8d 1079 }
9b7c1c41 1080
4b5190b5
NC
1081 if (HvREHASH(hv)) {
1082 PERL_HASH_INTERNAL(hash, key, klen);
1083 } else if (!hash)
5afd6d42 1084 PERL_HASH(hash, key, klen);
fde52b5c 1085
9b7c1c41
NC
1086 masked_flags = (k_flags & HVhek_MASK);
1087
f675dbe5 1088#ifdef DYNAMIC_ENV_FETCH
cbec9347 1089 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
f675dbe5
CB
1090 else
1091#endif
cbec9347
JH
1092 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1093 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c
PP
1094 for (; entry; entry = HeNEXT(entry)) {
1095 if (HeHASH(entry) != hash) /* strings can't be equal */
1096 continue;
eb160463 1097 if (HeKLEN(entry) != (I32)klen)
fde52b5c 1098 continue;
1c846c1f 1099 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
a0d0e21e 1100 continue;
9b7c1c41 1101 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
c3654f1a 1102 continue;
19692e8d 1103 if (k_flags & HVhek_FREEKEY)
f9a63242 1104 Safefree(key);
8aacddc1 1105 /* If we find the key, but the value is a placeholder, return false. */
7996736c 1106 if (HeVAL(entry) == &PL_sv_placeholder)
8aacddc1 1107 return FALSE;
a0d0e21e
LW
1108 return TRUE;
1109 }
f675dbe5 1110#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
cbec9347 1111 if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
a6c40364
GS
1112 unsigned long len;
1113 char *env = PerlEnv_ENVgetenv_len(key,&len);
1114 if (env) {
1115 sv = newSVpvn(env,len);
1116 SvTAINTED_on(sv);
1117 (void)hv_store_ent(hv,keysv,sv,hash);
19692e8d
NC
1118 if (k_flags & HVhek_FREEKEY)
1119 Safefree(key);
a6c40364
GS
1120 return TRUE;
1121 }
f675dbe5
CB
1122 }
1123#endif
19692e8d
NC
1124 if (k_flags & HVhek_FREEKEY)
1125 Safefree(key);
a0d0e21e
LW
1126 return FALSE;
1127}
1128
71596152 1129
76e3520e 1130STATIC void
cea2e8a9 1131S_hsplit(pTHX_ HV *hv)
79072805 1132{
cbec9347
JH
1133 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1134 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
79072805
LW
1135 register I32 newsize = oldsize * 2;
1136 register I32 i;
cbec9347 1137 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
72311751
GS
1138 register HE **aep;
1139 register HE **bep;
79072805
LW
1140 register HE *entry;
1141 register HE **oentry;
4b5190b5
NC
1142 int longest_chain = 0;
1143 int was_shared;
79072805 1144
3280af22 1145 PL_nomemok = TRUE;
8d6dde3e 1146#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
d18c6117 1147 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1148 if (!a) {
4a33f861 1149 PL_nomemok = FALSE;
422a93e5
GA
1150 return;
1151 }
4633a7c4 1152#else
d18c6117 1153 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1154 if (!a) {
3280af22 1155 PL_nomemok = FALSE;
422a93e5
GA
1156 return;
1157 }
cbec9347 1158 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
fba3b22e 1159 if (oldsize >= 64) {
cbec9347
JH
1160 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1161 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
4633a7c4
LW
1162 }
1163 else
cbec9347 1164 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
4633a7c4
LW
1165#endif
1166
3280af22 1167 PL_nomemok = FALSE;
72311751 1168 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
cbec9347
JH
1169 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1170 xhv->xhv_array = a; /* HvARRAY(hv) = a */
72311751 1171 aep = (HE**)a;
79072805 1172
72311751 1173 for (i=0; i<oldsize; i++,aep++) {
4b5190b5
NC
1174 int left_length = 0;
1175 int right_length = 0;
1176
72311751 1177 if (!*aep) /* non-existent */
79072805 1178 continue;
72311751
GS
1179 bep = aep+oldsize;
1180 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
eb160463 1181 if ((HeHASH(entry) & newsize) != (U32)i) {
fde52b5c 1182 *oentry = HeNEXT(entry);
72311751
GS
1183 HeNEXT(entry) = *bep;
1184 if (!*bep)
cbec9347 1185 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1186 *bep = entry;
4b5190b5 1187 right_length++;
79072805
LW
1188 continue;
1189 }
4b5190b5 1190 else {
fde52b5c 1191 oentry = &HeNEXT(entry);
4b5190b5
NC
1192 left_length++;
1193 }
79072805 1194 }
72311751 1195 if (!*aep) /* everything moved */
cbec9347 1196 xhv->xhv_fill--; /* HvFILL(hv)-- */
4b5190b5
NC
1197 /* I think we don't actually need to keep track of the longest length,
1198 merely flag if anything is too long. But for the moment while
1199 developing this code I'll track it. */
1200 if (left_length > longest_chain)
1201 longest_chain = left_length;
1202 if (right_length > longest_chain)
1203 longest_chain = right_length;
1204 }
1205
1206
1207 /* Pick your policy for "hashing isn't working" here: */
fdcd69b6 1208 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
4b5190b5
NC
1209 || HvREHASH(hv)) {
1210 return;
79072805 1211 }
4b5190b5
NC
1212
1213 if (hv == PL_strtab) {
1214 /* Urg. Someone is doing something nasty to the string table.
1215 Can't win. */
1216 return;
1217 }
1218
1219 /* Awooga. Awooga. Pathological data. */
fdcd69b6 1220 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
4b5190b5
NC
1221 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1222
1223 ++newsize;
1224 Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1225 was_shared = HvSHAREKEYS(hv);
1226
1227 xhv->xhv_fill = 0;
1228 HvSHAREKEYS_off(hv);
1229 HvREHASH_on(hv);
1230
1231 aep = (HE **) xhv->xhv_array;
1232
1233 for (i=0; i<newsize; i++,aep++) {
1234 entry = *aep;
1235 while (entry) {
1236 /* We're going to trash this HE's next pointer when we chain it
1237 into the new hash below, so store where we go next. */
1238 HE *next = HeNEXT(entry);
1239 UV hash;
1240
1241 /* Rehash it */
1242 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1243
1244 if (was_shared) {
1245 /* Unshare it. */
1246 HEK *new_hek
1247 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1248 hash, HeKFLAGS(entry));
1249 unshare_hek (HeKEY_hek(entry));
1250 HeKEY_hek(entry) = new_hek;
1251 } else {
1252 /* Not shared, so simply write the new hash in. */
1253 HeHASH(entry) = hash;
1254 }
1255 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1256 HEK_REHASH_on(HeKEY_hek(entry));
1257 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1258
1259 /* Copy oentry to the correct new chain. */
1260 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1261 if (!*bep)
1262 xhv->xhv_fill++; /* HvFILL(hv)++ */
1263 HeNEXT(entry) = *bep;
1264 *bep = entry;
1265
1266 entry = next;
1267 }
1268 }
1269 Safefree (xhv->xhv_array);
1270 xhv->xhv_array = a; /* HvARRAY(hv) = a */
79072805
LW
1271}
1272
72940dca 1273void
864dbfa3 1274Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
72940dca 1275{
cbec9347
JH
1276 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1277 I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
72940dca
PP
1278 register I32 newsize;
1279 register I32 i;
1280 register I32 j;
72311751
GS
1281 register char *a;
1282 register HE **aep;
72940dca
PP
1283 register HE *entry;
1284 register HE **oentry;
1285
1286 newsize = (I32) newmax; /* possible truncation here */
1287 if (newsize != newmax || newmax <= oldsize)
1288 return;
1289 while ((newsize & (1 + ~newsize)) != newsize) {
1290 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1291 }
1292 if (newsize < newmax)
1293 newsize *= 2;
1294 if (newsize < newmax)
1295 return; /* overflow detection */
1296
cbec9347 1297 a = xhv->xhv_array; /* HvARRAY(hv) */
72940dca 1298 if (a) {
3280af22 1299 PL_nomemok = TRUE;
8d6dde3e 1300#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
d18c6117 1301 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
8aacddc1 1302 if (!a) {
4a33f861 1303 PL_nomemok = FALSE;
422a93e5
GA
1304 return;
1305 }
72940dca 1306#else
d18c6117 1307 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
8aacddc1 1308 if (!a) {
3280af22 1309 PL_nomemok = FALSE;
422a93e5
GA
1310 return;
1311 }
cbec9347 1312 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
fba3b22e 1313 if (oldsize >= 64) {
cbec9347
JH
1314 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1315 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
72940dca
PP
1316 }
1317 else
cbec9347 1318 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
72940dca 1319#endif
3280af22 1320 PL_nomemok = FALSE;
72311751 1321 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
72940dca
PP
1322 }
1323 else {
d18c6117 1324 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
72940dca 1325 }
cbec9347
JH
1326 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1327 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1328 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
72940dca
PP
1329 return;
1330
72311751
GS
1331 aep = (HE**)a;
1332 for (i=0; i<oldsize; i++,aep++) {
1333 if (!*aep) /* non-existent */
72940dca 1334 continue;
72311751 1335 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
72940dca
PP
1336 if ((j = (HeHASH(entry) & newsize)) != i) {
1337 j -= i;
1338 *oentry = HeNEXT(entry);
72311751 1339 if (!(HeNEXT(entry) = aep[j]))
cbec9347 1340 xhv->xhv_fill++; /* HvFILL(hv)++ */
72311751 1341 aep[j] = entry;
72940dca
PP
1342 continue;
1343 }
1344 else
1345 oentry = &HeNEXT(entry);
1346 }
72311751 1347 if (!*aep) /* everything moved */
cbec9347 1348 xhv->xhv_fill--; /* HvFILL(hv)-- */
72940dca
PP
1349 }
1350}
1351
954c1994
GS
1352/*
1353=for apidoc newHV
1354
1355Creates a new HV. The reference count is set to 1.
1356
1357=cut
1358*/
1359
79072805 1360HV *
864dbfa3 1361Perl_newHV(pTHX)
79072805
LW
1362{
1363 register HV *hv;
cbec9347 1364 register XPVHV* xhv;
79072805 1365
a0d0e21e
LW
1366 hv = (HV*)NEWSV(502,0);
1367 sv_upgrade((SV *)hv, SVt_PVHV);
cbec9347 1368 xhv = (XPVHV*)SvANY(hv);
79072805
LW
1369 SvPOK_off(hv);
1370 SvNOK_off(hv);
1c846c1f 1371#ifndef NODEFAULT_SHAREKEYS
fde52b5c 1372 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1c846c1f 1373#endif
4b5190b5 1374
cbec9347
JH
1375 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1376 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1377 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
79072805
LW
1378 (void)hv_iterinit(hv); /* so each() will start off right */
1379 return hv;
1380}
1381
b3ac6de7 1382HV *
864dbfa3 1383Perl_newHVhv(pTHX_ HV *ohv)
b3ac6de7 1384{
b56ba0bf 1385 HV *hv = newHV();
4beac62f 1386 STRLEN hv_max, hv_fill;
4beac62f
AMS
1387
1388 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1389 return hv;
4beac62f 1390 hv_max = HvMAX(ohv);
b3ac6de7 1391
b56ba0bf
AMS
1392 if (!SvMAGICAL((SV *)ohv)) {
1393 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
eb160463
GS
1394 STRLEN i;
1395 bool shared = !!HvSHAREKEYS(ohv);
b56ba0bf 1396 HE **ents, **oents = (HE **)HvARRAY(ohv);
ff875642
JH
1397 char *a;
1398 New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1399 ents = (HE**)a;
b56ba0bf
AMS
1400
1401 /* In each bucket... */
1402 for (i = 0; i <= hv_max; i++) {
1403 HE *prev = NULL, *ent = NULL, *oent = oents[i];
1404
1405 if (!oent) {
1406 ents[i] = NULL;
1407 continue;
1408 }
1409
1410 /* Copy the linked list of entries. */
1411 for (oent = oents[i]; oent; oent = HeNEXT(oent)) {
1412 U32 hash = HeHASH(oent);
1413 char *key = HeKEY(oent);
19692e8d
NC
1414 STRLEN len = HeKLEN(oent);
1415 int flags = HeKFLAGS(oent);
b56ba0bf
AMS
1416
1417 ent = new_HE();
45dea987 1418 HeVAL(ent) = newSVsv(HeVAL(oent));
19692e8d
NC
1419 HeKEY_hek(ent)
1420 = shared ? share_hek_flags(key, len, hash, flags)
1421 : save_hek_flags(key, len, hash, flags);
b56ba0bf
AMS
1422 if (prev)
1423 HeNEXT(prev) = ent;
1424 else
1425 ents[i] = ent;
1426 prev = ent;
1427 HeNEXT(ent) = NULL;
1428 }
1429 }
1430
1431 HvMAX(hv) = hv_max;
1432 HvFILL(hv) = hv_fill;
8aacddc1 1433 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
b56ba0bf 1434 HvARRAY(hv) = ents;
1c846c1f 1435 }
b56ba0bf
AMS
1436 else {
1437 /* Iterate over ohv, copying keys and values one at a time. */
b3ac6de7 1438 HE *entry;
b56ba0bf
AMS
1439 I32 riter = HvRITER(ohv);
1440 HE *eiter = HvEITER(ohv);
1441
1442 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1443 while (hv_max && hv_max + 1 >= hv_fill * 2)
1444 hv_max = hv_max / 2;
1445 HvMAX(hv) = hv_max;
1446
4a76a316 1447 hv_iterinit(ohv);
e16e2ff8 1448 while ((entry = hv_iternext_flags(ohv, 0))) {
19692e8d
NC
1449 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1450 newSVsv(HeVAL(entry)), HeHASH(entry),
1451 HeKFLAGS(entry));
b3ac6de7 1452 }
b56ba0bf
AMS
1453 HvRITER(ohv) = riter;
1454 HvEITER(ohv) = eiter;
b3ac6de7 1455 }
1c846c1f 1456
b3ac6de7
IZ
1457 return hv;
1458}
1459
79072805 1460void
864dbfa3 1461Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
79072805 1462{
16bdeea2
GS
1463 SV *val;
1464
68dc0745 1465 if (!entry)
79072805 1466 return;
16bdeea2 1467 val = HeVAL(entry);
257c9e5b 1468 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
3280af22 1469 PL_sub_generation++; /* may be deletion of method from stash */
16bdeea2 1470 SvREFCNT_dec(val);
68dc0745
PP
1471 if (HeKLEN(entry) == HEf_SVKEY) {
1472 SvREFCNT_dec(HeKEY_sv(entry));
8aacddc1 1473 Safefree(HeKEY_hek(entry));
44a8e56a
PP
1474 }
1475 else if (HvSHAREKEYS(hv))
68dc0745 1476 unshare_hek(HeKEY_hek(entry));
fde52b5c 1477 else
68dc0745 1478 Safefree(HeKEY_hek(entry));
d33b2eba 1479 del_HE(entry);
79072805
LW
1480}
1481
1482void
864dbfa3 1483Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
79072805 1484{
68dc0745 1485 if (!entry)
79072805 1486 return;
68dc0745 1487 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
3280af22 1488 PL_sub_generation++; /* may be deletion of method from stash */
68dc0745
PP
1489 sv_2mortal(HeVAL(entry)); /* free between statements */
1490 if (HeKLEN(entry) == HEf_SVKEY) {
1491 sv_2mortal(HeKEY_sv(entry));
1492 Safefree(HeKEY_hek(entry));
44a8e56a
PP
1493 }
1494 else if (HvSHAREKEYS(hv))
68dc0745 1495 unshare_hek(HeKEY_hek(entry));
fde52b5c 1496 else
68dc0745 1497 Safefree(HeKEY_hek(entry));
d33b2eba 1498 del_HE(entry);
79072805
LW
1499}
1500
954c1994
GS
1501/*
1502=for apidoc hv_clear
1503
1504Clears a hash, making it empty.
1505
1506=cut
1507*/
1508
79072805 1509void
864dbfa3 1510Perl_hv_clear(pTHX_ HV *hv)
79072805 1511{
cbec9347 1512 register XPVHV* xhv;
79072805
LW
1513 if (!hv)
1514 return;
49293501 1515
ecae49c0
NC
1516 DEBUG_A(Perl_hv_assert(aTHX_ hv));
1517
34c3c4e3
DM
1518 xhv = (XPVHV*)SvANY(hv);
1519
5f099cb0 1520 if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
34c3c4e3 1521 /* restricted hash: convert all keys to placeholders */
3a676441
JH
1522 I32 i;
1523 HE* entry;
1524 for (i = 0; i <= (I32) xhv->xhv_max; i++) {
1525 entry = ((HE**)xhv->xhv_array)[i];
1526 for (; entry; entry = HeNEXT(entry)) {
1527 /* not already placeholder */
7996736c 1528 if (HeVAL(entry) != &PL_sv_placeholder) {
3a676441
JH
1529 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1530 SV* keysv = hv_iterkeysv(entry);
1531 Perl_croak(aTHX_
1532 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1533 keysv);
1534 }
1535 SvREFCNT_dec(HeVAL(entry));
7996736c 1536 HeVAL(entry) = &PL_sv_placeholder;
3a676441
JH
1537 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1538 }
34c3c4e3
DM
1539 }
1540 }
1541 return;
49293501
MS
1542 }
1543
463ee0b2 1544 hfreeentries(hv);
8aacddc1 1545 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
cbec9347
JH
1546 if (xhv->xhv_array /* HvARRAY(hv) */)
1547 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1548 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
a0d0e21e
LW
1549
1550 if (SvRMAGICAL(hv))
1c846c1f 1551 mg_clear((SV*)hv);
574c8022 1552
19692e8d 1553 HvHASKFLAGS_off(hv);
bb443f97 1554 HvREHASH_off(hv);
79072805
LW
1555}
1556
3540d4ce
AB
1557/*
1558=for apidoc hv_clear_placeholders
1559
1560Clears any placeholders from a hash. If a restricted hash has any of its keys
1561marked as readonly and the key is subsequently deleted, the key is not actually
1562deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1563it so it will be ignored by future operations such as iterating over the hash,
1564but will still allow the hash to have a value reaasigned to the key at some
1565future point. This function clears any such placeholder keys from the hash.
1566See Hash::Util::lock_keys() for an example of its use.
1567
1568=cut
1569*/
1570
1571void
1572Perl_hv_clear_placeholders(pTHX_ HV *hv)
1573{
1574 I32 items;
1575 items = (I32)HvPLACEHOLDERS(hv);
1576 if (items) {
1577 HE *entry;
1578 I32 riter = HvRITER(hv);
1579 HE *eiter = HvEITER(hv);
1580 hv_iterinit(hv);
1581 /* This may look suboptimal with the items *after* the iternext, but
1582 it's quite deliberate. We only get here with items==0 if we've
1583 just deleted the last placeholder in the hash. If we've just done
1584 that then it means that the hash is in lazy delete mode, and the
1585 HE is now only referenced in our iterator. If we just quit the loop
1586 and discarded our iterator then the HE leaks. So we do the && the
1587 other way to ensure iternext is called just one more time, which
1588 has the side effect of triggering the lazy delete. */
1589 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1590 && items) {
1591 SV *val = hv_iterval(hv, entry);
1592
1593 if (val == &PL_sv_placeholder) {
1594
1595 /* It seems that I have to go back in the front of the hash
1596 API to delete a hash, even though I have a HE structure
1597 pointing to the very entry I want to delete, and could hold
1598 onto the previous HE that points to it. And it's easier to
1599 go in with SVs as I can then specify the precomputed hash,
1600 and don't have fun and games with utf8 keys. */
1601 SV *key = hv_iterkeysv(entry);
1602
1603 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
1604 items--;
1605 }
1606 }
1607 HvRITER(hv) = riter;
1608 HvEITER(hv) = eiter;
1609 }
1610}
1611
76e3520e 1612STATIC void
cea2e8a9 1613S_hfreeentries(pTHX_ HV *hv)
79072805 1614{
a0d0e21e 1615 register HE **array;
68dc0745
PP
1616 register HE *entry;
1617 register HE *oentry = Null(HE*);
a0d0e21e
LW
1618 I32 riter;
1619 I32 max;
79072805
LW
1620
1621 if (!hv)
1622 return;
a0d0e21e 1623 if (!HvARRAY(hv))
79072805 1624 return;
a0d0e21e
LW
1625
1626 riter = 0;
1627 max = HvMAX(hv);
1628 array = HvARRAY(hv);
2f86008e
DM
1629 /* make everyone else think the array is empty, so that the destructors
1630 * called for freed entries can't recusively mess with us */
1631 HvARRAY(hv) = Null(HE**);
1632 HvFILL(hv) = 0;
1633 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1634
68dc0745 1635 entry = array[0];
a0d0e21e 1636 for (;;) {
68dc0745
PP
1637 if (entry) {
1638 oentry = entry;
1639 entry = HeNEXT(entry);
1640 hv_free_ent(hv, oentry);
a0d0e21e 1641 }
68dc0745 1642 if (!entry) {
a0d0e21e
LW
1643 if (++riter > max)
1644 break;
68dc0745 1645 entry = array[riter];
1c846c1f 1646 }
79072805 1647 }
2f86008e 1648 HvARRAY(hv) = array;
a0d0e21e 1649 (void)hv_iterinit(hv);
79072805
LW
1650}
1651
954c1994
GS
1652/*
1653=for apidoc hv_undef
1654
1655Undefines the hash.
1656
1657=cut
1658*/
1659
79072805 1660void
864dbfa3 1661Perl_hv_undef(pTHX_ HV *hv)
79072805 1662{
cbec9347 1663 register XPVHV* xhv;
79072805
LW
1664 if (!hv)
1665 return;
ecae49c0 1666 DEBUG_A(Perl_hv_assert(aTHX_ hv));
cbec9347 1667 xhv = (XPVHV*)SvANY(hv);
463ee0b2 1668 hfreeentries(hv);
cbec9347 1669 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
85e6fe83 1670 if (HvNAME(hv)) {
7e8961ec
AB
1671 if(PL_stashcache)
1672 hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
85e6fe83
LW
1673 Safefree(HvNAME(hv));
1674 HvNAME(hv) = 0;
1675 }
cbec9347
JH
1676 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1677 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
8aacddc1 1678 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
a0d0e21e
LW
1679
1680 if (SvRMAGICAL(hv))
1c846c1f 1681 mg_clear((SV*)hv);
79072805
LW
1682}
1683
954c1994
GS
1684/*
1685=for apidoc hv_iterinit
1686
1687Prepares a starting point to traverse a hash table. Returns the number of
1688keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1c846c1f 1689currently only meaningful for hashes without tie magic.
954c1994
GS
1690
1691NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1692hash buckets that happen to be in use. If you still need that esoteric
1693value, you can get it through the macro C<HvFILL(tb)>.
1694
e16e2ff8 1695
954c1994
GS
1696=cut
1697*/
1698
79072805 1699I32
864dbfa3 1700Perl_hv_iterinit(pTHX_ HV *hv)
79072805 1701{
cbec9347 1702 register XPVHV* xhv;
aa689395
PP
1703 HE *entry;
1704
1705 if (!hv)
cea2e8a9 1706 Perl_croak(aTHX_ "Bad hash");
cbec9347
JH
1707 xhv = (XPVHV*)SvANY(hv);
1708 entry = xhv->xhv_eiter; /* HvEITER(hv) */
72940dca
PP
1709 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1710 HvLAZYDEL_off(hv);
68dc0745 1711 hv_free_ent(hv, entry);
72940dca 1712 }
cbec9347
JH
1713 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1714 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1715 /* used to be xhv->xhv_fill before 5.004_65 */
8aacddc1 1716 return XHvTOTALKEYS(xhv);
79072805 1717}
954c1994
GS
1718/*
1719=for apidoc hv_iternext
1720
1721Returns entries from a hash iterator. See C<hv_iterinit>.
1722
fe7bca90
NC
1723You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1724iterator currently points to, without losing your place or invalidating your
1725iterator. Note that in this case the current entry is deleted from the hash
1726with your iterator holding the last reference to it. Your iterator is flagged
1727to free the entry on the next call to C<hv_iternext>, so you must not discard
1728your iterator immediately else the entry will leak - call C<hv_iternext> to
1729trigger the resource deallocation.
1730
954c1994
GS
1731=cut
1732*/
1733
79072805 1734HE *
864dbfa3 1735Perl_hv_iternext(pTHX_ HV *hv)
79072805 1736{
e16e2ff8
NC
1737 return hv_iternext_flags(hv, 0);
1738}
1739
1740/*
fe7bca90
NC
1741=for apidoc hv_iternext_flags
1742
1743Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1744The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1745set the placeholders keys (for restricted hashes) will be returned in addition
1746to normal keys. By default placeholders are automatically skipped over.
7996736c
MHM
1747Currently a placeholder is implemented with a value that is
1748C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
fe7bca90
NC
1749restricted hashes may change, and the implementation currently is
1750insufficiently abstracted for any change to be tidy.
e16e2ff8 1751
fe7bca90 1752=cut
e16e2ff8
NC
1753*/
1754
1755HE *
1756Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1757{
cbec9347 1758 register XPVHV* xhv;
79072805 1759 register HE *entry;
a0d0e21e 1760 HE *oldentry;
463ee0b2 1761 MAGIC* mg;
79072805
LW
1762
1763 if (!hv)
cea2e8a9 1764 Perl_croak(aTHX_ "Bad hash");
cbec9347
JH
1765 xhv = (XPVHV*)SvANY(hv);
1766 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
463ee0b2 1767
14befaf4 1768 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
8990e307 1769 SV *key = sv_newmortal();
cd1469e6 1770 if (entry) {
fde52b5c 1771 sv_setsv(key, HeSVKEY_force(entry));
cd1469e6
PP
1772 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1773 }
a0d0e21e 1774 else {
ff68c719 1775 char *k;
bbce6d69 1776 HEK *hek;
ff68c719 1777
cbec9347
JH
1778 /* one HE per MAGICAL hash */
1779 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
4633a7c4 1780 Zero(entry, 1, HE);
ff68c719
PP
1781 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1782 hek = (HEK*)k;
1783 HeKEY_hek(entry) = hek;
fde52b5c 1784 HeKLEN(entry) = HEf_SVKEY;
a0d0e21e
LW
1785 }
1786 magic_nextpack((SV*) hv,mg,key);
8aacddc1 1787 if (SvOK(key)) {
cd1469e6 1788 /* force key to stay around until next time */
bbce6d69
PP
1789 HeSVKEY_set(entry, SvREFCNT_inc(key));
1790 return entry; /* beware, hent_val is not set */
8aacddc1 1791 }
fde52b5c
PP
1792 if (HeVAL(entry))
1793 SvREFCNT_dec(HeVAL(entry));
ff68c719 1794 Safefree(HeKEY_hek(entry));
d33b2eba 1795 del_HE(entry);
cbec9347 1796 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
463ee0b2 1797 return Null(HE*);
79072805 1798 }
f675dbe5 1799#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
cbec9347 1800 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
f675dbe5
CB
1801 prime_env_iter();
1802#endif
463ee0b2 1803
cbec9347
JH
1804 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1805 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1806 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1807 char);
015a5f36 1808 /* At start of hash, entry is NULL. */
fde52b5c 1809 if (entry)
8aacddc1 1810 {
fde52b5c 1811 entry = HeNEXT(entry);
e16e2ff8
NC
1812 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1813 /*
1814 * Skip past any placeholders -- don't want to include them in
1815 * any iteration.
1816 */
7996736c 1817 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
e16e2ff8
NC
1818 entry = HeNEXT(entry);
1819 }
8aacddc1
NIS
1820 }
1821 }
fde52b5c 1822 while (!entry) {
015a5f36
NC
1823 /* OK. Come to the end of the current list. Grab the next one. */
1824
cbec9347 1825 xhv->xhv_riter++; /* HvRITER(hv)++ */
eb160463 1826 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
015a5f36 1827 /* There is no next one. End of the hash. */
cbec9347 1828 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
fde52b5c 1829 break;
79072805 1830 }
cbec9347
JH
1831 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1832 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
8aacddc1 1833
e16e2ff8 1834 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
015a5f36
NC
1835 /* If we have an entry, but it's a placeholder, don't count it.
1836 Try the next. */
7996736c 1837 while (entry && HeVAL(entry) == &PL_sv_placeholder)
015a5f36
NC
1838 entry = HeNEXT(entry);
1839 }
1840 /* Will loop again if this linked list starts NULL
1841 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1842 or if we run through it and find only placeholders. */
fde52b5c 1843 }
79072805 1844
72940dca
PP
1845 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1846 HvLAZYDEL_off(hv);
68dc0745 1847 hv_free_ent(hv, oldentry);
72940dca 1848 }
a0d0e21e 1849
fdcd69b6
NC
1850 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1851 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1852
cbec9347 1853 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
79072805
LW
1854 return entry;
1855}
1856
954c1994
GS
1857/*
1858=for apidoc hv_iterkey
1859
1860Returns the key from the current position of the hash iterator. See
1861C<hv_iterinit>.
1862
1863=cut
1864*/
1865
79072805 1866char *
864dbfa3 1867Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 1868{
fde52b5c 1869 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a
PP
1870 STRLEN len;
1871 char *p = SvPV(HeKEY_sv(entry), len);
1872 *retlen = len;
1873 return p;
fde52b5c
PP
1874 }
1875 else {
1876 *retlen = HeKLEN(entry);
1877 return HeKEY(entry);
1878 }
1879}
1880
1881/* unlike hv_iterval(), this always returns a mortal copy of the key */
954c1994
GS
1882/*
1883=for apidoc hv_iterkeysv
1884
1885Returns the key as an C<SV*> from the current position of the hash
1886iterator. The return value will always be a mortal copy of the key. Also
1887see C<hv_iterinit>.
1888
1889=cut
1890*/
1891
fde52b5c 1892SV *
864dbfa3 1893Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c 1894{
19692e8d
NC
1895 if (HeKLEN(entry) != HEf_SVKEY) {
1896 HEK *hek = HeKEY_hek(entry);
1897 int flags = HEK_FLAGS(hek);
1898 SV *sv;
1899
1900 if (flags & HVhek_WASUTF8) {
1901 /* Trouble :-)
1902 Andreas would like keys he put in as utf8 to come back as utf8
1903 */
1904 STRLEN utf8_len = HEK_LEN(hek);
2e5dfef7 1905 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
19692e8d 1906
2e5dfef7 1907 sv = newSVpvn ((char*)as_utf8, utf8_len);
19692e8d 1908 SvUTF8_on (sv);
c193270f 1909 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
4b5190b5
NC
1910 } else if (flags & HVhek_REHASH) {
1911 /* We don't have a pointer to the hv, so we have to replicate the
1912 flag into every HEK. This hv is using custom a hasing
1913 algorithm. Hence we can't return a shared string scalar, as
1914 that would contain the (wrong) hash value, and might get passed
1915 into an hv routine with a regular hash */
1916
1917 sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
1918 if (HEK_UTF8(hek))
1919 SvUTF8_on (sv);
1920 } else {
19692e8d
NC
1921 sv = newSVpvn_share(HEK_KEY(hek),
1922 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
1923 HEK_HASH(hek));
1924 }
1925 return sv_2mortal(sv);
1926 }
1927 return sv_mortalcopy(HeKEY_sv(entry));
79072805
LW
1928}
1929
954c1994
GS
1930/*
1931=for apidoc hv_iterval
1932
1933Returns the value from the current position of the hash iterator. See
1934C<hv_iterkey>.
1935
1936=cut
1937*/
1938
79072805 1939SV *
864dbfa3 1940Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 1941{
8990e307 1942 if (SvRMAGICAL(hv)) {
14befaf4 1943 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
8990e307 1944 SV* sv = sv_newmortal();
bbce6d69
PP
1945 if (HeKLEN(entry) == HEf_SVKEY)
1946 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1947 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
463ee0b2
LW
1948 return sv;
1949 }
79072805 1950 }
fde52b5c 1951 return HeVAL(entry);
79072805
LW
1952}
1953
954c1994
GS
1954/*
1955=for apidoc hv_iternextsv
1956
1957Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1958operation.
1959
1960=cut
1961*/
1962
a0d0e21e 1963SV *
864dbfa3 1964Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e
LW
1965{
1966 HE *he;
e16e2ff8 1967 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
a0d0e21e
LW
1968 return NULL;
1969 *key = hv_iterkey(he, retlen);
1970 return hv_iterval(hv, he);
1971}
1972
954c1994
GS
1973/*
1974=for apidoc hv_magic
1975
1976Adds magic to a hash. See C<sv_magic>.
1977
1978=cut
1979*/
1980
79072805 1981void
864dbfa3 1982Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
79072805 1983{
a0d0e21e 1984 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
79072805 1985}
fde52b5c 1986
37d85e3a
JH
1987#if 0 /* use the macro from hv.h instead */
1988
bbce6d69 1989char*
864dbfa3 1990Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
bbce6d69 1991{
ff68c719 1992 return HEK_KEY(share_hek(sv, len, hash));
bbce6d69
PP
1993}
1994
37d85e3a
JH
1995#endif
1996
bbce6d69 1997/* possibly free a shared string if no one has access to it
fde52b5c
PP
1998 * len and hash must both be valid for str.
1999 */
bbce6d69 2000void
864dbfa3 2001Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 2002{
19692e8d
NC
2003 unshare_hek_or_pvn (NULL, str, len, hash);
2004}
2005
2006
2007void
2008Perl_unshare_hek(pTHX_ HEK *hek)
2009{
2010 unshare_hek_or_pvn(hek, NULL, 0, 0);
2011}
2012
2013/* possibly free a shared string if no one has access to it
2014 hek if non-NULL takes priority over the other 3, else str, len and hash
2015 are used. If so, len and hash must both be valid for str.
2016 */
df132699 2017STATIC void
19692e8d
NC
2018S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
2019{
cbec9347 2020 register XPVHV* xhv;
fde52b5c
PP
2021 register HE *entry;
2022 register HE **oentry;
2023 register I32 i = 1;
2024 I32 found = 0;
c3654f1a 2025 bool is_utf8 = FALSE;
19692e8d 2026 int k_flags = 0;
f9a63242 2027 const char *save = str;
c3654f1a 2028
19692e8d
NC
2029 if (hek) {
2030 hash = HEK_HASH(hek);
2031 } else if (len < 0) {
2032 STRLEN tmplen = -len;
2033 is_utf8 = TRUE;
2034 /* See the note in hv_fetch(). --jhi */
2035 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2036 len = tmplen;
2037 if (is_utf8)
2038 k_flags = HVhek_UTF8;
2039 if (str != save)
2040 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
c3654f1a 2041 }
1c846c1f 2042
fde52b5c 2043 /* what follows is the moral equivalent of:
6b88bc9c 2044 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
bbce6d69 2045 if (--*Svp == Nullsv)
6b88bc9c 2046 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 2047 } */
cbec9347 2048 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2049 /* assert(xhv_array != 0) */
5f08fbcd 2050 LOCK_STRTAB_MUTEX;
cbec9347
JH
2051 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2052 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
19692e8d
NC
2053 if (hek) {
2054 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2055 if (HeKEY_hek(entry) != hek)
2056 continue;
2057 found = 1;
2058 break;
2059 }
2060 } else {
2061 int flags_masked = k_flags & HVhek_MASK;
2062 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
2063 if (HeHASH(entry) != hash) /* strings can't be equal */
2064 continue;
2065 if (HeKLEN(entry) != len)
2066 continue;
2067 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2068 continue;
2069 if (HeKFLAGS(entry) != flags_masked)
2070 continue;
2071 found = 1;
2072 break;
2073 }
2074 }
2075
2076 if (found) {
2077 if (--HeVAL(entry) == Nullsv) {
2078 *oentry = HeNEXT(entry);
2079 if (i && !*oentry)
2080 xhv->xhv_fill--; /* HvFILL(hv)-- */
2081 Safefree(HeKEY_hek(entry));
2082 del_HE(entry);
2083 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2084 }
fde52b5c 2085 }
19692e8d 2086
333f433b 2087 UNLOCK_STRTAB_MUTEX;
411caa50 2088 if (!found && ckWARN_d(WARN_INTERNAL))
19692e8d
NC
2089 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2090 "Attempt to free non-existent shared string '%s'%s",
2091 hek ? HEK_KEY(hek) : str,
2092 (k_flags & HVhek_UTF8) ? " (utf8)" : "");
2093 if (k_flags & HVhek_FREEKEY)
2094 Safefree(str);
fde52b5c
PP
2095}
2096
bbce6d69
PP
2097/* get a (constant) string ptr from the global string table
2098 * string will get added if it is not already there.
fde52b5c
PP
2099 * len and hash must both be valid for str.
2100 */
bbce6d69 2101HEK *
864dbfa3 2102Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 2103{
da58a35d 2104 bool is_utf8 = FALSE;
19692e8d 2105 int flags = 0;
f9a63242 2106 const char *save = str;
da58a35d
JH
2107
2108 if (len < 0) {
77caf834 2109 STRLEN tmplen = -len;
da58a35d 2110 is_utf8 = TRUE;
77caf834
JH
2111 /* See the note in hv_fetch(). --jhi */
2112 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2113 len = tmplen;
19692e8d
NC
2114 /* If we were able to downgrade here, then than means that we were passed
2115 in a key which only had chars 0-255, but was utf8 encoded. */
2116 if (is_utf8)
2117 flags = HVhek_UTF8;
2118 /* If we found we were able to downgrade the string to bytes, then
2119 we should flag that it needs upgrading on keys or each. Also flag
2120 that we need share_hek_flags to free the string. */
2121 if (str != save)
2122 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2123 }
2124
2125 return share_hek_flags (str, len, hash, flags);
2126}
2127
df132699 2128STATIC HEK *
19692e8d
NC
2129S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2130{
2131 register XPVHV* xhv;
2132 register HE *entry;
2133 register HE **oentry;
2134 register I32 i = 1;
2135 I32 found = 0;
2136 int flags_masked = flags & HVhek_MASK;
bbce6d69 2137
fde52b5c 2138 /* what follows is the moral equivalent of:
1c846c1f 2139
6b88bc9c 2140 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
8aacddc1 2141 hv_store(PL_strtab, str, len, Nullsv, hash);
fdcd69b6
NC
2142
2143 Can't rehash the shared string table, so not sure if it's worth
2144 counting the number of entries in the linked list
bbce6d69 2145 */
cbec9347 2146 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 2147 /* assert(xhv_array != 0) */
5f08fbcd 2148 LOCK_STRTAB_MUTEX;
cbec9347
JH
2149 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2150 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
bbce6d69 2151 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
fde52b5c
PP
2152 if (HeHASH(entry) != hash) /* strings can't be equal */
2153 continue;
2154 if (HeKLEN(entry) != len)
2155 continue;
1c846c1f 2156 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 2157 continue;
19692e8d 2158 if (HeKFLAGS(entry) != flags_masked)
c3654f1a 2159 continue;
fde52b5c 2160 found = 1;
fde52b5c
PP
2161 break;
2162 }
bbce6d69 2163 if (!found) {
d33b2eba 2164 entry = new_HE();
19692e8d 2165 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
bbce6d69
PP
2166 HeVAL(entry) = Nullsv;
2167 HeNEXT(entry) = *oentry;
2168 *oentry = entry;
cbec9347 2169 xhv->xhv_keys++; /* HvKEYS(hv)++ */
bbce6d69 2170 if (i) { /* initial entry? */
cbec9347 2171 xhv->xhv_fill++; /* HvFILL(hv)++ */
4c9cc595 2172 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
cbec9347 2173 hsplit(PL_strtab);
bbce6d69
PP
2174 }
2175 }
2176
2177 ++HeVAL(entry); /* use value slot as REFCNT */
5f08fbcd 2178 UNLOCK_STRTAB_MUTEX;
19692e8d
NC
2179
2180 if (flags & HVhek_FREEKEY)
f9a63242 2181 Safefree(str);
19692e8d 2182
ff68c719 2183 return HeKEY_hek(entry);
fde52b5c 2184}
ecae49c0
NC
2185
2186
2187/*
2188=for apidoc hv_assert
2189
2190Check that a hash is in an internally consistent state.
2191
2192=cut
2193*/
2194
2195void
2196Perl_hv_assert(pTHX_ HV *hv)
2197{
2198 HE* entry;
2199 int withflags = 0;
2200 int placeholders = 0;
2201 int real = 0;
2202 int bad = 0;
2203 I32 riter = HvRITER(hv);
2204 HE *eiter = HvEITER(hv);
2205
2206 (void)hv_iterinit(hv);
2207
2208 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
2209 /* sanity check the values */
2210 if (HeVAL(entry) == &PL_sv_placeholder) {
2211 placeholders++;
2212 } else {
2213 real++;
2214 }
2215 /* sanity check the keys */
2216 if (HeSVKEY(entry)) {
2217 /* Don't know what to check on SV keys. */
2218 } else if (HeKUTF8(entry)) {
2219 withflags++;
2220 if (HeKWASUTF8(entry)) {
2221 PerlIO_printf(Perl_debug_log,
2222 "hash key has both WASUFT8 and UTF8: '%.*s'\n",
2223 (int) HeKLEN(entry), HeKEY(entry));
2224 bad = 1;
2225 }
2226 } else if (HeKWASUTF8(entry)) {
2227 withflags++;
2228 }
2229 }
2230 if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
2231 if (HvUSEDKEYS(hv) != real) {
2232 PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
2233 (int) real, (int) HvUSEDKEYS(hv));
2234 bad = 1;
2235 }
2236 if (HvPLACEHOLDERS(hv) != placeholders) {
2237 PerlIO_printf(Perl_debug_log,
2238 "Count %d placeholder(s), but hash reports %d\n",
2239 (int) placeholders, (int) HvPLACEHOLDERS(hv));
2240 bad = 1;
2241 }
2242 }
2243 if (withflags && ! HvHASKFLAGS(hv)) {
2244 PerlIO_printf(Perl_debug_log,
2245 "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
2246 withflags);
2247 bad = 1;
2248 }
2249 if (bad) {
2250 sv_dump((SV *)hv);
2251 }
2252 HvRITER(hv) = riter; /* Restore hash iterator state */
2253 HvEITER(hv) = eiter;
2254}