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