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