Dethinko.
[p5sagit/p5-mst-13.2.git] / hv.c
CommitLineData
a0d0e21e 1/* hv.c
79072805 2 *
4eb8286e 3 * Copyright (c) 1991-1999, 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
dcb4812c 18#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
19# define ARRAY_ALLOC_BYTES(size) ( (size)*sizeof(HE*) )
20#else
21# define MALLOC_OVERHEAD 16
e094bb4e 22# define ARRAY_ALLOC_BYTES(size) ( ((size) < 64) \
23 ? (size)*sizeof(HE*) \
24 : (size)*sizeof(HE*)*2 - MALLOC_OVERHEAD )
dcb4812c 25#endif
26
76e3520e 27STATIC HE*
cea2e8a9 28S_new_he(pTHX)
4633a7c4 29{
30 HE* he;
333f433b 31 LOCK_SV_MUTEX;
32 if (!PL_he_root)
33 more_he();
34 he = PL_he_root;
35 PL_he_root = HeNEXT(he);
36 UNLOCK_SV_MUTEX;
37 return he;
4633a7c4 38}
39
76e3520e 40STATIC void
cea2e8a9 41S_del_he(pTHX_ HE *p)
4633a7c4 42{
333f433b 43 LOCK_SV_MUTEX;
3280af22 44 HeNEXT(p) = (HE*)PL_he_root;
45 PL_he_root = p;
333f433b 46 UNLOCK_SV_MUTEX;
4633a7c4 47}
48
333f433b 49STATIC void
cea2e8a9 50S_more_he(pTHX)
4633a7c4 51{
52 register HE* he;
53 register HE* heend;
3280af22 54 New(54, PL_he_root, 1008/sizeof(HE), HE);
55 he = PL_he_root;
4633a7c4 56 heend = &he[1008 / sizeof(HE) - 1];
57 while (he < heend) {
fde52b5c 58 HeNEXT(he) = (HE*)(he + 1);
4633a7c4 59 he++;
60 }
fde52b5c 61 HeNEXT(he) = 0;
4633a7c4 62}
63
76e3520e 64STATIC HEK *
cea2e8a9 65S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
bbce6d69 66{
67 char *k;
68 register HEK *hek;
69
ff68c719 70 New(54, k, HEK_BASESIZE + len + 1, char);
bbce6d69 71 hek = (HEK*)k;
ff68c719 72 Copy(str, HEK_KEY(hek), len, char);
73 *(HEK_KEY(hek) + len) = '\0';
74 HEK_LEN(hek) = len;
75 HEK_HASH(hek) = hash;
bbce6d69 76 return hek;
77}
78
79void
864dbfa3 80Perl_unshare_hek(pTHX_ HEK *hek)
bbce6d69 81{
ff68c719 82 unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
bbce6d69 83}
84
fde52b5c 85/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
86 * contains an SV* */
87
79072805 88SV**
864dbfa3 89Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
79072805 90{
91 register XPVHV* xhv;
fde52b5c 92 register U32 hash;
79072805 93 register HE *entry;
79072805 94 SV *sv;
79072805 95
96 if (!hv)
97 return 0;
463ee0b2 98
8990e307 99 if (SvRMAGICAL(hv)) {
463ee0b2 100 if (mg_find((SV*)hv,'P')) {
11343788 101 dTHR;
8990e307 102 sv = sv_newmortal();
463ee0b2 103 mg_copy((SV*)hv, sv, key, klen);
3280af22 104 PL_hv_fetch_sv = sv;
105 return &PL_hv_fetch_sv;
463ee0b2 106 }
902173a3 107#ifdef ENV_IS_CASELESS
108 else if (mg_find((SV*)hv,'E')) {
e7152ba2 109 U32 i;
110 for (i = 0; i < klen; ++i)
111 if (isLOWER(key[i])) {
79cb57f6 112 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
e7152ba2 113 SV **ret = hv_fetch(hv, nkey, klen, 0);
114 if (!ret && lval)
115 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
116 return ret;
117 }
902173a3 118 }
119#endif
463ee0b2 120 }
121
79072805 122 xhv = (XPVHV*)SvANY(hv);
123 if (!xhv->xhv_array) {
a0d0e21e 124 if (lval
125#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
126 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
127#endif
128 )
dcb4812c 129 Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
79072805 130 else
131 return 0;
132 }
133
fde52b5c 134 PERL_HASH(hash, key, klen);
79072805 135
a0d0e21e 136 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c 137 for (; entry; entry = HeNEXT(entry)) {
138 if (HeHASH(entry) != hash) /* strings can't be equal */
79072805 139 continue;
fde52b5c 140 if (HeKLEN(entry) != klen)
79072805 141 continue;
36477c24 142 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
79072805 143 continue;
fde52b5c 144 return &HeVAL(entry);
79072805 145 }
a0d0e21e 146#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
147 if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
a6c40364 148 unsigned long len;
149 char *env = PerlEnv_ENVgetenv_len(key,&len);
150 if (env) {
151 sv = newSVpvn(env,len);
152 SvTAINTED_on(sv);
153 return hv_store(hv,key,klen,sv,hash);
154 }
a0d0e21e 155 }
156#endif
79072805 157 if (lval) { /* gonna assign to this, so it better be there */
158 sv = NEWSV(61,0);
e7152ba2 159 return hv_store(hv,key,klen,sv,hash);
79072805 160 }
161 return 0;
162}
163
fde52b5c 164/* returns a HE * structure with the all fields set */
165/* note that hent_val will be a mortal sv for MAGICAL hashes */
166HE *
864dbfa3 167Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
fde52b5c 168{
169 register XPVHV* xhv;
170 register char *key;
171 STRLEN klen;
172 register HE *entry;
173 SV *sv;
174
175 if (!hv)
176 return 0;
177
902173a3 178 if (SvRMAGICAL(hv)) {
179 if (mg_find((SV*)hv,'P')) {
6ff68fdd 180 dTHR;
902173a3 181 sv = sv_newmortal();
182 keysv = sv_2mortal(newSVsv(keysv));
183 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
3280af22 184 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
902173a3 185 char *k;
186 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
3280af22 187 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
902173a3 188 }
3280af22 189 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
190 HeVAL(&PL_hv_fetch_ent_mh) = sv;
191 return &PL_hv_fetch_ent_mh;
1cf368ac 192 }
902173a3 193#ifdef ENV_IS_CASELESS
194 else if (mg_find((SV*)hv,'E')) {
e7152ba2 195 U32 i;
902173a3 196 key = SvPV(keysv, klen);
e7152ba2 197 for (i = 0; i < klen; ++i)
198 if (isLOWER(key[i])) {
79cb57f6 199 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
e7152ba2 200 (void)strupr(SvPVX(nkeysv));
201 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
202 if (!entry && lval)
203 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
204 return entry;
205 }
902173a3 206 }
207#endif
fde52b5c 208 }
209
effa1e2d 210 xhv = (XPVHV*)SvANY(hv);
fde52b5c 211 if (!xhv->xhv_array) {
212 if (lval
213#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
214 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
215#endif
216 )
dcb4812c 217 Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
fde52b5c 218 else
219 return 0;
220 }
221
effa1e2d 222 key = SvPV(keysv, klen);
223
224 if (!hash)
225 PERL_HASH(hash, key, klen);
226
fde52b5c 227 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
228 for (; entry; entry = HeNEXT(entry)) {
229 if (HeHASH(entry) != hash) /* strings can't be equal */
230 continue;
231 if (HeKLEN(entry) != klen)
232 continue;
36477c24 233 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 234 continue;
235 return entry;
236 }
237#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
238 if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
a6c40364 239 unsigned long len;
240 char *env = PerlEnv_ENVgetenv_len(key,&len);
241 if (env) {
242 sv = newSVpvn(env,len);
243 SvTAINTED_on(sv);
244 return hv_store_ent(hv,keysv,sv,hash);
245 }
fde52b5c 246 }
247#endif
248 if (lval) { /* gonna assign to this, so it better be there */
249 sv = NEWSV(61,0);
e7152ba2 250 return hv_store_ent(hv,keysv,sv,hash);
fde52b5c 251 }
252 return 0;
253}
254
864dbfa3 255STATIC void
cea2e8a9 256S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
d0066dc7 257{
258 MAGIC *mg = SvMAGIC(hv);
259 *needs_copy = FALSE;
260 *needs_store = TRUE;
261 while (mg) {
262 if (isUPPER(mg->mg_type)) {
263 *needs_copy = TRUE;
264 switch (mg->mg_type) {
265 case 'P':
d0066dc7 266 case 'S':
267 *needs_store = FALSE;
d0066dc7 268 }
269 }
270 mg = mg->mg_moremagic;
271 }
272}
273
79072805 274SV**
864dbfa3 275Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
79072805 276{
277 register XPVHV* xhv;
79072805 278 register I32 i;
279 register HE *entry;
280 register HE **oentry;
79072805 281
282 if (!hv)
283 return 0;
284
285 xhv = (XPVHV*)SvANY(hv);
463ee0b2 286 if (SvMAGICAL(hv)) {
d0066dc7 287 bool needs_copy;
288 bool needs_store;
289 hv_magic_check (hv, &needs_copy, &needs_store);
290 if (needs_copy) {
291 mg_copy((SV*)hv, val, key, klen);
292 if (!xhv->xhv_array && !needs_store)
293 return 0;
902173a3 294#ifdef ENV_IS_CASELESS
295 else if (mg_find((SV*)hv,'E')) {
79cb57f6 296 SV *sv = sv_2mortal(newSVpvn(key,klen));
902173a3 297 key = strupr(SvPVX(sv));
298 hash = 0;
299 }
300#endif
d0066dc7 301 }
463ee0b2 302 }
fde52b5c 303 if (!hash)
304 PERL_HASH(hash, key, klen);
305
306 if (!xhv->xhv_array)
dcb4812c 307 Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
fde52b5c 308
309 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
310 i = 1;
311
312 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
313 if (HeHASH(entry) != hash) /* strings can't be equal */
314 continue;
315 if (HeKLEN(entry) != klen)
316 continue;
36477c24 317 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 318 continue;
319 SvREFCNT_dec(HeVAL(entry));
320 HeVAL(entry) = val;
321 return &HeVAL(entry);
322 }
323
324 entry = new_he();
fde52b5c 325 if (HvSHAREKEYS(hv))
ff68c719 326 HeKEY_hek(entry) = share_hek(key, klen, hash);
fde52b5c 327 else /* gotta do the real thing */
ff68c719 328 HeKEY_hek(entry) = save_hek(key, klen, hash);
fde52b5c 329 HeVAL(entry) = val;
fde52b5c 330 HeNEXT(entry) = *oentry;
331 *oentry = entry;
332
333 xhv->xhv_keys++;
334 if (i) { /* initial entry? */
335 ++xhv->xhv_fill;
336 if (xhv->xhv_keys > xhv->xhv_max)
337 hsplit(hv);
79072805 338 }
339
fde52b5c 340 return &HeVAL(entry);
341}
342
343HE *
864dbfa3 344Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
fde52b5c 345{
346 register XPVHV* xhv;
347 register char *key;
348 STRLEN klen;
349 register I32 i;
350 register HE *entry;
351 register HE **oentry;
352
353 if (!hv)
354 return 0;
355
356 xhv = (XPVHV*)SvANY(hv);
357 if (SvMAGICAL(hv)) {
aeea060c 358 dTHR;
d0066dc7 359 bool needs_copy;
360 bool needs_store;
361 hv_magic_check (hv, &needs_copy, &needs_store);
362 if (needs_copy) {
3280af22 363 bool save_taint = PL_tainted;
364 if (PL_tainting)
365 PL_tainted = SvTAINTED(keysv);
d0066dc7 366 keysv = sv_2mortal(newSVsv(keysv));
367 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
368 TAINT_IF(save_taint);
369 if (!xhv->xhv_array && !needs_store)
370 return Nullhe;
902173a3 371#ifdef ENV_IS_CASELESS
372 else if (mg_find((SV*)hv,'E')) {
373 key = SvPV(keysv, klen);
79cb57f6 374 keysv = sv_2mortal(newSVpvn(key,klen));
902173a3 375 (void)strupr(SvPVX(keysv));
376 hash = 0;
377 }
378#endif
379 }
fde52b5c 380 }
381
382 key = SvPV(keysv, klen);
902173a3 383
fde52b5c 384 if (!hash)
385 PERL_HASH(hash, key, klen);
386
79072805 387 if (!xhv->xhv_array)
dcb4812c 388 Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
79072805 389
a0d0e21e 390 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
79072805 391 i = 1;
392
fde52b5c 393 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
394 if (HeHASH(entry) != hash) /* strings can't be equal */
79072805 395 continue;
fde52b5c 396 if (HeKLEN(entry) != klen)
79072805 397 continue;
36477c24 398 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
79072805 399 continue;
fde52b5c 400 SvREFCNT_dec(HeVAL(entry));
401 HeVAL(entry) = val;
402 return entry;
79072805 403 }
79072805 404
4633a7c4 405 entry = new_he();
fde52b5c 406 if (HvSHAREKEYS(hv))
ff68c719 407 HeKEY_hek(entry) = share_hek(key, klen, hash);
fde52b5c 408 else /* gotta do the real thing */
ff68c719 409 HeKEY_hek(entry) = save_hek(key, klen, hash);
fde52b5c 410 HeVAL(entry) = val;
fde52b5c 411 HeNEXT(entry) = *oentry;
79072805 412 *oentry = entry;
413
463ee0b2 414 xhv->xhv_keys++;
79072805 415 if (i) { /* initial entry? */
463ee0b2 416 ++xhv->xhv_fill;
417 if (xhv->xhv_keys > xhv->xhv_max)
79072805 418 hsplit(hv);
419 }
79072805 420
fde52b5c 421 return entry;
79072805 422}
423
424SV *
864dbfa3 425Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
79072805 426{
427 register XPVHV* xhv;
79072805 428 register I32 i;
fde52b5c 429 register U32 hash;
79072805 430 register HE *entry;
431 register HE **oentry;
67a38de0 432 SV **svp;
79072805 433 SV *sv;
79072805 434
435 if (!hv)
436 return Nullsv;
8990e307 437 if (SvRMAGICAL(hv)) {
0a0bb7c7 438 bool needs_copy;
439 bool needs_store;
440 hv_magic_check (hv, &needs_copy, &needs_store);
441
67a38de0 442 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
443 sv = *svp;
0a0bb7c7 444 mg_clear(sv);
445 if (!needs_store) {
446 if (mg_find(sv, 'p')) {
447 sv_unmagic(sv, 'p'); /* No longer an element */
448 return sv;
449 }
450 return Nullsv; /* element cannot be deleted */
451 }
902173a3 452#ifdef ENV_IS_CASELESS
2fd1c6b8 453 else if (mg_find((SV*)hv,'E')) {
79cb57f6 454 sv = sv_2mortal(newSVpvn(key,klen));
2fd1c6b8 455 key = strupr(SvPVX(sv));
456 }
902173a3 457#endif
2fd1c6b8 458 }
463ee0b2 459 }
79072805 460 xhv = (XPVHV*)SvANY(hv);
461 if (!xhv->xhv_array)
462 return Nullsv;
fde52b5c 463
464 PERL_HASH(hash, key, klen);
79072805 465
a0d0e21e 466 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
79072805 467 entry = *oentry;
468 i = 1;
fde52b5c 469 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
470 if (HeHASH(entry) != hash) /* strings can't be equal */
79072805 471 continue;
fde52b5c 472 if (HeKLEN(entry) != klen)
79072805 473 continue;
36477c24 474 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
79072805 475 continue;
fde52b5c 476 *oentry = HeNEXT(entry);
79072805 477 if (i && !*oentry)
478 xhv->xhv_fill--;
748a9306 479 if (flags & G_DISCARD)
480 sv = Nullsv;
481 else
fde52b5c 482 sv = sv_mortalcopy(HeVAL(entry));
a0d0e21e 483 if (entry == xhv->xhv_eiter)
72940dca 484 HvLAZYDEL_on(hv);
a0d0e21e 485 else
68dc0745 486 hv_free_ent(hv, entry);
fde52b5c 487 --xhv->xhv_keys;
488 return sv;
489 }
490 return Nullsv;
491}
492
493SV *
864dbfa3 494Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
fde52b5c 495{
496 register XPVHV* xhv;
497 register I32 i;
498 register char *key;
499 STRLEN klen;
500 register HE *entry;
501 register HE **oentry;
502 SV *sv;
503
504 if (!hv)
505 return Nullsv;
506 if (SvRMAGICAL(hv)) {
0a0bb7c7 507 bool needs_copy;
508 bool needs_store;
509 hv_magic_check (hv, &needs_copy, &needs_store);
510
67a38de0 511 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
0a0bb7c7 512 sv = HeVAL(entry);
513 mg_clear(sv);
514 if (!needs_store) {
515 if (mg_find(sv, 'p')) {
516 sv_unmagic(sv, 'p'); /* No longer an element */
517 return sv;
518 }
519 return Nullsv; /* element cannot be deleted */
520 }
902173a3 521#ifdef ENV_IS_CASELESS
2fd1c6b8 522 else if (mg_find((SV*)hv,'E')) {
523 key = SvPV(keysv, klen);
79cb57f6 524 keysv = sv_2mortal(newSVpvn(key,klen));
2fd1c6b8 525 (void)strupr(SvPVX(keysv));
526 hash = 0;
527 }
902173a3 528#endif
2fd1c6b8 529 }
fde52b5c 530 }
531 xhv = (XPVHV*)SvANY(hv);
532 if (!xhv->xhv_array)
533 return Nullsv;
534
535 key = SvPV(keysv, klen);
536
537 if (!hash)
538 PERL_HASH(hash, key, klen);
539
540 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
541 entry = *oentry;
542 i = 1;
543 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
544 if (HeHASH(entry) != hash) /* strings can't be equal */
545 continue;
546 if (HeKLEN(entry) != klen)
547 continue;
36477c24 548 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 549 continue;
550 *oentry = HeNEXT(entry);
551 if (i && !*oentry)
552 xhv->xhv_fill--;
553 if (flags & G_DISCARD)
554 sv = Nullsv;
555 else
556 sv = sv_mortalcopy(HeVAL(entry));
557 if (entry == xhv->xhv_eiter)
72940dca 558 HvLAZYDEL_on(hv);
fde52b5c 559 else
68dc0745 560 hv_free_ent(hv, entry);
463ee0b2 561 --xhv->xhv_keys;
79072805 562 return sv;
563 }
79072805 564 return Nullsv;
79072805 565}
566
a0d0e21e 567bool
864dbfa3 568Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
a0d0e21e 569{
570 register XPVHV* xhv;
fde52b5c 571 register U32 hash;
a0d0e21e 572 register HE *entry;
573 SV *sv;
574
575 if (!hv)
576 return 0;
577
578 if (SvRMAGICAL(hv)) {
579 if (mg_find((SV*)hv,'P')) {
11343788 580 dTHR;
a0d0e21e 581 sv = sv_newmortal();
582 mg_copy((SV*)hv, sv, key, klen);
583 magic_existspack(sv, mg_find(sv, 'p'));
584 return SvTRUE(sv);
585 }
902173a3 586#ifdef ENV_IS_CASELESS
587 else if (mg_find((SV*)hv,'E')) {
79cb57f6 588 sv = sv_2mortal(newSVpvn(key,klen));
902173a3 589 key = strupr(SvPVX(sv));
590 }
591#endif
a0d0e21e 592 }
593
594 xhv = (XPVHV*)SvANY(hv);
f675dbe5 595#ifndef DYNAMIC_ENV_FETCH
a0d0e21e 596 if (!xhv->xhv_array)
597 return 0;
f675dbe5 598#endif
a0d0e21e 599
fde52b5c 600 PERL_HASH(hash, key, klen);
a0d0e21e 601
f675dbe5 602#ifdef DYNAMIC_ENV_FETCH
603 if (!xhv->xhv_array) entry = Null(HE*);
604 else
605#endif
a0d0e21e 606 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
fde52b5c 607 for (; entry; entry = HeNEXT(entry)) {
608 if (HeHASH(entry) != hash) /* strings can't be equal */
a0d0e21e 609 continue;
fde52b5c 610 if (HeKLEN(entry) != klen)
a0d0e21e 611 continue;
36477c24 612 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
fde52b5c 613 continue;
614 return TRUE;
615 }
f675dbe5 616#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
a6c40364 617 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
618 unsigned long len;
619 char *env = PerlEnv_ENVgetenv_len(key,&len);
620 if (env) {
621 sv = newSVpvn(env,len);
622 SvTAINTED_on(sv);
623 (void)hv_store(hv,key,klen,sv,hash);
624 return TRUE;
625 }
f675dbe5 626 }
627#endif
fde52b5c 628 return FALSE;
629}
630
631
632bool
864dbfa3 633Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
fde52b5c 634{
635 register XPVHV* xhv;
636 register char *key;
637 STRLEN klen;
638 register HE *entry;
639 SV *sv;
640
641 if (!hv)
642 return 0;
643
644 if (SvRMAGICAL(hv)) {
645 if (mg_find((SV*)hv,'P')) {
e858de61 646 dTHR; /* just for SvTRUE */
fde52b5c 647 sv = sv_newmortal();
effa1e2d 648 keysv = sv_2mortal(newSVsv(keysv));
fde52b5c 649 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
650 magic_existspack(sv, mg_find(sv, 'p'));
651 return SvTRUE(sv);
652 }
902173a3 653#ifdef ENV_IS_CASELESS
654 else if (mg_find((SV*)hv,'E')) {
655 key = SvPV(keysv, klen);
79cb57f6 656 keysv = sv_2mortal(newSVpvn(key,klen));
902173a3 657 (void)strupr(SvPVX(keysv));
658 hash = 0;
659 }
660#endif
fde52b5c 661 }
662
663 xhv = (XPVHV*)SvANY(hv);
f675dbe5 664#ifndef DYNAMIC_ENV_FETCH
fde52b5c 665 if (!xhv->xhv_array)
666 return 0;
f675dbe5 667#endif
fde52b5c 668
669 key = SvPV(keysv, klen);
670 if (!hash)
671 PERL_HASH(hash, key, klen);
672
f675dbe5 673#ifdef DYNAMIC_ENV_FETCH
674 if (!xhv->xhv_array) entry = Null(HE*);
675 else
676#endif
fde52b5c 677 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
678 for (; entry; entry = HeNEXT(entry)) {
679 if (HeHASH(entry) != hash) /* strings can't be equal */
680 continue;
681 if (HeKLEN(entry) != klen)
682 continue;
36477c24 683 if (memNE(HeKEY(entry),key,klen)) /* is this it? */
a0d0e21e 684 continue;
685 return TRUE;
686 }
f675dbe5 687#ifdef DYNAMIC_ENV_FETCH /* is it out there? */
a6c40364 688 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
689 unsigned long len;
690 char *env = PerlEnv_ENVgetenv_len(key,&len);
691 if (env) {
692 sv = newSVpvn(env,len);
693 SvTAINTED_on(sv);
694 (void)hv_store_ent(hv,keysv,sv,hash);
695 return TRUE;
696 }
f675dbe5 697 }
698#endif
a0d0e21e 699 return FALSE;
700}
701
76e3520e 702STATIC void
cea2e8a9 703S_hsplit(pTHX_ HV *hv)
79072805 704{
705 register XPVHV* xhv = (XPVHV*)SvANY(hv);
a0d0e21e 706 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
79072805 707 register I32 newsize = oldsize * 2;
708 register I32 i;
72311751 709 register char *a = xhv->xhv_array;
710 register HE **aep;
711 register HE **bep;
79072805 712 register HE *entry;
713 register HE **oentry;
714
3280af22 715 PL_nomemok = TRUE;
8d6dde3e 716#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
dcb4812c 717 Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 718 if (!a) {
4a33f861 719 PL_nomemok = FALSE;
422a93e5 720 return;
721 }
4633a7c4 722#else
4633a7c4 723#define MALLOC_OVERHEAD 16
dcb4812c 724 New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 725 if (!a) {
3280af22 726 PL_nomemok = FALSE;
422a93e5 727 return;
728 }
72311751 729 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
fba3b22e 730 if (oldsize >= 64) {
dcb4812c 731 offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
4633a7c4 732 }
733 else
734 Safefree(xhv->xhv_array);
735#endif
736
3280af22 737 PL_nomemok = FALSE;
72311751 738 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
79072805 739 xhv->xhv_max = --newsize;
72311751 740 xhv->xhv_array = a;
741 aep = (HE**)a;
79072805 742
72311751 743 for (i=0; i<oldsize; i++,aep++) {
744 if (!*aep) /* non-existent */
79072805 745 continue;
72311751 746 bep = aep+oldsize;
747 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
fde52b5c 748 if ((HeHASH(entry) & newsize) != i) {
749 *oentry = HeNEXT(entry);
72311751 750 HeNEXT(entry) = *bep;
751 if (!*bep)
79072805 752 xhv->xhv_fill++;
72311751 753 *bep = entry;
79072805 754 continue;
755 }
756 else
fde52b5c 757 oentry = &HeNEXT(entry);
79072805 758 }
72311751 759 if (!*aep) /* everything moved */
79072805 760 xhv->xhv_fill--;
761 }
762}
763
72940dca 764void
864dbfa3 765Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
72940dca 766{
767 register XPVHV* xhv = (XPVHV*)SvANY(hv);
768 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
769 register I32 newsize;
770 register I32 i;
771 register I32 j;
72311751 772 register char *a;
773 register HE **aep;
72940dca 774 register HE *entry;
775 register HE **oentry;
776
777 newsize = (I32) newmax; /* possible truncation here */
778 if (newsize != newmax || newmax <= oldsize)
779 return;
780 while ((newsize & (1 + ~newsize)) != newsize) {
781 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
782 }
783 if (newsize < newmax)
784 newsize *= 2;
785 if (newsize < newmax)
786 return; /* overflow detection */
787
72311751 788 a = xhv->xhv_array;
72940dca 789 if (a) {
3280af22 790 PL_nomemok = TRUE;
8d6dde3e 791#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
dcb4812c 792 Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 793 if (!a) {
4a33f861 794 PL_nomemok = FALSE;
422a93e5 795 return;
796 }
72940dca 797#else
dcb4812c 798 New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
422a93e5 799 if (!a) {
3280af22 800 PL_nomemok = FALSE;
422a93e5 801 return;
802 }
72311751 803 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
fba3b22e 804 if (oldsize >= 64) {
dcb4812c 805 offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
72940dca 806 }
807 else
808 Safefree(xhv->xhv_array);
809#endif
3280af22 810 PL_nomemok = FALSE;
72311751 811 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
72940dca 812 }
813 else {
dcb4812c 814 Newz(0, a, ARRAY_ALLOC_BYTES(newsize), char);
72940dca 815 }
816 xhv->xhv_max = --newsize;
72311751 817 xhv->xhv_array = a;
72940dca 818 if (!xhv->xhv_fill) /* skip rest if no entries */
819 return;
820
72311751 821 aep = (HE**)a;
822 for (i=0; i<oldsize; i++,aep++) {
823 if (!*aep) /* non-existent */
72940dca 824 continue;
72311751 825 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
72940dca 826 if ((j = (HeHASH(entry) & newsize)) != i) {
827 j -= i;
828 *oentry = HeNEXT(entry);
72311751 829 if (!(HeNEXT(entry) = aep[j]))
72940dca 830 xhv->xhv_fill++;
72311751 831 aep[j] = entry;
72940dca 832 continue;
833 }
834 else
835 oentry = &HeNEXT(entry);
836 }
72311751 837 if (!*aep) /* everything moved */
72940dca 838 xhv->xhv_fill--;
839 }
840}
841
79072805 842HV *
864dbfa3 843Perl_newHV(pTHX)
79072805 844{
845 register HV *hv;
846 register XPVHV* xhv;
847
a0d0e21e 848 hv = (HV*)NEWSV(502,0);
849 sv_upgrade((SV *)hv, SVt_PVHV);
79072805 850 xhv = (XPVHV*)SvANY(hv);
851 SvPOK_off(hv);
852 SvNOK_off(hv);
fde52b5c 853#ifndef NODEFAULT_SHAREKEYS
854 HvSHAREKEYS_on(hv); /* key-sharing on by default */
855#endif
463ee0b2 856 xhv->xhv_max = 7; /* start with 8 buckets */
79072805 857 xhv->xhv_fill = 0;
858 xhv->xhv_pmroot = 0;
79072805 859 (void)hv_iterinit(hv); /* so each() will start off right */
860 return hv;
861}
862
b3ac6de7 863HV *
864dbfa3 864Perl_newHVhv(pTHX_ HV *ohv)
b3ac6de7 865{
866 register HV *hv;
b3ac6de7 867 STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
868 STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
869
870 hv = newHV();
871 while (hv_max && hv_max + 1 >= hv_fill * 2)
872 hv_max = hv_max / 2; /* Is always 2^n-1 */
4a76a316 873 HvMAX(hv) = hv_max;
b3ac6de7 874 if (!hv_fill)
875 return hv;
876
877#if 0
33c27489 878 if (! SvTIED_mg((SV*)ohv, 'P')) {
b3ac6de7 879 /* Quick way ???*/
880 }
881 else
882#endif
883 {
884 HE *entry;
885 I32 hv_riter = HvRITER(ohv); /* current root of iterator */
886 HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
887
888 /* Slow way */
4a76a316 889 hv_iterinit(ohv);
b3ac6de7 890 while (entry = hv_iternext(ohv)) {
891 hv_store(hv, HeKEY(entry), HeKLEN(entry),
892 SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
893 }
894 HvRITER(ohv) = hv_riter;
895 HvEITER(ohv) = hv_eiter;
896 }
897
898 return hv;
899}
900
79072805 901void
864dbfa3 902Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
79072805 903{
16bdeea2 904 SV *val;
905
68dc0745 906 if (!entry)
79072805 907 return;
16bdeea2 908 val = HeVAL(entry);
257c9e5b 909 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
3280af22 910 PL_sub_generation++; /* may be deletion of method from stash */
16bdeea2 911 SvREFCNT_dec(val);
68dc0745 912 if (HeKLEN(entry) == HEf_SVKEY) {
913 SvREFCNT_dec(HeKEY_sv(entry));
914 Safefree(HeKEY_hek(entry));
44a8e56a 915 }
916 else if (HvSHAREKEYS(hv))
68dc0745 917 unshare_hek(HeKEY_hek(entry));
fde52b5c 918 else
68dc0745 919 Safefree(HeKEY_hek(entry));
920 del_he(entry);
79072805 921}
922
923void
864dbfa3 924Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
79072805 925{
68dc0745 926 if (!entry)
79072805 927 return;
68dc0745 928 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
3280af22 929 PL_sub_generation++; /* may be deletion of method from stash */
68dc0745 930 sv_2mortal(HeVAL(entry)); /* free between statements */
931 if (HeKLEN(entry) == HEf_SVKEY) {
932 sv_2mortal(HeKEY_sv(entry));
933 Safefree(HeKEY_hek(entry));
44a8e56a 934 }
935 else if (HvSHAREKEYS(hv))
68dc0745 936 unshare_hek(HeKEY_hek(entry));
fde52b5c 937 else
68dc0745 938 Safefree(HeKEY_hek(entry));
939 del_he(entry);
79072805 940}
941
942void
864dbfa3 943Perl_hv_clear(pTHX_ HV *hv)
79072805 944{
945 register XPVHV* xhv;
946 if (!hv)
947 return;
948 xhv = (XPVHV*)SvANY(hv);
463ee0b2 949 hfreeentries(hv);
79072805 950 xhv->xhv_fill = 0;
a0d0e21e 951 xhv->xhv_keys = 0;
79072805 952 if (xhv->xhv_array)
463ee0b2 953 (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
a0d0e21e 954
955 if (SvRMAGICAL(hv))
956 mg_clear((SV*)hv);
79072805 957}
958
76e3520e 959STATIC void
cea2e8a9 960S_hfreeentries(pTHX_ HV *hv)
79072805 961{
a0d0e21e 962 register HE **array;
68dc0745 963 register HE *entry;
964 register HE *oentry = Null(HE*);
a0d0e21e 965 I32 riter;
966 I32 max;
79072805 967
968 if (!hv)
969 return;
a0d0e21e 970 if (!HvARRAY(hv))
79072805 971 return;
a0d0e21e 972
973 riter = 0;
974 max = HvMAX(hv);
975 array = HvARRAY(hv);
68dc0745 976 entry = array[0];
a0d0e21e 977 for (;;) {
68dc0745 978 if (entry) {
979 oentry = entry;
980 entry = HeNEXT(entry);
981 hv_free_ent(hv, oentry);
a0d0e21e 982 }
68dc0745 983 if (!entry) {
a0d0e21e 984 if (++riter > max)
985 break;
68dc0745 986 entry = array[riter];
a0d0e21e 987 }
79072805 988 }
a0d0e21e 989 (void)hv_iterinit(hv);
79072805 990}
991
992void
864dbfa3 993Perl_hv_undef(pTHX_ HV *hv)
79072805 994{
995 register XPVHV* xhv;
996 if (!hv)
997 return;
998 xhv = (XPVHV*)SvANY(hv);
463ee0b2 999 hfreeentries(hv);
79072805 1000 Safefree(xhv->xhv_array);
85e6fe83 1001 if (HvNAME(hv)) {
1002 Safefree(HvNAME(hv));
1003 HvNAME(hv) = 0;
1004 }
79072805 1005 xhv->xhv_array = 0;
aa689395 1006 xhv->xhv_max = 7; /* it's a normal hash */
79072805 1007 xhv->xhv_fill = 0;
a0d0e21e 1008 xhv->xhv_keys = 0;
1009
1010 if (SvRMAGICAL(hv))
1011 mg_clear((SV*)hv);
79072805 1012}
1013
79072805 1014I32
864dbfa3 1015Perl_hv_iterinit(pTHX_ HV *hv)
79072805 1016{
aa689395 1017 register XPVHV* xhv;
1018 HE *entry;
1019
1020 if (!hv)
cea2e8a9 1021 Perl_croak(aTHX_ "Bad hash");
aa689395 1022 xhv = (XPVHV*)SvANY(hv);
1023 entry = xhv->xhv_eiter;
72940dca 1024 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1025 HvLAZYDEL_off(hv);
68dc0745 1026 hv_free_ent(hv, entry);
72940dca 1027 }
79072805 1028 xhv->xhv_riter = -1;
1029 xhv->xhv_eiter = Null(HE*);
c6601927 1030 return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
79072805 1031}
1032
1033HE *
864dbfa3 1034Perl_hv_iternext(pTHX_ HV *hv)
79072805 1035{
1036 register XPVHV* xhv;
1037 register HE *entry;
a0d0e21e 1038 HE *oldentry;
463ee0b2 1039 MAGIC* mg;
79072805 1040
1041 if (!hv)
cea2e8a9 1042 Perl_croak(aTHX_ "Bad hash");
79072805 1043 xhv = (XPVHV*)SvANY(hv);
a0d0e21e 1044 oldentry = entry = xhv->xhv_eiter;
463ee0b2 1045
33c27489 1046 if (mg = SvTIED_mg((SV*)hv, 'P')) {
8990e307 1047 SV *key = sv_newmortal();
cd1469e6 1048 if (entry) {
fde52b5c 1049 sv_setsv(key, HeSVKEY_force(entry));
cd1469e6 1050 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1051 }
a0d0e21e 1052 else {
ff68c719 1053 char *k;
bbce6d69 1054 HEK *hek;
ff68c719 1055
1056 xhv->xhv_eiter = entry = new_he(); /* one HE per MAGICAL hash */
4633a7c4 1057 Zero(entry, 1, HE);
ff68c719 1058 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1059 hek = (HEK*)k;
1060 HeKEY_hek(entry) = hek;
fde52b5c 1061 HeKLEN(entry) = HEf_SVKEY;
a0d0e21e 1062 }
1063 magic_nextpack((SV*) hv,mg,key);
463ee0b2 1064 if (SvOK(key)) {
cd1469e6 1065 /* force key to stay around until next time */
bbce6d69 1066 HeSVKEY_set(entry, SvREFCNT_inc(key));
1067 return entry; /* beware, hent_val is not set */
463ee0b2 1068 }
fde52b5c 1069 if (HeVAL(entry))
1070 SvREFCNT_dec(HeVAL(entry));
ff68c719 1071 Safefree(HeKEY_hek(entry));
4633a7c4 1072 del_he(entry);
463ee0b2 1073 xhv->xhv_eiter = Null(HE*);
1074 return Null(HE*);
79072805 1075 }
f675dbe5 1076#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1077 if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1078 prime_env_iter();
1079#endif
463ee0b2 1080
79072805 1081 if (!xhv->xhv_array)
dcb4812c 1082 Newz(506,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
fde52b5c 1083 if (entry)
1084 entry = HeNEXT(entry);
1085 while (!entry) {
1086 ++xhv->xhv_riter;
1087 if (xhv->xhv_riter > xhv->xhv_max) {
1088 xhv->xhv_riter = -1;
1089 break;
79072805 1090 }
fde52b5c 1091 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1092 }
79072805 1093
72940dca 1094 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1095 HvLAZYDEL_off(hv);
68dc0745 1096 hv_free_ent(hv, oldentry);
72940dca 1097 }
a0d0e21e 1098
79072805 1099 xhv->xhv_eiter = entry;
1100 return entry;
1101}
1102
1103char *
864dbfa3 1104Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
79072805 1105{
fde52b5c 1106 if (HeKLEN(entry) == HEf_SVKEY) {
fb73857a 1107 STRLEN len;
1108 char *p = SvPV(HeKEY_sv(entry), len);
1109 *retlen = len;
1110 return p;
fde52b5c 1111 }
1112 else {
1113 *retlen = HeKLEN(entry);
1114 return HeKEY(entry);
1115 }
1116}
1117
1118/* unlike hv_iterval(), this always returns a mortal copy of the key */
1119SV *
864dbfa3 1120Perl_hv_iterkeysv(pTHX_ register HE *entry)
fde52b5c 1121{
1122 if (HeKLEN(entry) == HEf_SVKEY)
bbce6d69 1123 return sv_mortalcopy(HeKEY_sv(entry));
fde52b5c 1124 else
79cb57f6 1125 return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""),
fde52b5c 1126 HeKLEN(entry)));
79072805 1127}
1128
1129SV *
864dbfa3 1130Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
79072805 1131{
8990e307 1132 if (SvRMAGICAL(hv)) {
463ee0b2 1133 if (mg_find((SV*)hv,'P')) {
8990e307 1134 SV* sv = sv_newmortal();
bbce6d69 1135 if (HeKLEN(entry) == HEf_SVKEY)
1136 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1137 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
463ee0b2 1138 return sv;
1139 }
79072805 1140 }
fde52b5c 1141 return HeVAL(entry);
79072805 1142}
1143
a0d0e21e 1144SV *
864dbfa3 1145Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
a0d0e21e 1146{
1147 HE *he;
1148 if ( (he = hv_iternext(hv)) == NULL)
1149 return NULL;
1150 *key = hv_iterkey(he, retlen);
1151 return hv_iterval(hv, he);
1152}
1153
79072805 1154void
864dbfa3 1155Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
79072805 1156{
a0d0e21e 1157 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
79072805 1158}
fde52b5c 1159
bbce6d69 1160char*
864dbfa3 1161Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
bbce6d69 1162{
ff68c719 1163 return HEK_KEY(share_hek(sv, len, hash));
bbce6d69 1164}
1165
1166/* possibly free a shared string if no one has access to it
fde52b5c 1167 * len and hash must both be valid for str.
1168 */
bbce6d69 1169void
864dbfa3 1170Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
fde52b5c 1171{
1172 register XPVHV* xhv;
1173 register HE *entry;
1174 register HE **oentry;
1175 register I32 i = 1;
1176 I32 found = 0;
bbce6d69 1177
fde52b5c 1178 /* what follows is the moral equivalent of:
6b88bc9c 1179 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
bbce6d69 1180 if (--*Svp == Nullsv)
6b88bc9c 1181 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
bbce6d69 1182 } */
3280af22 1183 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 1184 /* assert(xhv_array != 0) */
5f08fbcd 1185 LOCK_STRTAB_MUTEX;
fde52b5c 1186 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
bbce6d69 1187 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
fde52b5c 1188 if (HeHASH(entry) != hash) /* strings can't be equal */
1189 continue;
1190 if (HeKLEN(entry) != len)
1191 continue;
36477c24 1192 if (memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 1193 continue;
1194 found = 1;
bbce6d69 1195 if (--HeVAL(entry) == Nullsv) {
1196 *oentry = HeNEXT(entry);
1197 if (i && !*oentry)
1198 xhv->xhv_fill--;
ff68c719 1199 Safefree(HeKEY_hek(entry));
bbce6d69 1200 del_he(entry);
1201 --xhv->xhv_keys;
fde52b5c 1202 }
bbce6d69 1203 break;
fde52b5c 1204 }
333f433b 1205 UNLOCK_STRTAB_MUTEX;
bbce6d69 1206
0453d815 1207 {
1208 dTHR;
1209 if (!found && ckWARN_d(WARN_INTERNAL))
1210 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string");
1211 }
fde52b5c 1212}
1213
bbce6d69 1214/* get a (constant) string ptr from the global string table
1215 * string will get added if it is not already there.
fde52b5c 1216 * len and hash must both be valid for str.
1217 */
bbce6d69 1218HEK *
864dbfa3 1219Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
fde52b5c 1220{
1221 register XPVHV* xhv;
1222 register HE *entry;
1223 register HE **oentry;
1224 register I32 i = 1;
1225 I32 found = 0;
bbce6d69 1226
fde52b5c 1227 /* what follows is the moral equivalent of:
bbce6d69 1228
6b88bc9c 1229 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1230 hv_store(PL_strtab, str, len, Nullsv, hash);
bbce6d69 1231 */
3280af22 1232 xhv = (XPVHV*)SvANY(PL_strtab);
fde52b5c 1233 /* assert(xhv_array != 0) */
5f08fbcd 1234 LOCK_STRTAB_MUTEX;
fde52b5c 1235 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
bbce6d69 1236 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
fde52b5c 1237 if (HeHASH(entry) != hash) /* strings can't be equal */
1238 continue;
1239 if (HeKLEN(entry) != len)
1240 continue;
36477c24 1241 if (memNE(HeKEY(entry),str,len)) /* is this it? */
fde52b5c 1242 continue;
1243 found = 1;
fde52b5c 1244 break;
1245 }
bbce6d69 1246 if (!found) {
1247 entry = new_he();
ff68c719 1248 HeKEY_hek(entry) = save_hek(str, len, hash);
bbce6d69 1249 HeVAL(entry) = Nullsv;
1250 HeNEXT(entry) = *oentry;
1251 *oentry = entry;
1252 xhv->xhv_keys++;
1253 if (i) { /* initial entry? */
1254 ++xhv->xhv_fill;
1255 if (xhv->xhv_keys > xhv->xhv_max)
3280af22 1256 hsplit(PL_strtab);
bbce6d69 1257 }
1258 }
1259
1260 ++HeVAL(entry); /* use value slot as REFCNT */
5f08fbcd 1261 UNLOCK_STRTAB_MUTEX;
ff68c719 1262 return HeKEY_hek(entry);
fde52b5c 1263}
1264
bbce6d69 1265
61c8b479 1266