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