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