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