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