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