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