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