3 * Copyright (c) 1991-2001, 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_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
101 #if defined(USE_ITHREADS)
103 Perl_he_dup(pTHX_ HE *e, bool shared)
109 /* look for it in the table first */
110 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
114 /* create anew and remember what it is */
116 ptr_table_store(PL_ptr_table, e, ret);
118 HeNEXT(ret) = he_dup(HeNEXT(e),shared);
119 if (HeKLEN(e) == HEf_SVKEY)
120 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
122 HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
124 HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
125 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
128 #endif /* USE_ITHREADS */
130 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
136 Returns the SV which corresponds to the specified key in the hash. The
137 C<klen> is the length of the key. If C<lval> is set then the fetch will be
138 part of a store. Check that the return value is non-null before
139 dereferencing it to a C<SV*>.
141 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
142 information on how to use this function on tied hashes.
148 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
153 bool is_utf8 = FALSE;
154 const char *keysave = key;
164 if (SvRMAGICAL(hv)) {
165 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
167 mg_copy((SV*)hv, sv, key, klen);
169 return &PL_hv_fetch_sv;
171 #ifdef ENV_IS_CASELESS
172 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
174 for (i = 0; i < klen; ++i)
175 if (isLOWER(key[i])) {
176 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
177 SV **ret = hv_fetch(hv, nkey, klen, 0);
179 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
188 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
189 || mg_find((SV*)hv, PERL_MAGIC_env)
192 Newz(503, HvARRAY(hv),
193 PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), HE*);
198 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
199 STRLEN tmplen = klen;
200 /* Just casting the &klen to (STRLEN) won't work well
201 * if STRLEN and I32 are of different widths. --jhi */
202 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
206 PERL_HASH(hash, key, klen);
208 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
209 for (; entry; entry = HeNEXT(entry)) {
210 if (HeHASH(entry) != hash) /* strings can't be equal */
212 if (HeKLEN(entry) != klen)
214 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
216 if (HeKUTF8(entry) != (char)is_utf8)
220 return &HeVAL(entry);
222 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
223 if (mg_find((SV*)hv, PERL_MAGIC_env)) {
225 char *env = PerlEnv_ENVgetenv_len(key,&len);
227 sv = newSVpvn(env,len);
231 return hv_store(hv,key,klen,sv,hash);
235 if (lval) { /* gonna assign to this, so it better be there */
237 if (key != keysave) { /* must be is_utf8 == 0 */
238 SV **ret = hv_store(hv,key,klen,sv,hash);
243 return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
250 /* returns a HE * structure with the all fields set */
251 /* note that hent_val will be a mortal sv for MAGICAL hashes */
253 =for apidoc hv_fetch_ent
255 Returns the hash entry which corresponds to the specified key in the hash.
256 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
257 if you want the function to compute it. IF C<lval> is set then the fetch
258 will be part of a store. Make sure the return value is non-null before
259 accessing it. The return value when C<tb> is a tied hash is a pointer to a
260 static location, so be sure to make a copy of the structure if you need to
263 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
264 information on how to use this function on tied hashes.
270 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
282 if (SvRMAGICAL(hv)) {
283 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
285 keysv = sv_2mortal(newSVsv(keysv));
286 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
287 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
289 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
290 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
292 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
293 HeVAL(&PL_hv_fetch_ent_mh) = sv;
294 return &PL_hv_fetch_ent_mh;
296 #ifdef ENV_IS_CASELESS
297 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
299 key = SvPV(keysv, klen);
300 for (i = 0; i < klen; ++i)
301 if (isLOWER(key[i])) {
302 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
303 (void)strupr(SvPVX(nkeysv));
304 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
306 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
315 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
316 || mg_find((SV*)hv, PERL_MAGIC_env)
319 Newz(503, HvARRAY(hv),
320 PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), HE*);
325 keysave = key = SvPV(keysv, klen);
326 is_utf8 = (SvUTF8(keysv)!=0);
328 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
329 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
332 PERL_HASH(hash, key, klen);
334 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
335 for (; entry; entry = HeNEXT(entry)) {
336 if (HeHASH(entry) != hash) /* strings can't be equal */
338 if (HeKLEN(entry) != klen)
340 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
342 if (HeKUTF8(entry) != (char)is_utf8)
348 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
349 if (mg_find((SV*)hv, PERL_MAGIC_env)) {
351 char *env = PerlEnv_ENVgetenv_len(key,&len);
353 sv = newSVpvn(env,len);
355 return hv_store_ent(hv,keysv,sv,hash);
361 if (lval) { /* gonna assign to this, so it better be there */
363 return hv_store_ent(hv,keysv,sv,hash);
369 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
371 MAGIC *mg = SvMAGIC(hv);
375 if (isUPPER(mg->mg_type)) {
377 switch (mg->mg_type) {
378 case PERL_MAGIC_tied:
380 *needs_store = FALSE;
383 mg = mg->mg_moremagic;
390 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
391 the length of the key. The C<hash> parameter is the precomputed hash
392 value; if it is zero then Perl will compute it. The return value will be
393 NULL if the operation failed or if the value did not need to be actually
394 stored within the hash (as in the case of tied hashes). Otherwise it can
395 be dereferenced to get the original C<SV*>. Note that the caller is
396 responsible for suitably incrementing the reference count of C<val> before
397 the call, and decrementing it if the function returned NULL.
399 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
400 information on how to use this function on tied hashes.
406 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
410 register HE **oentry;
411 bool is_utf8 = FALSE;
412 const char *keysave = key;
425 hv_magic_check (hv, &needs_copy, &needs_store);
427 mg_copy((SV*)hv, val, key, klen);
428 if (!HvARRAY(hv) && !needs_store)
430 #ifdef ENV_IS_CASELESS
431 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
432 key = savepvn(key,klen);
439 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
440 STRLEN tmplen = klen;
441 /* See the note in hv_fetch(). --jhi */
442 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
447 PERL_HASH(hash, key, klen);
450 Newz(505, HvARRAY(hv),
451 PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), HE*);
453 oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
456 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
457 if (HeHASH(entry) != hash) /* strings can't be equal */
459 if (HeKLEN(entry) != klen)
461 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
463 if (HeKUTF8(entry) != (char)is_utf8)
465 SvREFCNT_dec(HeVAL(entry));
469 return &HeVAL(entry);
474 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
475 else /* gotta do the real thing */
476 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
480 HeNEXT(entry) = *oentry;
484 if (i) { /* initial entry? */
486 if (HvKEYS(hv) > HvMAX(hv))
490 return &HeVAL(entry);
494 =for apidoc hv_store_ent
496 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
497 parameter is the precomputed hash value; if it is zero then Perl will
498 compute it. The return value is the new hash entry so created. It will be
499 NULL if the operation failed or if the value did not need to be actually
500 stored within the hash (as in the case of tied hashes). Otherwise the
501 contents of the return value can be accessed using the C<He?> macros
502 described here. Note that the caller is responsible for suitably
503 incrementing the reference count of C<val> before the call, and
504 decrementing it if the function returned NULL.
506 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
507 information on how to use this function on tied hashes.
513 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
519 register HE **oentry;
529 hv_magic_check (hv, &needs_copy, &needs_store);
531 bool save_taint = PL_tainted;
533 PL_tainted = SvTAINTED(keysv);
534 keysv = sv_2mortal(newSVsv(keysv));
535 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
536 TAINT_IF(save_taint);
537 if (!HvARRAY(hv) && !needs_store)
539 #ifdef ENV_IS_CASELESS
540 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
541 key = SvPV(keysv, klen);
542 keysv = sv_2mortal(newSVpvn(key,klen));
543 (void)strupr(SvPVX(keysv));
550 keysave = key = SvPV(keysv, klen);
551 is_utf8 = (SvUTF8(keysv) != 0);
553 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
554 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
557 PERL_HASH(hash, key, klen);
560 Newz(505, HvARRAY(hv),
561 PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), HE*);
563 oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
566 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
567 if (HeHASH(entry) != hash) /* strings can't be equal */
569 if (HeKLEN(entry) != klen)
571 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
573 if (HeKUTF8(entry) != (char)is_utf8)
575 SvREFCNT_dec(HeVAL(entry));
584 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
585 else /* gotta do the real thing */
586 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
590 HeNEXT(entry) = *oentry;
594 if (i) { /* initial entry? */
596 if (HvKEYS(hv) > HvMAX(hv))
604 =for apidoc hv_delete
606 Deletes a key/value pair in the hash. The value SV is removed from the
607 hash and returned to the caller. The C<klen> is the length of the key.
608 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
615 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
620 register HE **oentry;
623 bool is_utf8 = FALSE;
624 const char *keysave = key;
632 if (SvRMAGICAL(hv)) {
635 hv_magic_check (hv, &needs_copy, &needs_store);
637 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
641 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
642 /* No longer an element */
643 sv_unmagic(sv, PERL_MAGIC_tiedelem);
646 return Nullsv; /* element cannot be deleted */
648 #ifdef ENV_IS_CASELESS
649 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
650 sv = sv_2mortal(newSVpvn(key,klen));
651 key = strupr(SvPVX(sv));
659 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
660 STRLEN tmplen = klen;
661 /* See the note in hv_fetch(). --jhi */
662 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
666 PERL_HASH(hash, key, klen);
668 oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
671 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
672 if (HeHASH(entry) != hash) /* strings can't be equal */
674 if (HeKLEN(entry) != klen)
676 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
678 if (HeKUTF8(entry) != (char)is_utf8)
682 *oentry = HeNEXT(entry);
685 if (flags & G_DISCARD)
688 sv = sv_2mortal(HeVAL(entry));
689 HeVAL(entry) = &PL_sv_undef;
691 if (entry == HvEITER(hv))
694 hv_free_ent(hv, entry);
704 =for apidoc hv_delete_ent
706 Deletes a key/value pair in the hash. The value SV is removed from the
707 hash and returned to the caller. The C<flags> value will normally be zero;
708 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
709 precomputed hash value, or 0 to ask for it to be computed.
715 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
721 register HE **oentry;
728 if (SvRMAGICAL(hv)) {
731 hv_magic_check (hv, &needs_copy, &needs_store);
733 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
737 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
738 /* No longer an element */
739 sv_unmagic(sv, PERL_MAGIC_tiedelem);
742 return Nullsv; /* element cannot be deleted */
744 #ifdef ENV_IS_CASELESS
745 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
746 key = SvPV(keysv, klen);
747 keysv = sv_2mortal(newSVpvn(key,klen));
748 (void)strupr(SvPVX(keysv));
757 keysave = key = SvPV(keysv, klen);
758 is_utf8 = (SvUTF8(keysv) != 0);
760 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
761 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
764 PERL_HASH(hash, key, klen);
766 oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
769 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
770 if (HeHASH(entry) != hash) /* strings can't be equal */
772 if (HeKLEN(entry) != klen)
774 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
776 if (HeKUTF8(entry) != (char)is_utf8)
780 *oentry = HeNEXT(entry);
783 if (flags & G_DISCARD)
786 sv = sv_2mortal(HeVAL(entry));
787 HeVAL(entry) = &PL_sv_undef;
789 if (entry == HvEITER(hv))
792 hv_free_ent(hv, entry);
802 =for apidoc hv_exists
804 Returns a boolean indicating whether the specified hash key exists. The
805 C<klen> is the length of the key.
811 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
816 bool is_utf8 = FALSE;
817 const char *keysave = key;
827 if (SvRMAGICAL(hv)) {
828 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
830 mg_copy((SV*)hv, sv, key, klen);
831 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
834 #ifdef ENV_IS_CASELESS
835 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
836 sv = sv_2mortal(newSVpvn(key,klen));
837 key = strupr(SvPVX(sv));
842 #ifndef DYNAMIC_ENV_FETCH
847 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
848 STRLEN tmplen = klen;
849 /* See the note in hv_fetch(). --jhi */
850 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
854 PERL_HASH(hash, key, klen);
856 #ifdef DYNAMIC_ENV_FETCH
857 if (!HvARRAY(hv)) entry = Null(HE*);
860 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
861 for (; entry; entry = HeNEXT(entry)) {
862 if (HeHASH(entry) != hash) /* strings can't be equal */
864 if (HeKLEN(entry) != klen)
866 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
868 if (HeKUTF8(entry) != (char)is_utf8)
874 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
875 if (mg_find((SV*)hv, PERL_MAGIC_env)) {
877 char *env = PerlEnv_ENVgetenv_len(key,&len);
879 sv = newSVpvn(env,len);
881 (void)hv_store(hv,key,klen,sv,hash);
893 =for apidoc hv_exists_ent
895 Returns a boolean indicating whether the specified hash key exists. C<hash>
896 can be a valid precomputed hash value, or 0 to ask for it to be
903 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
915 if (SvRMAGICAL(hv)) {
916 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
917 SV* svret = sv_newmortal();
919 keysv = sv_2mortal(newSVsv(keysv));
920 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
921 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
922 return SvTRUE(svret);
924 #ifdef ENV_IS_CASELESS
925 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
926 key = SvPV(keysv, klen);
927 keysv = sv_2mortal(newSVpvn(key,klen));
928 (void)strupr(SvPVX(keysv));
934 #ifndef DYNAMIC_ENV_FETCH
939 keysave = key = SvPV(keysv, klen);
940 is_utf8 = (SvUTF8(keysv) != 0);
941 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
942 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
944 PERL_HASH(hash, key, klen);
946 #ifdef DYNAMIC_ENV_FETCH
947 if (!HvARRAY(hv)) entry = Null(HE*);
950 entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
951 for (; entry; entry = HeNEXT(entry)) {
952 if (HeHASH(entry) != hash) /* strings can't be equal */
954 if (HeKLEN(entry) != klen)
956 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
958 if (HeKUTF8(entry) != (char)is_utf8)
964 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
965 if (mg_find((SV*)hv, PERL_MAGIC_env)) {
967 char *env = PerlEnv_ENVgetenv_len(key,&len);
969 sv = newSVpvn(env,len);
971 (void)hv_store_ent(hv,keysv,sv,hash);
982 S_hsplit(pTHX_ HV *hv)
984 I32 oldsize = (I32) HvMAX(hv) + 1; /* sic(k) */
985 register I32 newsize = oldsize * 2;
987 register char *a = (char *)HvARRAY(hv);
991 register HE **oentry;
994 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
995 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1001 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1006 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1007 if (oldsize >= 64) {
1008 offer_nice_chunk(HvARRAY(hv), PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1011 Safefree(HvARRAY(hv));
1015 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1016 HvMAX(hv) = --newsize;
1017 HvARRAY(hv) = (HE**)a;
1020 for (i=0; i<oldsize; i++,aep++) {
1021 if (!*aep) /* non-existent */
1024 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1025 if ((HeHASH(entry) & newsize) != i) {
1026 *oentry = HeNEXT(entry);
1027 HeNEXT(entry) = *bep;
1034 oentry = &HeNEXT(entry);
1036 if (!*aep) /* everything moved */
1042 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1044 I32 oldsize = (I32) HvMAX(hv) + 1; /* sic(k) */
1045 register I32 newsize;
1051 register HE **oentry;
1053 newsize = (I32) newmax; /* possible truncation here */
1054 if (newsize != newmax || newmax <= oldsize)
1056 while ((newsize & (1 + ~newsize)) != newsize) {
1057 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1059 if (newsize < newmax)
1061 if (newsize < newmax)
1062 return; /* overflow detection */
1064 a = (char *)HvARRAY(hv);
1067 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1068 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1074 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1079 Copy(HvARRAY(hv), a, oldsize * sizeof(HE*), char);
1080 if (oldsize >= 64) {
1081 offer_nice_chunk(HvARRAY(hv), PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1084 Safefree(HvARRAY(hv));
1087 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1090 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1092 HvMAX(hv) = --newsize;
1093 HvARRAY(hv) = (HE**)a;
1094 if (!HvFILL(hv)) /* skip rest if no entries */
1098 for (i=0; i<oldsize; i++,aep++) {
1099 if (!*aep) /* non-existent */
1101 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1102 if ((j = (HeHASH(entry) & newsize)) != i) {
1104 *oentry = HeNEXT(entry);
1105 if (!(HeNEXT(entry) = aep[j]))
1111 oentry = &HeNEXT(entry);
1113 if (!*aep) /* everything moved */
1121 Creates a new HV. The reference count is set to 1.
1131 hv = (HV*)NEWSV(502,0);
1132 sv_upgrade((SV *)hv, SVt_PVHV);
1135 #ifndef NODEFAULT_SHAREKEYS
1136 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1138 HvMAX(hv) = 7; /* start with 8 buckets */
1141 (void)hv_iterinit(hv); /* so each() will start off right */
1146 Perl_newHVhv(pTHX_ HV *ohv)
1149 STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1150 STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1153 while (hv_max && hv_max + 1 >= hv_fill * 2)
1154 hv_max = hv_max / 2; /* Is always 2^n-1 */
1160 if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
1167 I32 hv_riter = HvRITER(ohv); /* current root of iterator */
1168 HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
1172 while ((entry = hv_iternext(ohv))) {
1173 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1174 newSVsv(HeVAL(entry)), HeHASH(entry));
1176 HvRITER(ohv) = hv_riter;
1177 HvEITER(ohv) = hv_eiter;
1184 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1191 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1192 PL_sub_generation++; /* may be deletion of method from stash */
1194 if (HeKLEN(entry) == HEf_SVKEY) {
1195 SvREFCNT_dec(HeKEY_sv(entry));
1196 Safefree(HeKEY_hek(entry));
1198 else if (HvSHAREKEYS(hv))
1199 unshare_hek(HeKEY_hek(entry));
1201 Safefree(HeKEY_hek(entry));
1206 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1210 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1211 PL_sub_generation++; /* may be deletion of method from stash */
1212 sv_2mortal(HeVAL(entry)); /* free between statements */
1213 if (HeKLEN(entry) == HEf_SVKEY) {
1214 sv_2mortal(HeKEY_sv(entry));
1215 Safefree(HeKEY_hek(entry));
1217 else if (HvSHAREKEYS(hv))
1218 unshare_hek(HeKEY_hek(entry));
1220 Safefree(HeKEY_hek(entry));
1225 =for apidoc hv_clear
1227 Clears a hash, making it empty.
1233 Perl_hv_clear(pTHX_ HV *hv)
1241 (void)memzero(HvARRAY(hv), (HvMAX(hv) + 1) * sizeof(HE*));
1248 S_hfreeentries(pTHX_ HV *hv)
1250 register HE **array;
1252 register HE *oentry = Null(HE*);
1263 array = HvARRAY(hv);
1268 entry = HeNEXT(entry);
1269 hv_free_ent(hv, oentry);
1274 entry = array[riter];
1277 (void)hv_iterinit(hv);
1281 =for apidoc hv_undef
1289 Perl_hv_undef(pTHX_ HV *hv)
1294 Safefree(HvARRAY(hv));
1296 Safefree(HvNAME(hv));
1300 HvMAX(hv) = 7; /* it's a normal hash */
1309 =for apidoc hv_iterinit
1311 Prepares a starting point to traverse a hash table. Returns the number of
1312 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1313 currently only meaningful for hashes without tie magic.
1315 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1316 hash buckets that happen to be in use. If you still need that esoteric
1317 value, you can get it through the macro C<HvFILL(tb)>.
1323 Perl_hv_iterinit(pTHX_ HV *hv)
1328 Perl_croak(aTHX_ "Bad hash");
1329 entry = HvEITER(hv);
1330 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1332 hv_free_ent(hv, entry);
1335 HvEITER(hv) = Null(HE*);
1336 return HvKEYS(hv); /* used to be xhv->xhv_fill before 5.004_65 */
1340 =for apidoc hv_iternext
1342 Returns entries from a hash iterator. See C<hv_iterinit>.
1348 Perl_hv_iternext(pTHX_ HV *hv)
1355 Perl_croak(aTHX_ "Bad hash");
1356 oldentry = entry = HvEITER(hv);
1358 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1359 SV *key = sv_newmortal();
1361 sv_setsv(key, HeSVKEY_force(entry));
1362 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1368 HvEITER(hv) = entry = new_HE(); /* one HE per MAGICAL hash */
1370 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1372 HeKEY_hek(entry) = hek;
1373 HeKLEN(entry) = HEf_SVKEY;
1375 magic_nextpack((SV*) hv,mg,key);
1377 /* force key to stay around until next time */
1378 HeSVKEY_set(entry, SvREFCNT_inc(key));
1379 return entry; /* beware, hent_val is not set */
1382 SvREFCNT_dec(HeVAL(entry));
1383 Safefree(HeKEY_hek(entry));
1385 HvEITER(hv) = Null(HE*);
1388 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1389 if (!entry && mg_find((SV*)hv, PERL_MAGIC_env))
1394 Newz(506, HvARRAY(hv),
1395 PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1), HE*);
1397 entry = HeNEXT(entry);
1400 if (HvRITER(hv) > HvMAX(hv)) {
1404 entry = (HvARRAY(hv))[HvRITER(hv)];
1407 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1409 hv_free_ent(hv, oldentry);
1412 HvEITER(hv) = entry;
1417 =for apidoc hv_iterkey
1419 Returns the key from the current position of the hash iterator. See
1426 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1428 if (HeKLEN(entry) == HEf_SVKEY) {
1430 char *p = SvPV(HeKEY_sv(entry), len);
1435 *retlen = HeKLEN(entry);
1436 return HeKEY(entry);
1440 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1442 =for apidoc hv_iterkeysv
1444 Returns the key as an C<SV*> from the current position of the hash
1445 iterator. The return value will always be a mortal copy of the key. Also
1452 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1454 if (HeKLEN(entry) == HEf_SVKEY)
1455 return sv_mortalcopy(HeKEY_sv(entry));
1457 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1458 HeKLEN_UTF8(entry), HeHASH(entry)));
1462 =for apidoc hv_iterval
1464 Returns the value from the current position of the hash iterator. See
1471 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1473 if (SvRMAGICAL(hv)) {
1474 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1475 SV* sv = sv_newmortal();
1476 if (HeKLEN(entry) == HEf_SVKEY)
1477 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1478 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1482 return HeVAL(entry);
1486 =for apidoc hv_iternextsv
1488 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1495 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1498 if ( (he = hv_iternext(hv)) == NULL)
1500 *key = hv_iterkey(he, retlen);
1501 return hv_iterval(hv, he);
1505 =for apidoc hv_magic
1507 Adds magic to a hash. See C<sv_magic>.
1513 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1515 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1519 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1521 return HEK_KEY(share_hek(sv, len, hash));
1524 /* possibly free a shared string if no one has access to it
1525 * len and hash must both be valid for str.
1528 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1532 register HE **oentry;
1535 bool is_utf8 = FALSE;
1536 const char *save = str;
1541 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1542 STRLEN tmplen = len;
1543 /* See the note in hv_fetch(). --jhi */
1544 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1549 /* what follows is the moral equivalent of:
1550 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1551 if (--*Svp == Nullsv)
1552 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1554 /* assert(xhv_array != 0) */
1557 oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1558 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1559 if (HeHASH(entry) != hash) /* strings can't be equal */
1561 if (HeKLEN(entry) != len)
1563 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1565 if (HeKUTF8(entry) != (char)is_utf8)
1568 if (--HeVAL(entry) == Nullsv) {
1569 *oentry = HeNEXT(entry);
1572 Safefree(HeKEY_hek(entry));
1578 UNLOCK_STRTAB_MUTEX;
1581 if (!found && ckWARN_d(WARN_INTERNAL))
1582 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1585 /* get a (constant) string ptr from the global string table
1586 * string will get added if it is not already there.
1587 * len and hash must both be valid for str.
1590 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1594 register HE **oentry;
1597 bool is_utf8 = FALSE;
1598 const char *save = str;
1603 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1604 STRLEN tmplen = len;
1605 /* See the note in hv_fetch(). --jhi */
1606 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1611 /* what follows is the moral equivalent of:
1613 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1614 hv_store(PL_strtab, str, len, Nullsv, hash);
1616 /* assert(xhv_array != 0) */
1619 oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1620 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1621 if (HeHASH(entry) != hash) /* strings can't be equal */
1623 if (HeKLEN(entry) != len)
1625 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1627 if (HeKUTF8(entry) != (char)is_utf8)
1634 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1635 HeVAL(entry) = Nullsv;
1636 HeNEXT(entry) = *oentry;
1639 if (i) { /* initial entry? */
1641 if (HvKEYS(hv) > HvMAX(hv))
1646 ++HeVAL(entry); /* use value slot as REFCNT */
1647 UNLOCK_STRTAB_MUTEX;
1650 return HeKEY_hek(entry);