Test case for #10433/#10424.
[p5sagit/p5-mst-13.2.git] / hv.c
CommitLineData
a0d0e21e 1/* hv.c
79072805 2 *
bc89e66f 3 * Copyright (c) 1991-2001, Larry Wall
79072805 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 8 */
9
10/*
11 * "I sit beside the fire and think of all that I have seen." --Bilbo
79072805 12 */
13
14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_HV_C
79072805 16#include "perl.h"
17
1c846c1f 18
76e3520e 19STATIC HE*
cea2e8a9 20S_new_he(pTHX)
4633a7c4 21{
22 HE* he;
333f433b 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 30}
31
76e3520e 32STATIC void
cea2e8a9 33S_del_he(pTHX_ HE *p)
4633a7c4 34{
333f433b 35 LOCK_SV_MUTEX;
3280af22 36 HeNEXT(p) = (HE*)PL_he_root;
37 PL_he_root = p;
333f433b 38 UNLOCK_SV_MUTEX;
4633a7c4 39}
40
333f433b 41STATIC void
cea2e8a9 42S_more_he(pTHX)
4633a7c4 43{
44 register HE* he;
45 register HE* heend;
612f20c3 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 56 he++;
57 }
fde52b5c 58 HeNEXT(he) = 0;
4633a7c4 59}
60
d33b2eba 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 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 97 unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
98 HEK_HASH(hek));
bbce6d69 99}
100
d18c6117 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 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 116 ptr_table_store(PL_ptr_table, e, ret);
117
118 HeNEXT(ret) = he_dup(HeNEXT(e),shared);
d18c6117 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 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 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 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 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 156
157 if (!hv)
158 return 0;
463ee0b2 159
da58a35d 160 if (klen < 0) {
161 klen = -klen;
162 is_utf8 = TRUE;
163 }
164
8990e307 165 if (SvRMAGICAL(hv)) {
14befaf4 166 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
8990e307 167 sv = sv_newmortal();
463ee0b2 168 mg_copy((SV*)hv, sv, key, klen);
3280af22 169 PL_hv_fetch_sv = sv;
170 return &PL_hv_fetch_sv;
463ee0b2 171 }
902173a3 172#ifdef ENV_IS_CASELESS
14befaf4 173 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
e7152ba2 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 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 183 }
184#endif
463ee0b2 185 }
186
79072805 187 xhv = (XPVHV*)SvANY(hv);
188 if (!xhv->xhv_array) {
1c846c1f 189 if (lval
a0d0e21e 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 194 Newz(503, xhv->xhv_array,
195 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
79072805 196 else
197 return 0;
198 }
199
75a54232 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 218 if (HeKUTF8(entry) != (char)is_utf8)
219 continue;
f9a63242 220 if (key != keysave)
221 Safefree(key);
fde52b5c 222 return &HeVAL(entry);
79072805 223 }
a0d0e21e 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 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 231 if (key != keysave)
232 Safefree(key);
a6c40364 233 return hv_store(hv,key,klen,sv,hash);
234 }
a0d0e21e 235 }
236#endif
79072805 237 if (lval) { /* gonna assign to this, so it better be there */
238 sv = NEWSV(61,0);
f9a63242 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 247 if (key != keysave)
248 Safefree(key);
79072805 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 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 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)) {
14befaf4 286 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
902173a3 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 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 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 299#ifdef ENV_IS_CASELESS
14befaf4 300 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
e7152ba2 301 U32 i;
902173a3 302 key = SvPV(keysv, klen);
e7152ba2 303 for (i = 0; i < klen; ++i)
304 if (isLOWER(key[i])) {
79cb57f6 305 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
e7152ba2 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 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 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 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 346 if (HeKUTF8(entry) != (char)is_utf8)
347 continue;
f9a63242 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 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 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 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) {
14befaf4 382 case PERL_MAGIC_tied:
383 case PERL_MAGIC_sig:
d0066dc7 384 *needs_store = FALSE;
d0066dc7 385 }
386 }
387 mg = mg->mg_moremagic;
388 }
389}
390
954c1994 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 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 411{
412 register XPVHV* xhv;
79072805 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 418
419 if (!hv)
420 return 0;
421
da58a35d 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 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 436#ifdef ENV_IS_CASELESS
14befaf4 437 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
d220deaf 438 key = savepvn(key,klen);
439 key = strupr(key);
902173a3 440 hash = 0;
441 }
442#endif
d0066dc7 443 }
463ee0b2 444 }
75a54232 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 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 469 if (HeKUTF8(entry) != (char)is_utf8)
470 continue;
fde52b5c 471 SvREFCNT_dec(HeVAL(entry));
472 HeVAL(entry) = val;
f9a63242 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 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 494 }
495
fde52b5c 496 return &HeVAL(entry);
497}
498
954c1994 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
87324b0f 507contents of the return value can be accessed using the C<He?> macros
954c1994 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 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 535 bool needs_copy;
536 bool needs_store;
537 hv_magic_check (hv, &needs_copy, &needs_store);
538 if (needs_copy) {
3280af22 539 bool save_taint = PL_tainted;
540 if (PL_tainting)
541 PL_tainted = SvTAINTED(keysv);
d0066dc7 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 547#ifdef ENV_IS_CASELESS
14befaf4 548 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
902173a3 549 key = SvPV(keysv, klen);
79cb57f6 550 keysv = sv_2mortal(newSVpvn(key,klen));
902173a3 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 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 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 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 581 if (HeKUTF8(entry) != (char)is_utf8)
582 continue;
fde52b5c 583 SvREFCNT_dec(HeVAL(entry));
584 HeVAL(entry) = val;
f9a63242 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 595 if (key != keysave)
596 Safefree(key);
fde52b5c 597 HeVAL(entry) = val;
fde52b5c 598 HeNEXT(entry) = *oentry;
79072805 599 *oentry = entry;
600
463ee0b2 601 xhv->xhv_keys++;
79072805 602 if (i) { /* initial entry? */
463ee0b2 603 ++xhv->xhv_fill;
604 if (xhv->xhv_keys > xhv->xhv_max)
79072805 605 hsplit(hv);
606 }
79072805 607
fde52b5c 608 return entry;
79072805 609}
610
954c1994 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 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 624{
625 register XPVHV* xhv;
79072805 626 register I32 i;
fde52b5c 627 register U32 hash;
79072805 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 634
635 if (!hv)
636 return Nullsv;
da58a35d 637 if (klen < 0) {
638 klen = -klen;
639 is_utf8 = TRUE;
640 }
8990e307 641 if (SvRMAGICAL(hv)) {
0a0bb7c7 642 bool needs_copy;
643 bool needs_store;
644 hv_magic_check (hv, &needs_copy, &needs_store);
645
67a38de0 646 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
647 sv = *svp;
0a0bb7c7 648 mg_clear(sv);
649 if (!needs_store) {
14befaf4 650 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
651 /* No longer an element */
652 sv_unmagic(sv, PERL_MAGIC_tiedelem);
0a0bb7c7 653 return sv;
654 }
655 return Nullsv; /* element cannot be deleted */
656 }
902173a3 657#ifdef ENV_IS_CASELESS
14befaf4 658 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
79cb57f6 659 sv = sv_2mortal(newSVpvn(key,klen));
2fd1c6b8 660 key = strupr(SvPVX(sv));
661 }
902173a3 662#endif
2fd1c6b8 663 }
463ee0b2 664 }
79072805 665 xhv = (XPVHV*)SvANY(hv);
666 if (!xhv->xhv_array)
667 return Nullsv;
fde52b5c 668
75a54232 669 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
670 STRLEN tmplen = klen;
671 /* See the note in hv_fetch(). --jhi */
672 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
673 klen = tmplen;
674 }
f9a63242 675
fde52b5c 676 PERL_HASH(hash, key, klen);
79072805 677
a0d0e21e 678 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
79072805 679 entry = *oentry;
680 i = 1;
fde52b5c 681 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
682 if (HeHASH(entry) != hash) /* strings can't be equal */
79072805 683 continue;
fde52b5c 684 if (HeKLEN(entry) != klen)
79072805 685 continue;
1c846c1f 686 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
79072805 687 continue;
c3654f1a 688 if (HeKUTF8(entry) != (char)is_utf8)
689 continue;
f9a63242 690 if (key != keysave)
691 Safefree(key);
fde52b5c 692 *oentry = HeNEXT(entry);
79072805 693 if (i && !*oentry)
694 xhv->xhv_fill--;
748a9306 695 if (flags & G_DISCARD)
696 sv = Nullsv;
94f7643d 697 else {
79d01fbf 698 sv = sv_2mortal(HeVAL(entry));
94f7643d 699 HeVAL(entry) = &PL_sv_undef;
700 }
a0d0e21e 701 if (entry == xhv->xhv_eiter)
72940dca 702 HvLAZYDEL_on(hv);
a0d0e21e 703 else
68dc0745 704 hv_free_ent(hv, entry);
fde52b5c 705 --xhv->xhv_keys;
706 return sv;
707 }
f9a63242 708 if (key != keysave)
709 Safefree(key);
fde52b5c 710 return Nullsv;
711}
712
954c1994 713/*
714=for apidoc hv_delete_ent
715
716Deletes a key/value pair in the hash. The value SV is removed from the
717hash and returned to the caller. The C<flags> value will normally be zero;
718if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
719precomputed hash value, or 0 to ask for it to be computed.
720
721=cut
722*/
723
fde52b5c 724SV *
864dbfa3 725Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
fde52b5c 726{
727 register XPVHV* xhv;
728 register I32 i;
729 register char *key;
730 STRLEN klen;
731 register HE *entry;
732 register HE **oentry;
733 SV *sv;
da58a35d 734 bool is_utf8;
f9a63242 735 char *keysave;
1c846c1f 736
fde52b5c 737 if (!hv)
738 return Nullsv;
739 if (SvRMAGICAL(hv)) {
0a0bb7c7 740 bool needs_copy;
741 bool needs_store;
742 hv_magic_check (hv, &needs_copy, &needs_store);
743
67a38de0 744 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
0a0bb7c7 745 sv = HeVAL(entry);
746 mg_clear(sv);
747 if (!needs_store) {
14befaf4 748 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
749 /* No longer an element */
750 sv_unmagic(sv, PERL_MAGIC_tiedelem);
0a0bb7c7 751 return sv;
752 }
753 return Nullsv; /* element cannot be deleted */
754 }
902173a3 755#ifdef ENV_IS_CASELESS
14befaf4 756 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
2fd1c6b8 757 key = SvPV(keysv, klen);
79cb57f6 758 keysv = sv_2mortal(newSVpvn(key,klen));
2fd1c6b8 759 (void)strupr(SvPVX(keysv));
1c846c1f 760 hash = 0;
2fd1c6b8 761 }
902173a3 762#endif
2fd1c6b8 763 }
fde52b5c 764 }
765 xhv = (XPVHV*)SvANY(hv);
766 if (!xhv->xhv_array)
767 return Nullsv;
768
f9a63242 769 keysave = key = SvPV(keysv, klen);
da58a35d 770 is_utf8 = (SvUTF8(keysv) != 0);
1c846c1f 771
f9a63242 772 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
773 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
774
fde52b5c 775 if (!hash)
776 PERL_HASH(hash, key, klen);
777
778 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
779 entry = *oentry;
780 i = 1;
781 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
782 if (HeHASH(entry) != hash) /* strings can't be equal */
783 continue;
784 if (HeKLEN(entry) != klen)
785 continue;
1c846c1f 786 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 787 continue;
c3654f1a 788 if (HeKUTF8(entry) != (char)is_utf8)
789 continue;
f9a63242 790 if (key != keysave)
791 Safefree(key);
fde52b5c 792 *oentry = HeNEXT(entry);
793 if (i && !*oentry)
794 xhv->xhv_fill--;
795 if (flags & G_DISCARD)
796 sv = Nullsv;
94f7643d 797 else {
79d01fbf 798 sv = sv_2mortal(HeVAL(entry));
94f7643d 799 HeVAL(entry) = &PL_sv_undef;
800 }
fde52b5c 801 if (entry == xhv->xhv_eiter)
72940dca 802 HvLAZYDEL_on(hv);
fde52b5c 803 else
68dc0745 804 hv_free_ent(hv, entry);
463ee0b2 805 --xhv->xhv_keys;
79072805 806 return sv;
807 }
f9a63242 808 if (key != keysave)
809 Safefree(key);
79072805 810 return Nullsv;
79072805 811}
812
954c1994 813/*
814=for apidoc hv_exists
815
816Returns a boolean indicating whether the specified hash key exists. The
817C<klen> is the length of the key.
818
819=cut
820*/
821
a0d0e21e 822bool
da58a35d 823Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
a0d0e21e 824{
825 register XPVHV* xhv;
fde52b5c 826 register U32 hash;
a0d0e21e 827 register HE *entry;
828 SV *sv;
da58a35d 829 bool is_utf8 = FALSE;
f9a63242 830 const char *keysave = key;
a0d0e21e 831
832 if (!hv)
833 return 0;
834
da58a35d 835 if (klen < 0) {
836 klen = -klen;
837 is_utf8 = TRUE;
838 }
839
a0d0e21e 840 if (SvRMAGICAL(hv)) {
14befaf4 841 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
a0d0e21e 842 sv = sv_newmortal();
1c846c1f 843 mg_copy((SV*)hv, sv, key, klen);
14befaf4 844 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
a0d0e21e 845 return SvTRUE(sv);
846 }
902173a3 847#ifdef ENV_IS_CASELESS
14befaf4 848 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
79cb57f6 849 sv = sv_2mortal(newSVpvn(key,klen));
902173a3 850 key = strupr(SvPVX(sv));
851 }
852#endif
a0d0e21e 853 }
854
855 xhv = (XPVHV*)SvANY(hv);
f675dbe5 856#ifndef DYNAMIC_ENV_FETCH
a0d0e21e 857 if (!xhv->xhv_array)
1c846c1f 858 return 0;
f675dbe5 859#endif
a0d0e21e 860
75a54232 861 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
862 STRLEN tmplen = klen;
863 /* See the note in hv_fetch(). --jhi */
864 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
865 klen = tmplen;
866 }
f9a63242 867
fde52b5c 868 PERL_HASH(hash, key, klen);
a0d0e21e 869
f675dbe5 870#ifdef DYNAMIC_ENV_FETCH
871 if (!xhv->xhv_array) entry = Null(HE*);
872 else
873#endif
a0d0e21e 874 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c 875 for (; entry; entry = HeNEXT(entry)) {
876 if (HeHASH(entry) != hash) /* strings can't be equal */
a0d0e21e 877 continue;
fde52b5c 878 if (HeKLEN(entry) != klen)
a0d0e21e 879 continue;
1c846c1f 880 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 881 continue;
c3654f1a 882 if (HeKUTF8(entry) != (char)is_utf8)
883 continue;
f9a63242 884 if (key != keysave)
885 Safefree(key);
fde52b5c 886 return TRUE;
887 }
f675dbe5 888#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
a6c40364 889 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
890 unsigned long len;
891 char *env = PerlEnv_ENVgetenv_len(key,&len);
892 if (env) {
893 sv = newSVpvn(env,len);
894 SvTAINTED_on(sv);
895 (void)hv_store(hv,key,klen,sv,hash);
896 return TRUE;
897 }
f675dbe5 898 }
899#endif
f9a63242 900 if (key != keysave)
901 Safefree(key);
fde52b5c 902 return FALSE;
903}
904
905
954c1994 906/*
907=for apidoc hv_exists_ent
908
909Returns a boolean indicating whether the specified hash key exists. C<hash>
910can be a valid precomputed hash value, or 0 to ask for it to be
911computed.
912
913=cut
914*/
915
fde52b5c 916bool
864dbfa3 917Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
fde52b5c 918{
919 register XPVHV* xhv;
920 register char *key;
921 STRLEN klen;
922 register HE *entry;
923 SV *sv;
c3654f1a 924 bool is_utf8;
f9a63242 925 char *keysave;
fde52b5c 926
927 if (!hv)
928 return 0;
929
930 if (SvRMAGICAL(hv)) {
14befaf4 931 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
62815d3c 932 SV* svret = sv_newmortal();
fde52b5c 933 sv = sv_newmortal();
effa1e2d 934 keysv = sv_2mortal(newSVsv(keysv));
1c846c1f 935 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
14befaf4 936 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
62815d3c 937 return SvTRUE(svret);
fde52b5c 938 }
902173a3 939#ifdef ENV_IS_CASELESS
14befaf4 940 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
902173a3 941 key = SvPV(keysv, klen);
79cb57f6 942 keysv = sv_2mortal(newSVpvn(key,klen));
902173a3 943 (void)strupr(SvPVX(keysv));
1c846c1f 944 hash = 0;
902173a3 945 }
946#endif
fde52b5c 947 }
948
949 xhv = (XPVHV*)SvANY(hv);
f675dbe5 950#ifndef DYNAMIC_ENV_FETCH
fde52b5c 951 if (!xhv->xhv_array)
1c846c1f 952 return 0;
f675dbe5 953#endif
fde52b5c 954
f9a63242 955 keysave = key = SvPV(keysv, klen);
c3654f1a 956 is_utf8 = (SvUTF8(keysv) != 0);
f9a63242 957 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
958 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
fde52b5c 959 if (!hash)
960 PERL_HASH(hash, key, klen);
961
f675dbe5 962#ifdef DYNAMIC_ENV_FETCH
963 if (!xhv->xhv_array) entry = Null(HE*);
964 else
965#endif
fde52b5c 966 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
967 for (; entry; entry = HeNEXT(entry)) {
968 if (HeHASH(entry) != hash) /* strings can't be equal */
969 continue;
970 if (HeKLEN(entry) != klen)
971 continue;
1c846c1f 972 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
a0d0e21e 973 continue;
c3654f1a 974 if (HeKUTF8(entry) != (char)is_utf8)
975 continue;
f9a63242 976 if (key != keysave)
977 Safefree(key);
a0d0e21e 978 return TRUE;
979 }
f675dbe5 980#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
a6c40364 981 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
982 unsigned long len;
983 char *env = PerlEnv_ENVgetenv_len(key,&len);
984 if (env) {
985 sv = newSVpvn(env,len);
986 SvTAINTED_on(sv);
987 (void)hv_store_ent(hv,keysv,sv,hash);
988 return TRUE;
989 }
f675dbe5 990 }
991#endif
f9a63242 992 if (key != keysave)
993 Safefree(key);
a0d0e21e 994 return FALSE;
995}
996
76e3520e 997STATIC void
cea2e8a9 998S_hsplit(pTHX_ HV *hv)
79072805 999{
1000 register XPVHV* xhv = (XPVHV*)SvANY(hv);
a0d0e21e 1001 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
79072805 1002 register I32 newsize = oldsize * 2;
1003 register I32 i;
72311751 1004 register char *a = xhv->xhv_array;
1005 register HE **aep;
1006 register HE **bep;
79072805 1007 register HE *entry;
1008 register HE **oentry;
1009
3280af22 1010 PL_nomemok = TRUE;
8d6dde3e 1011#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
d18c6117 1012 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1013 if (!a) {
4a33f861 1014 PL_nomemok = FALSE;
422a93e5 1015 return;
1016 }
4633a7c4 1017#else
d18c6117 1018 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1019 if (!a) {
3280af22 1020 PL_nomemok = FALSE;
422a93e5 1021 return;
1022 }
72311751 1023 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
fba3b22e 1024 if (oldsize >= 64) {
d18c6117 1025 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
4633a7c4 1026 }
1027 else
1028 Safefree(xhv->xhv_array);
1029#endif
1030
3280af22 1031 PL_nomemok = FALSE;
72311751 1032 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
79072805 1033 xhv->xhv_max = --newsize;
72311751 1034 xhv->xhv_array = a;
1035 aep = (HE**)a;
79072805 1036
72311751 1037 for (i=0; i<oldsize; i++,aep++) {
1038 if (!*aep) /* non-existent */
79072805 1039 continue;
72311751 1040 bep = aep+oldsize;
1041 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
fde52b5c 1042 if ((HeHASH(entry) & newsize) != i) {
1043 *oentry = HeNEXT(entry);
72311751 1044 HeNEXT(entry) = *bep;
1045 if (!*bep)
79072805 1046 xhv->xhv_fill++;
72311751 1047 *bep = entry;
79072805 1048 continue;
1049 }
1050 else
fde52b5c 1051 oentry = &HeNEXT(entry);
79072805 1052 }
72311751 1053 if (!*aep) /* everything moved */
79072805 1054 xhv->xhv_fill--;
1055 }
1056}
1057
72940dca 1058void
864dbfa3 1059Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
72940dca 1060{
1061 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1062 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
1063 register I32 newsize;
1064 register I32 i;
1065 register I32 j;
72311751 1066 register char *a;
1067 register HE **aep;
72940dca 1068 register HE *entry;
1069 register HE **oentry;
1070
1071 newsize = (I32) newmax; /* possible truncation here */
1072 if (newsize != newmax || newmax <= oldsize)
1073 return;
1074 while ((newsize & (1 + ~newsize)) != newsize) {
1075 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1076 }
1077 if (newsize < newmax)
1078 newsize *= 2;
1079 if (newsize < newmax)
1080 return; /* overflow detection */
1081
72311751 1082 a = xhv->xhv_array;
72940dca 1083 if (a) {
3280af22 1084 PL_nomemok = TRUE;
8d6dde3e 1085#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
d18c6117 1086 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1087 if (!a) {
4a33f861 1088 PL_nomemok = FALSE;
422a93e5 1089 return;
1090 }
72940dca 1091#else
d18c6117 1092 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 1093 if (!a) {
3280af22 1094 PL_nomemok = FALSE;
422a93e5 1095 return;
1096 }
72311751 1097 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
fba3b22e 1098 if (oldsize >= 64) {
d18c6117 1099 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
72940dca 1100 }
1101 else
1102 Safefree(xhv->xhv_array);
1103#endif
3280af22 1104 PL_nomemok = FALSE;
72311751 1105 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
72940dca 1106 }
1107 else {
d18c6117 1108 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
72940dca 1109 }
1110 xhv->xhv_max = --newsize;
72311751 1111 xhv->xhv_array = a;
72940dca 1112 if (!xhv->xhv_fill) /* skip rest if no entries */
1113 return;
1114
72311751 1115 aep = (HE**)a;
1116 for (i=0; i<oldsize; i++,aep++) {
1117 if (!*aep) /* non-existent */
72940dca 1118 continue;
72311751 1119 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
72940dca 1120 if ((j = (HeHASH(entry) & newsize)) != i) {
1121 j -= i;
1122 *oentry = HeNEXT(entry);
72311751 1123 if (!(HeNEXT(entry) = aep[j]))
72940dca 1124 xhv->xhv_fill++;
72311751 1125 aep[j] = entry;
72940dca 1126 continue;
1127 }
1128 else
1129 oentry = &HeNEXT(entry);
1130 }
72311751 1131 if (!*aep) /* everything moved */
72940dca 1132 xhv->xhv_fill--;
1133 }
1134}
1135
954c1994 1136/*
1137=for apidoc newHV
1138
1139Creates a new HV. The reference count is set to 1.
1140
1141=cut
1142*/
1143
79072805 1144HV *
864dbfa3 1145Perl_newHV(pTHX)
79072805 1146{
1147 register HV *hv;
1148 register XPVHV* xhv;
1149
a0d0e21e 1150 hv = (HV*)NEWSV(502,0);
1151 sv_upgrade((SV *)hv, SVt_PVHV);
79072805 1152 xhv = (XPVHV*)SvANY(hv);
1153 SvPOK_off(hv);
1154 SvNOK_off(hv);
1c846c1f 1155#ifndef NODEFAULT_SHAREKEYS
fde52b5c 1156 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1c846c1f 1157#endif
463ee0b2 1158 xhv->xhv_max = 7; /* start with 8 buckets */
79072805 1159 xhv->xhv_fill = 0;
1160 xhv->xhv_pmroot = 0;
79072805 1161 (void)hv_iterinit(hv); /* so each() will start off right */
1162 return hv;
1163}
1164
b3ac6de7 1165HV *
864dbfa3 1166Perl_newHVhv(pTHX_ HV *ohv)
b3ac6de7 1167{
1168 register HV *hv;
b3ac6de7 1169 STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1170 STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1171
1172 hv = newHV();
1173 while (hv_max && hv_max + 1 >= hv_fill * 2)
1174 hv_max = hv_max / 2; /* Is always 2^n-1 */
4a76a316 1175 HvMAX(hv) = hv_max;
b3ac6de7 1176 if (!hv_fill)
1177 return hv;
1178
1179#if 0
14befaf4 1180 if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
b3ac6de7 1181 /* Quick way ???*/
1c846c1f 1182 }
1183 else
b3ac6de7 1184#endif
1185 {
1186 HE *entry;
1187 I32 hv_riter = HvRITER(ohv); /* current root of iterator */
1188 HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
1189
1190 /* Slow way */
4a76a316 1191 hv_iterinit(ohv);
155aba94 1192 while ((entry = hv_iternext(ohv))) {
c3654f1a 1193 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
00122d59 1194 newSVsv(HeVAL(entry)), HeHASH(entry));
b3ac6de7 1195 }
1196 HvRITER(ohv) = hv_riter;
1197 HvEITER(ohv) = hv_eiter;
1198 }
1c846c1f 1199
b3ac6de7 1200 return hv;
1201}
1202
79072805 1203void
864dbfa3 1204Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
79072805 1205{
16bdeea2 1206 SV *val;
1207
68dc0745 1208 if (!entry)
79072805 1209 return;
16bdeea2 1210 val = HeVAL(entry);
257c9e5b 1211 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
3280af22 1212 PL_sub_generation++; /* may be deletion of method from stash */
16bdeea2 1213 SvREFCNT_dec(val);
68dc0745 1214 if (HeKLEN(entry) == HEf_SVKEY) {
1215 SvREFCNT_dec(HeKEY_sv(entry));
1216 Safefree(HeKEY_hek(entry));
44a8e56a 1217 }
1218 else if (HvSHAREKEYS(hv))
68dc0745 1219 unshare_hek(HeKEY_hek(entry));
fde52b5c 1220 else
68dc0745 1221 Safefree(HeKEY_hek(entry));
d33b2eba 1222 del_HE(entry);
79072805 1223}
1224
1225void
864dbfa3 1226Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
79072805 1227{
68dc0745 1228 if (!entry)
79072805 1229 return;
68dc0745 1230 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
3280af22 1231 PL_sub_generation++; /* may be deletion of method from stash */
68dc0745 1232 sv_2mortal(HeVAL(entry)); /* free between statements */
1233 if (HeKLEN(entry) == HEf_SVKEY) {
1234 sv_2mortal(HeKEY_sv(entry));
1235 Safefree(HeKEY_hek(entry));
44a8e56a 1236 }
1237 else if (HvSHAREKEYS(hv))
68dc0745 1238 unshare_hek(HeKEY_hek(entry));
fde52b5c 1239 else
68dc0745 1240 Safefree(HeKEY_hek(entry));
d33b2eba 1241 del_HE(entry);
79072805 1242}
1243
954c1994 1244/*
1245=for apidoc hv_clear
1246
1247Clears a hash, making it empty.
1248
1249=cut
1250*/
1251
79072805 1252void
864dbfa3 1253Perl_hv_clear(pTHX_ HV *hv)
79072805 1254{
1255 register XPVHV* xhv;
1256 if (!hv)
1257 return;
1258 xhv = (XPVHV*)SvANY(hv);
463ee0b2 1259 hfreeentries(hv);
79072805 1260 xhv->xhv_fill = 0;
a0d0e21e 1261 xhv->xhv_keys = 0;
79072805 1262 if (xhv->xhv_array)
463ee0b2 1263 (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
a0d0e21e 1264
1265 if (SvRMAGICAL(hv))
1c846c1f 1266 mg_clear((SV*)hv);
79072805 1267}
1268
76e3520e 1269STATIC void
cea2e8a9 1270S_hfreeentries(pTHX_ HV *hv)
79072805 1271{
a0d0e21e 1272 register HE **array;
68dc0745 1273 register HE *entry;
1274 register HE *oentry = Null(HE*);
a0d0e21e 1275 I32 riter;
1276 I32 max;
79072805 1277
1278 if (!hv)
1279 return;
a0d0e21e 1280 if (!HvARRAY(hv))
79072805 1281 return;
a0d0e21e 1282
1283 riter = 0;
1284 max = HvMAX(hv);
1285 array = HvARRAY(hv);
68dc0745 1286 entry = array[0];
a0d0e21e 1287 for (;;) {
68dc0745 1288 if (entry) {
1289 oentry = entry;
1290 entry = HeNEXT(entry);
1291 hv_free_ent(hv, oentry);
a0d0e21e 1292 }
68dc0745 1293 if (!entry) {
a0d0e21e 1294 if (++riter > max)
1295 break;
68dc0745 1296 entry = array[riter];
1c846c1f 1297 }
79072805 1298 }
a0d0e21e 1299 (void)hv_iterinit(hv);
79072805 1300}
1301
954c1994 1302/*
1303=for apidoc hv_undef
1304
1305Undefines the hash.
1306
1307=cut
1308*/
1309
79072805 1310void
864dbfa3 1311Perl_hv_undef(pTHX_ HV *hv)
79072805 1312{
1313 register XPVHV* xhv;
1314 if (!hv)
1315 return;
1316 xhv = (XPVHV*)SvANY(hv);
463ee0b2 1317 hfreeentries(hv);
9b3a60d0 1318 Safefree(xhv->xhv_array);
85e6fe83 1319 if (HvNAME(hv)) {
1320 Safefree(HvNAME(hv));
1321 HvNAME(hv) = 0;
1322 }
79072805 1323 xhv->xhv_array = 0;
aa689395 1324 xhv->xhv_max = 7; /* it's a normal hash */
79072805 1325 xhv->xhv_fill = 0;
a0d0e21e 1326 xhv->xhv_keys = 0;
1327
1328 if (SvRMAGICAL(hv))
1c846c1f 1329 mg_clear((SV*)hv);
79072805 1330}
1331
954c1994 1332/*
1333=for apidoc hv_iterinit
1334
1335Prepares a starting point to traverse a hash table. Returns the number of
1336keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1c846c1f 1337currently only meaningful for hashes without tie magic.
954c1994 1338
1339NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1340hash buckets that happen to be in use. If you still need that esoteric
1341value, you can get it through the macro C<HvFILL(tb)>.
1342
1343=cut
1344*/
1345
79072805 1346I32
864dbfa3 1347Perl_hv_iterinit(pTHX_ HV *hv)
79072805 1348{
aa689395 1349 register XPVHV* xhv;
1350 HE *entry;
1351
1352 if (!hv)
cea2e8a9 1353 Perl_croak(aTHX_ "Bad hash");
aa689395 1354 xhv = (XPVHV*)SvANY(hv);
1355 entry = xhv->xhv_eiter;
72940dca 1356 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1357 HvLAZYDEL_off(hv);
68dc0745 1358 hv_free_ent(hv, entry);
72940dca 1359 }
79072805 1360 xhv->xhv_riter = -1;
1361 xhv->xhv_eiter = Null(HE*);
c6601927 1362 return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
79072805 1363}
1364
954c1994 1365/*
1366=for apidoc hv_iternext
1367
1368Returns entries from a hash iterator. See C<hv_iterinit>.
1369
1370=cut
1371*/
1372
79072805 1373HE *
864dbfa3 1374Perl_hv_iternext(pTHX_ HV *hv)
79072805 1375{
1376 register XPVHV* xhv;
1377 register HE *entry;
a0d0e21e 1378 HE *oldentry;
463ee0b2 1379 MAGIC* mg;
79072805 1380
1381 if (!hv)
cea2e8a9 1382 Perl_croak(aTHX_ "Bad hash");
79072805 1383 xhv = (XPVHV*)SvANY(hv);
a0d0e21e 1384 oldentry = entry = xhv->xhv_eiter;
463ee0b2 1385
14befaf4 1386 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
8990e307 1387 SV *key = sv_newmortal();
cd1469e6 1388 if (entry) {
fde52b5c 1389 sv_setsv(key, HeSVKEY_force(entry));
cd1469e6 1390 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1391 }
a0d0e21e 1392 else {
ff68c719 1393 char *k;
bbce6d69 1394 HEK *hek;
ff68c719 1395
d33b2eba 1396 xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
4633a7c4 1397 Zero(entry, 1, HE);
ff68c719 1398 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1399 hek = (HEK*)k;
1400 HeKEY_hek(entry) = hek;
fde52b5c 1401 HeKLEN(entry) = HEf_SVKEY;
a0d0e21e 1402 }
1403 magic_nextpack((SV*) hv,mg,key);
463ee0b2 1404 if (SvOK(key)) {
cd1469e6 1405 /* force key to stay around until next time */
bbce6d69 1406 HeSVKEY_set(entry, SvREFCNT_inc(key));
1407 return entry; /* beware, hent_val is not set */
463ee0b2 1408 }
fde52b5c 1409 if (HeVAL(entry))
1410 SvREFCNT_dec(HeVAL(entry));
ff68c719 1411 Safefree(HeKEY_hek(entry));
d33b2eba 1412 del_HE(entry);
463ee0b2 1413 xhv->xhv_eiter = Null(HE*);
1414 return Null(HE*);
79072805 1415 }
f675dbe5 1416#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1417 if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1418 prime_env_iter();
1419#endif
463ee0b2 1420
79072805 1421 if (!xhv->xhv_array)
d18c6117 1422 Newz(506, xhv->xhv_array,
1423 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
fde52b5c 1424 if (entry)
1425 entry = HeNEXT(entry);
1426 while (!entry) {
1427 ++xhv->xhv_riter;
1428 if (xhv->xhv_riter > xhv->xhv_max) {
1429 xhv->xhv_riter = -1;
1430 break;
79072805 1431 }
fde52b5c 1432 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1433 }
79072805 1434
72940dca 1435 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1436 HvLAZYDEL_off(hv);
68dc0745 1437 hv_free_ent(hv, oldentry);
72940dca 1438 }
a0d0e21e 1439
79072805 1440 xhv->xhv_eiter = entry;
1441 return entry;
1442}
1443
954c1994 1444/*
1445=for apidoc hv_iterkey
1446
1447Returns the key from the current position of the hash iterator. See
1448C<hv_iterinit>.
1449
1450=cut
1451*/
1452
79072805 1453char *
864dbfa3 1454Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 1455{
fde52b5c 1456 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a 1457 STRLEN len;
1458 char *p = SvPV(HeKEY_sv(entry), len);
1459 *retlen = len;
1460 return p;
fde52b5c 1461 }
1462 else {
1463 *retlen = HeKLEN(entry);
1464 return HeKEY(entry);
1465 }
1466}
1467
1468/* unlike hv_iterval(), this always returns a mortal copy of the key */
954c1994 1469/*
1470=for apidoc hv_iterkeysv
1471
1472Returns the key as an C<SV*> from the current position of the hash
1473iterator. The return value will always be a mortal copy of the key. Also
1474see C<hv_iterinit>.
1475
1476=cut
1477*/
1478
fde52b5c 1479SV *
864dbfa3 1480Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c 1481{
1482 if (HeKLEN(entry) == HEf_SVKEY)
bbce6d69 1483 return sv_mortalcopy(HeKEY_sv(entry));
c3654f1a 1484 else
1485 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1486 HeKLEN_UTF8(entry), HeHASH(entry)));
79072805 1487}
1488
954c1994 1489/*
1490=for apidoc hv_iterval
1491
1492Returns the value from the current position of the hash iterator. See
1493C<hv_iterkey>.
1494
1495=cut
1496*/
1497
79072805 1498SV *
864dbfa3 1499Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 1500{
8990e307 1501 if (SvRMAGICAL(hv)) {
14befaf4 1502 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
8990e307 1503 SV* sv = sv_newmortal();
bbce6d69 1504 if (HeKLEN(entry) == HEf_SVKEY)
1505 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1506 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
463ee0b2 1507 return sv;
1508 }
79072805 1509 }
fde52b5c 1510 return HeVAL(entry);
79072805 1511}
1512
954c1994 1513/*
1514=for apidoc hv_iternextsv
1515
1516Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1517operation.
1518
1519=cut
1520*/
1521
a0d0e21e 1522SV *
864dbfa3 1523Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e 1524{
1525 HE *he;
1526 if ( (he = hv_iternext(hv)) == NULL)
1527 return NULL;
1528 *key = hv_iterkey(he, retlen);
1529 return hv_iterval(hv, he);
1530}
1531
954c1994 1532/*
1533=for apidoc hv_magic
1534
1535Adds magic to a hash. See C<sv_magic>.
1536
1537=cut
1538*/
1539
79072805 1540void
864dbfa3 1541Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
79072805 1542{
a0d0e21e 1543 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
79072805 1544}
fde52b5c 1545
bbce6d69 1546char*
864dbfa3 1547Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
bbce6d69 1548{
ff68c719 1549 return HEK_KEY(share_hek(sv, len, hash));
bbce6d69 1550}
1551
1552/* possibly free a shared string if no one has access to it
fde52b5c 1553 * len and hash must both be valid for str.
1554 */
bbce6d69 1555void
864dbfa3 1556Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 1557{
1558 register XPVHV* xhv;
1559 register HE *entry;
1560 register HE **oentry;
1561 register I32 i = 1;
1562 I32 found = 0;
c3654f1a 1563 bool is_utf8 = FALSE;
f9a63242 1564 const char *save = str;
c3654f1a 1565
1566 if (len < 0) {
1567 len = -len;
1568 is_utf8 = TRUE;
75a54232 1569 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1570 STRLEN tmplen = len;
1571 /* See the note in hv_fetch(). --jhi */
1572 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1573 len = tmplen;
1574 }
c3654f1a 1575 }
1c846c1f 1576
fde52b5c 1577 /* what follows is the moral equivalent of:
6b88bc9c 1578 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
bbce6d69 1579 if (--*Svp == Nullsv)
6b88bc9c 1580 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 1581 } */
3280af22 1582 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 1583 /* assert(xhv_array != 0) */
5f08fbcd 1584 LOCK_STRTAB_MUTEX;
fde52b5c 1585 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
bbce6d69 1586 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
fde52b5c 1587 if (HeHASH(entry) != hash) /* strings can't be equal */
1588 continue;
1589 if (HeKLEN(entry) != len)
1590 continue;
1c846c1f 1591 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 1592 continue;
c3654f1a 1593 if (HeKUTF8(entry) != (char)is_utf8)
1594 continue;
fde52b5c 1595 found = 1;
bbce6d69 1596 if (--HeVAL(entry) == Nullsv) {
1597 *oentry = HeNEXT(entry);
1598 if (i && !*oentry)
1599 xhv->xhv_fill--;
ff68c719 1600 Safefree(HeKEY_hek(entry));
d33b2eba 1601 del_HE(entry);
bbce6d69 1602 --xhv->xhv_keys;
fde52b5c 1603 }
bbce6d69 1604 break;
fde52b5c 1605 }
333f433b 1606 UNLOCK_STRTAB_MUTEX;
f9a63242 1607 if (str != save)
1608 Safefree(str);
411caa50 1609 if (!found && ckWARN_d(WARN_INTERNAL))
1610 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
fde52b5c 1611}
1612
bbce6d69 1613/* get a (constant) string ptr from the global string table
1614 * string will get added if it is not already there.
fde52b5c 1615 * len and hash must both be valid for str.
1616 */
bbce6d69 1617HEK *
864dbfa3 1618Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 1619{
1620 register XPVHV* xhv;
1621 register HE *entry;
1622 register HE **oentry;
1623 register I32 i = 1;
1624 I32 found = 0;
da58a35d 1625 bool is_utf8 = FALSE;
f9a63242 1626 const char *save = str;
da58a35d 1627
1628 if (len < 0) {
1629 len = -len;
1630 is_utf8 = TRUE;
75a54232 1631 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1632 STRLEN tmplen = len;
1633 /* See the note in hv_fetch(). --jhi */
1634 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1635 len = tmplen;
1636 }
da58a35d 1637 }
bbce6d69 1638
fde52b5c 1639 /* what follows is the moral equivalent of:
1c846c1f 1640
6b88bc9c 1641 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1642 hv_store(PL_strtab, str, len, Nullsv, hash);
bbce6d69 1643 */
3280af22 1644 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 1645 /* assert(xhv_array != 0) */
5f08fbcd 1646 LOCK_STRTAB_MUTEX;
fde52b5c 1647 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
bbce6d69 1648 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
fde52b5c 1649 if (HeHASH(entry) != hash) /* strings can't be equal */
1650 continue;
1651 if (HeKLEN(entry) != len)
1652 continue;
1c846c1f 1653 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 1654 continue;
c3654f1a 1655 if (HeKUTF8(entry) != (char)is_utf8)
1656 continue;
fde52b5c 1657 found = 1;
fde52b5c 1658 break;
1659 }
bbce6d69 1660 if (!found) {
d33b2eba 1661 entry = new_HE();
c3654f1a 1662 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
bbce6d69 1663 HeVAL(entry) = Nullsv;
1664 HeNEXT(entry) = *oentry;
1665 *oentry = entry;
1666 xhv->xhv_keys++;
1667 if (i) { /* initial entry? */
1668 ++xhv->xhv_fill;
1669 if (xhv->xhv_keys > xhv->xhv_max)
3280af22 1670 hsplit(PL_strtab);
bbce6d69 1671 }
1672 }
1673
1674 ++HeVAL(entry); /* use value slot as REFCNT */
5f08fbcd 1675 UNLOCK_STRTAB_MUTEX;
f9a63242 1676 if (str != save)
1677 Safefree(str);
ff68c719 1678 return HeKEY_hek(entry);
fde52b5c 1679}