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