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