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