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