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