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