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