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