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