3 * Copyright (c) 1991-2000, Larry Wall
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.
11 * "I sit beside the fire and think of all that I have seen." --Bilbo
27 PL_he_root = HeNEXT(he);
36 HeNEXT(p) = (HE*)PL_he_root;
47 New(54, ptr, 1008/sizeof(XPV), XPV);
48 ptr->xpv_pv = (char*)PL_he_arenaroot;
49 PL_he_arenaroot = ptr;
52 heend = &he[1008 / sizeof(HE) - 1];
55 HeNEXT(he) = (HE*)(he + 1);
63 #define new_HE() (HE*)safemalloc(sizeof(HE))
64 #define del_HE(p) safefree((char*)p)
68 #define new_HE() new_he()
69 #define del_HE(p) del_he(p)
74 S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
85 New(54, k, HEK_BASESIZE + len + 1, char);
87 Copy(str, HEK_KEY(hek), len, char);
90 HEK_UTF8(hek) = (char)is_utf8;
95 Perl_unshare_hek(pTHX_ HEK *hek)
97 unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
100 #if defined(USE_ITHREADS)
102 Perl_he_dup(pTHX_ HE *e, bool shared)
108 /* look for it in the table first */
109 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
113 /* create anew and remember what it is */
115 ptr_table_store(PL_ptr_table, e, ret);
117 HeNEXT(ret) = he_dup(HeNEXT(e),shared);
118 if (HeKLEN(e) == HEf_SVKEY)
119 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
121 HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
123 HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
124 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
127 #endif /* USE_ITHREADS */
129 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
135 Returns the SV which corresponds to the specified key in the hash. The
136 C<klen> is the length of the key. If C<lval> is set then the fetch will be
137 part of a store. Check that the return value is non-null before
138 dereferencing it to a C<SV*>.
140 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
141 information on how to use this function on tied hashes.
147 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
153 bool is_utf8 = FALSE;
163 if (SvRMAGICAL(hv)) {
164 if (mg_find((SV*)hv,'P')) {
166 mg_copy((SV*)hv, sv, key, klen);
168 return &PL_hv_fetch_sv;
170 #ifdef ENV_IS_CASELESS
171 else if (mg_find((SV*)hv,'E')) {
173 for (i = 0; i < klen; ++i)
174 if (isLOWER(key[i])) {
175 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
176 SV **ret = hv_fetch(hv, nkey, klen, 0);
178 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
185 xhv = (XPVHV*)SvANY(hv);
186 if (!xhv->xhv_array) {
188 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
189 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
192 Newz(503, xhv->xhv_array,
193 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
198 PERL_HASH(hash, key, klen);
200 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
201 for (; entry; entry = HeNEXT(entry)) {
202 if (HeHASH(entry) != hash) /* strings can't be equal */
204 if (HeKLEN(entry) != klen)
206 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
208 if (HeKUTF8(entry) != (char)is_utf8)
210 return &HeVAL(entry);
212 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
213 if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
215 char *env = PerlEnv_ENVgetenv_len(key,&len);
217 sv = newSVpvn(env,len);
219 return hv_store(hv,key,klen,sv,hash);
223 if (lval) { /* gonna assign to this, so it better be there */
225 return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
230 /* returns a HE * structure with the all fields set */
231 /* note that hent_val will be a mortal sv for MAGICAL hashes */
233 =for apidoc hv_fetch_ent
235 Returns the hash entry which corresponds to the specified key in the hash.
236 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
237 if you want the function to compute it. IF C<lval> is set then the fetch
238 will be part of a store. Make sure the return value is non-null before
239 accessing it. The return value when C<tb> is a tied hash is a pointer to a
240 static location, so be sure to make a copy of the structure if you need to
243 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
244 information on how to use this function on tied hashes.
250 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
262 if (SvRMAGICAL(hv)) {
263 if (mg_find((SV*)hv,'P')) {
265 keysv = sv_2mortal(newSVsv(keysv));
266 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
267 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
269 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
270 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
272 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
273 HeVAL(&PL_hv_fetch_ent_mh) = sv;
274 return &PL_hv_fetch_ent_mh;
276 #ifdef ENV_IS_CASELESS
277 else if (mg_find((SV*)hv,'E')) {
279 key = SvPV(keysv, klen);
280 for (i = 0; i < klen; ++i)
281 if (isLOWER(key[i])) {
282 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
283 (void)strupr(SvPVX(nkeysv));
284 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
286 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
293 xhv = (XPVHV*)SvANY(hv);
294 if (!xhv->xhv_array) {
296 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
297 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
300 Newz(503, xhv->xhv_array,
301 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
306 key = SvPV(keysv, klen);
307 is_utf8 = (SvUTF8(keysv)!=0);
310 PERL_HASH(hash, key, klen);
312 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
313 for (; entry; entry = HeNEXT(entry)) {
314 if (HeHASH(entry) != hash) /* strings can't be equal */
316 if (HeKLEN(entry) != klen)
318 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
320 if (HeKUTF8(entry) != (char)is_utf8)
324 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
325 if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
327 char *env = PerlEnv_ENVgetenv_len(key,&len);
329 sv = newSVpvn(env,len);
331 return hv_store_ent(hv,keysv,sv,hash);
335 if (lval) { /* gonna assign to this, so it better be there */
337 return hv_store_ent(hv,keysv,sv,hash);
343 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
345 MAGIC *mg = SvMAGIC(hv);
349 if (isUPPER(mg->mg_type)) {
351 switch (mg->mg_type) {
354 *needs_store = FALSE;
357 mg = mg->mg_moremagic;
364 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
365 the length of the key. The C<hash> parameter is the precomputed hash
366 value; if it is zero then Perl will compute it. The return value will be
367 NULL if the operation failed or if the value did not need to be actually
368 stored within the hash (as in the case of tied hashes). Otherwise it can
369 be dereferenced to get the original C<SV*>. Note that the caller is
370 responsible for suitably incrementing the reference count of C<val> before
371 the call, and decrementing it if the function returned NULL.
373 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
374 information on how to use this function on tied hashes.
380 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
385 register HE **oentry;
386 bool is_utf8 = FALSE;
396 xhv = (XPVHV*)SvANY(hv);
400 hv_magic_check (hv, &needs_copy, &needs_store);
402 mg_copy((SV*)hv, val, key, klen);
403 if (!xhv->xhv_array && !needs_store)
405 #ifdef ENV_IS_CASELESS
406 else if (mg_find((SV*)hv,'E')) {
407 SV *sv = sv_2mortal(newSVpvn(key,klen));
408 key = strupr(SvPVX(sv));
415 PERL_HASH(hash, key, klen);
418 Newz(505, xhv->xhv_array,
419 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
421 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
424 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
425 if (HeHASH(entry) != hash) /* strings can't be equal */
427 if (HeKLEN(entry) != klen)
429 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
431 if (HeKUTF8(entry) != (char)is_utf8)
433 SvREFCNT_dec(HeVAL(entry));
435 return &HeVAL(entry);
440 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
441 else /* gotta do the real thing */
442 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
444 HeNEXT(entry) = *oentry;
448 if (i) { /* initial entry? */
450 if (xhv->xhv_keys > xhv->xhv_max)
454 return &HeVAL(entry);
458 =for apidoc hv_store_ent
460 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
461 parameter is the precomputed hash value; if it is zero then Perl will
462 compute it. The return value is the new hash entry so created. It will be
463 NULL if the operation failed or if the value did not need to be actually
464 stored within the hash (as in the case of tied hashes). Otherwise the
465 contents of the return value can be accessed using the C<He???> macros
466 described here. Note that the caller is responsible for suitably
467 incrementing the reference count of C<val> before the call, and
468 decrementing it if the function returned NULL.
470 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
471 information on how to use this function on tied hashes.
477 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
484 register HE **oentry;
490 xhv = (XPVHV*)SvANY(hv);
494 hv_magic_check (hv, &needs_copy, &needs_store);
496 bool save_taint = PL_tainted;
498 PL_tainted = SvTAINTED(keysv);
499 keysv = sv_2mortal(newSVsv(keysv));
500 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
501 TAINT_IF(save_taint);
502 if (!xhv->xhv_array && !needs_store)
504 #ifdef ENV_IS_CASELESS
505 else if (mg_find((SV*)hv,'E')) {
506 key = SvPV(keysv, klen);
507 keysv = sv_2mortal(newSVpvn(key,klen));
508 (void)strupr(SvPVX(keysv));
515 key = SvPV(keysv, klen);
516 is_utf8 = (SvUTF8(keysv) != 0);
519 PERL_HASH(hash, key, klen);
522 Newz(505, xhv->xhv_array,
523 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
525 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
528 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
529 if (HeHASH(entry) != hash) /* strings can't be equal */
531 if (HeKLEN(entry) != klen)
533 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
535 if (HeKUTF8(entry) != (char)is_utf8)
537 SvREFCNT_dec(HeVAL(entry));
544 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
545 else /* gotta do the real thing */
546 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
548 HeNEXT(entry) = *oentry;
552 if (i) { /* initial entry? */
554 if (xhv->xhv_keys > xhv->xhv_max)
562 =for apidoc hv_delete
564 Deletes a key/value pair in the hash. The value SV is removed from the
565 hash and returned to the caller. The C<klen> is the length of the key.
566 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
573 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
579 register HE **oentry;
582 bool is_utf8 = FALSE;
590 if (SvRMAGICAL(hv)) {
593 hv_magic_check (hv, &needs_copy, &needs_store);
595 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
599 if (mg_find(sv, 'p')) {
600 sv_unmagic(sv, 'p'); /* No longer an element */
603 return Nullsv; /* element cannot be deleted */
605 #ifdef ENV_IS_CASELESS
606 else if (mg_find((SV*)hv,'E')) {
607 sv = sv_2mortal(newSVpvn(key,klen));
608 key = strupr(SvPVX(sv));
613 xhv = (XPVHV*)SvANY(hv);
617 PERL_HASH(hash, key, klen);
619 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
622 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
623 if (HeHASH(entry) != hash) /* strings can't be equal */
625 if (HeKLEN(entry) != klen)
627 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
629 if (HeKUTF8(entry) != (char)is_utf8)
631 *oentry = HeNEXT(entry);
634 if (flags & G_DISCARD)
637 sv = sv_2mortal(HeVAL(entry));
638 HeVAL(entry) = &PL_sv_undef;
640 if (entry == xhv->xhv_eiter)
643 hv_free_ent(hv, entry);
651 =for apidoc hv_delete_ent
653 Deletes a key/value pair in the hash. The value SV is removed from the
654 hash and returned to the caller. The C<flags> value will normally be zero;
655 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
656 precomputed hash value, or 0 to ask for it to be computed.
662 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
669 register HE **oentry;
675 if (SvRMAGICAL(hv)) {
678 hv_magic_check (hv, &needs_copy, &needs_store);
680 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
684 if (mg_find(sv, 'p')) {
685 sv_unmagic(sv, 'p'); /* No longer an element */
688 return Nullsv; /* element cannot be deleted */
690 #ifdef ENV_IS_CASELESS
691 else if (mg_find((SV*)hv,'E')) {
692 key = SvPV(keysv, klen);
693 keysv = sv_2mortal(newSVpvn(key,klen));
694 (void)strupr(SvPVX(keysv));
700 xhv = (XPVHV*)SvANY(hv);
704 key = SvPV(keysv, klen);
705 is_utf8 = (SvUTF8(keysv) != 0);
708 PERL_HASH(hash, key, klen);
710 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
713 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
714 if (HeHASH(entry) != hash) /* strings can't be equal */
716 if (HeKLEN(entry) != klen)
718 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
720 if (HeKUTF8(entry) != (char)is_utf8)
722 *oentry = HeNEXT(entry);
725 if (flags & G_DISCARD)
728 sv = sv_2mortal(HeVAL(entry));
729 HeVAL(entry) = &PL_sv_undef;
731 if (entry == xhv->xhv_eiter)
734 hv_free_ent(hv, entry);
742 =for apidoc hv_exists
744 Returns a boolean indicating whether the specified hash key exists. The
745 C<klen> is the length of the key.
751 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
757 bool is_utf8 = FALSE;
767 if (SvRMAGICAL(hv)) {
768 if (mg_find((SV*)hv,'P')) {
770 mg_copy((SV*)hv, sv, key, klen);
771 magic_existspack(sv, mg_find(sv, 'p'));
774 #ifdef ENV_IS_CASELESS
775 else if (mg_find((SV*)hv,'E')) {
776 sv = sv_2mortal(newSVpvn(key,klen));
777 key = strupr(SvPVX(sv));
782 xhv = (XPVHV*)SvANY(hv);
783 #ifndef DYNAMIC_ENV_FETCH
788 PERL_HASH(hash, key, klen);
790 #ifdef DYNAMIC_ENV_FETCH
791 if (!xhv->xhv_array) entry = Null(HE*);
794 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
795 for (; entry; entry = HeNEXT(entry)) {
796 if (HeHASH(entry) != hash) /* strings can't be equal */
798 if (HeKLEN(entry) != klen)
800 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
802 if (HeKUTF8(entry) != (char)is_utf8)
806 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
807 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
809 char *env = PerlEnv_ENVgetenv_len(key,&len);
811 sv = newSVpvn(env,len);
813 (void)hv_store(hv,key,klen,sv,hash);
823 =for apidoc hv_exists_ent
825 Returns a boolean indicating whether the specified hash key exists. C<hash>
826 can be a valid precomputed hash value, or 0 to ask for it to be
833 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
844 if (SvRMAGICAL(hv)) {
845 if (mg_find((SV*)hv,'P')) {
847 keysv = sv_2mortal(newSVsv(keysv));
848 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
849 magic_existspack(sv, mg_find(sv, 'p'));
852 #ifdef ENV_IS_CASELESS
853 else if (mg_find((SV*)hv,'E')) {
854 key = SvPV(keysv, klen);
855 keysv = sv_2mortal(newSVpvn(key,klen));
856 (void)strupr(SvPVX(keysv));
862 xhv = (XPVHV*)SvANY(hv);
863 #ifndef DYNAMIC_ENV_FETCH
868 key = SvPV(keysv, klen);
870 PERL_HASH(hash, key, klen);
872 #ifdef DYNAMIC_ENV_FETCH
873 if (!xhv->xhv_array) entry = Null(HE*);
876 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
877 for (; entry; entry = HeNEXT(entry)) {
878 if (HeHASH(entry) != hash) /* strings can't be equal */
880 if (HeKLEN(entry) != klen)
882 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
886 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
887 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
889 char *env = PerlEnv_ENVgetenv_len(key,&len);
891 sv = newSVpvn(env,len);
893 (void)hv_store_ent(hv,keysv,sv,hash);
902 S_hsplit(pTHX_ HV *hv)
904 register XPVHV* xhv = (XPVHV*)SvANY(hv);
905 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
906 register I32 newsize = oldsize * 2;
908 register char *a = xhv->xhv_array;
912 register HE **oentry;
915 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
916 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
922 #define MALLOC_OVERHEAD 16
923 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
928 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
930 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
933 Safefree(xhv->xhv_array);
937 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
938 xhv->xhv_max = --newsize;
942 for (i=0; i<oldsize; i++,aep++) {
943 if (!*aep) /* non-existent */
946 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
947 if ((HeHASH(entry) & newsize) != i) {
948 *oentry = HeNEXT(entry);
949 HeNEXT(entry) = *bep;
956 oentry = &HeNEXT(entry);
958 if (!*aep) /* everything moved */
964 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
966 register XPVHV* xhv = (XPVHV*)SvANY(hv);
967 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
968 register I32 newsize;
974 register HE **oentry;
976 newsize = (I32) newmax; /* possible truncation here */
977 if (newsize != newmax || newmax <= oldsize)
979 while ((newsize & (1 + ~newsize)) != newsize) {
980 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
982 if (newsize < newmax)
984 if (newsize < newmax)
985 return; /* overflow detection */
990 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
991 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
997 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1002 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
1003 if (oldsize >= 64) {
1004 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1007 Safefree(xhv->xhv_array);
1010 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1013 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1015 xhv->xhv_max = --newsize;
1017 if (!xhv->xhv_fill) /* skip rest if no entries */
1021 for (i=0; i<oldsize; i++,aep++) {
1022 if (!*aep) /* non-existent */
1024 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1025 if ((j = (HeHASH(entry) & newsize)) != i) {
1027 *oentry = HeNEXT(entry);
1028 if (!(HeNEXT(entry) = aep[j]))
1034 oentry = &HeNEXT(entry);
1036 if (!*aep) /* everything moved */
1044 Creates a new HV. The reference count is set to 1.
1053 register XPVHV* xhv;
1055 hv = (HV*)NEWSV(502,0);
1056 sv_upgrade((SV *)hv, SVt_PVHV);
1057 xhv = (XPVHV*)SvANY(hv);
1060 #ifndef NODEFAULT_SHAREKEYS
1061 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1063 xhv->xhv_max = 7; /* start with 8 buckets */
1065 xhv->xhv_pmroot = 0;
1066 (void)hv_iterinit(hv); /* so each() will start off right */
1071 Perl_newHVhv(pTHX_ HV *ohv)
1074 STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1075 STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1078 while (hv_max && hv_max + 1 >= hv_fill * 2)
1079 hv_max = hv_max / 2; /* Is always 2^n-1 */
1085 if (! SvTIED_mg((SV*)ohv, 'P')) {
1092 I32 hv_riter = HvRITER(ohv); /* current root of iterator */
1093 HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
1097 while ((entry = hv_iternext(ohv))) {
1098 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1099 SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
1101 HvRITER(ohv) = hv_riter;
1102 HvEITER(ohv) = hv_eiter;
1109 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1116 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1117 PL_sub_generation++; /* may be deletion of method from stash */
1119 if (HeKLEN(entry) == HEf_SVKEY) {
1120 SvREFCNT_dec(HeKEY_sv(entry));
1121 Safefree(HeKEY_hek(entry));
1123 else if (HvSHAREKEYS(hv))
1124 unshare_hek(HeKEY_hek(entry));
1126 Safefree(HeKEY_hek(entry));
1131 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1135 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1136 PL_sub_generation++; /* may be deletion of method from stash */
1137 sv_2mortal(HeVAL(entry)); /* free between statements */
1138 if (HeKLEN(entry) == HEf_SVKEY) {
1139 sv_2mortal(HeKEY_sv(entry));
1140 Safefree(HeKEY_hek(entry));
1142 else if (HvSHAREKEYS(hv))
1143 unshare_hek(HeKEY_hek(entry));
1145 Safefree(HeKEY_hek(entry));
1150 =for apidoc hv_clear
1152 Clears a hash, making it empty.
1158 Perl_hv_clear(pTHX_ HV *hv)
1160 register XPVHV* xhv;
1163 xhv = (XPVHV*)SvANY(hv);
1168 (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
1175 S_hfreeentries(pTHX_ HV *hv)
1177 register HE **array;
1179 register HE *oentry = Null(HE*);
1190 array = HvARRAY(hv);
1195 entry = HeNEXT(entry);
1196 hv_free_ent(hv, oentry);
1201 entry = array[riter];
1204 (void)hv_iterinit(hv);
1208 =for apidoc hv_undef
1216 Perl_hv_undef(pTHX_ HV *hv)
1218 register XPVHV* xhv;
1221 xhv = (XPVHV*)SvANY(hv);
1223 Safefree(xhv->xhv_array);
1225 Safefree(HvNAME(hv));
1229 xhv->xhv_max = 7; /* it's a normal hash */
1238 =for apidoc hv_iterinit
1240 Prepares a starting point to traverse a hash table. Returns the number of
1241 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1242 currently only meaningful for hashes without tie magic.
1244 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1245 hash buckets that happen to be in use. If you still need that esoteric
1246 value, you can get it through the macro C<HvFILL(tb)>.
1252 Perl_hv_iterinit(pTHX_ HV *hv)
1254 register XPVHV* xhv;
1258 Perl_croak(aTHX_ "Bad hash");
1259 xhv = (XPVHV*)SvANY(hv);
1260 entry = xhv->xhv_eiter;
1261 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1263 hv_free_ent(hv, entry);
1265 xhv->xhv_riter = -1;
1266 xhv->xhv_eiter = Null(HE*);
1267 return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
1271 =for apidoc hv_iternext
1273 Returns entries from a hash iterator. See C<hv_iterinit>.
1279 Perl_hv_iternext(pTHX_ HV *hv)
1281 register XPVHV* xhv;
1287 Perl_croak(aTHX_ "Bad hash");
1288 xhv = (XPVHV*)SvANY(hv);
1289 oldentry = entry = xhv->xhv_eiter;
1291 if ((mg = SvTIED_mg((SV*)hv, 'P'))) {
1292 SV *key = sv_newmortal();
1294 sv_setsv(key, HeSVKEY_force(entry));
1295 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1301 xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
1303 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1305 HeKEY_hek(entry) = hek;
1306 HeKLEN(entry) = HEf_SVKEY;
1308 magic_nextpack((SV*) hv,mg,key);
1310 /* force key to stay around until next time */
1311 HeSVKEY_set(entry, SvREFCNT_inc(key));
1312 return entry; /* beware, hent_val is not set */
1315 SvREFCNT_dec(HeVAL(entry));
1316 Safefree(HeKEY_hek(entry));
1318 xhv->xhv_eiter = Null(HE*);
1321 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1322 if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1326 if (!xhv->xhv_array)
1327 Newz(506, xhv->xhv_array,
1328 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
1330 entry = HeNEXT(entry);
1333 if (xhv->xhv_riter > xhv->xhv_max) {
1334 xhv->xhv_riter = -1;
1337 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1340 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1342 hv_free_ent(hv, oldentry);
1345 xhv->xhv_eiter = entry;
1350 =for apidoc hv_iterkey
1352 Returns the key from the current position of the hash iterator. See
1359 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1361 if (HeKLEN(entry) == HEf_SVKEY) {
1363 char *p = SvPV(HeKEY_sv(entry), len);
1368 *retlen = HeKLEN(entry);
1369 return HeKEY(entry);
1373 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1375 =for apidoc hv_iterkeysv
1377 Returns the key as an C<SV*> from the current position of the hash
1378 iterator. The return value will always be a mortal copy of the key. Also
1385 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1387 if (HeKLEN(entry) == HEf_SVKEY)
1388 return sv_mortalcopy(HeKEY_sv(entry));
1390 SV *sv = newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1391 HeKLEN(entry), HeHASH(entry));
1394 return sv_2mortal(sv);
1399 =for apidoc hv_iterval
1401 Returns the value from the current position of the hash iterator. See
1408 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1410 if (SvRMAGICAL(hv)) {
1411 if (mg_find((SV*)hv,'P')) {
1412 SV* sv = sv_newmortal();
1413 if (HeKLEN(entry) == HEf_SVKEY)
1414 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1415 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1419 return HeVAL(entry);
1423 =for apidoc hv_iternextsv
1425 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1432 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1435 if ( (he = hv_iternext(hv)) == NULL)
1437 *key = hv_iterkey(he, retlen);
1438 return hv_iterval(hv, he);
1442 =for apidoc hv_magic
1444 Adds magic to a hash. See C<sv_magic>.
1450 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1452 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1456 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1458 return HEK_KEY(share_hek(sv, len, hash));
1461 /* possibly free a shared string if no one has access to it
1462 * len and hash must both be valid for str.
1465 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1467 register XPVHV* xhv;
1469 register HE **oentry;
1473 /* what follows is the moral equivalent of:
1474 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1475 if (--*Svp == Nullsv)
1476 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1478 xhv = (XPVHV*)SvANY(PL_strtab);
1479 /* assert(xhv_array != 0) */
1481 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1482 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1483 if (HeHASH(entry) != hash) /* strings can't be equal */
1485 if (HeKLEN(entry) != len)
1487 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1490 if (--HeVAL(entry) == Nullsv) {
1491 *oentry = HeNEXT(entry);
1494 Safefree(HeKEY_hek(entry));
1500 UNLOCK_STRTAB_MUTEX;
1502 if (!found && ckWARN_d(WARN_INTERNAL))
1503 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1506 /* get a (constant) string ptr from the global string table
1507 * string will get added if it is not already there.
1508 * len and hash must both be valid for str.
1511 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1513 register XPVHV* xhv;
1515 register HE **oentry;
1518 bool is_utf8 = FALSE;
1525 /* what follows is the moral equivalent of:
1527 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1528 hv_store(PL_strtab, str, len, Nullsv, hash);
1530 xhv = (XPVHV*)SvANY(PL_strtab);
1531 /* assert(xhv_array != 0) */
1533 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1534 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1535 if (HeHASH(entry) != hash) /* strings can't be equal */
1537 if (HeKLEN(entry) != len)
1539 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1541 if (HeKUTF8(entry) != (char)is_utf8)
1548 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1549 HeVAL(entry) = Nullsv;
1550 HeNEXT(entry) = *oentry;
1553 if (i) { /* initial entry? */
1555 if (xhv->xhv_keys > xhv->xhv_max)
1560 ++HeVAL(entry); /* use value slot as REFCNT */
1561 UNLOCK_STRTAB_MUTEX;
1562 return HeKEY_hek(entry);