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)
154 bool is_utf8 = FALSE;
155 const char *keysave = key;
165 if (SvRMAGICAL(hv)) {
166 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
168 mg_copy((SV*)hv, sv, key, klen);
170 return &PL_hv_fetch_sv;
172 #ifdef ENV_IS_CASELESS
173 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
175 for (i = 0; i < klen; ++i)
176 if (isLOWER(key[i])) {
177 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
178 SV **ret = hv_fetch(hv, nkey, klen, 0);
180 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
187 xhv = (XPVHV*)SvANY(hv);
188 if (!xhv->xhv_array) {
190 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
191 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
194 Newz(503, xhv->xhv_array,
195 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
200 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
201 STRLEN tmplen = klen;
202 /* Just casting the &klen to (STRLEN) won't work well
203 * if STRLEN and I32 are of different widths. --jhi */
204 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
208 PERL_HASH(hash, key, klen);
210 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
211 for (; entry; entry = HeNEXT(entry)) {
212 if (HeHASH(entry) != hash) /* strings can't be equal */
214 if (HeKLEN(entry) != klen)
216 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
218 if (HeKUTF8(entry) != (char)is_utf8)
222 return &HeVAL(entry);
224 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
225 if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
227 char *env = PerlEnv_ENVgetenv_len(key,&len);
229 sv = newSVpvn(env,len);
233 return hv_store(hv,key,klen,sv,hash);
237 if (lval) { /* gonna assign to this, so it better be there */
239 if (key != keysave) { /* must be is_utf8 == 0 */
240 SV **ret = hv_store(hv,key,klen,sv,hash);
245 return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
252 /* returns a HE * structure with the all fields set */
253 /* note that hent_val will be a mortal sv for MAGICAL hashes */
255 =for apidoc hv_fetch_ent
257 Returns the hash entry which corresponds to the specified key in the hash.
258 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
259 if you want the function to compute it. IF C<lval> is set then the fetch
260 will be part of a store. Make sure the return value is non-null before
261 accessing it. The return value when C<tb> is a tied hash is a pointer to a
262 static location, so be sure to make a copy of the structure if you need to
265 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
266 information on how to use this function on tied hashes.
272 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
285 if (SvRMAGICAL(hv)) {
286 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
288 keysv = sv_2mortal(newSVsv(keysv));
289 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
290 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
292 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
293 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
295 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
296 HeVAL(&PL_hv_fetch_ent_mh) = sv;
297 return &PL_hv_fetch_ent_mh;
299 #ifdef ENV_IS_CASELESS
300 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
302 key = SvPV(keysv, klen);
303 for (i = 0; i < klen; ++i)
304 if (isLOWER(key[i])) {
305 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
306 (void)strupr(SvPVX(nkeysv));
307 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
309 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
316 xhv = (XPVHV*)SvANY(hv);
317 if (!xhv->xhv_array) {
319 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
320 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
323 Newz(503, xhv->xhv_array,
324 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
329 keysave = key = SvPV(keysv, klen);
330 is_utf8 = (SvUTF8(keysv)!=0);
332 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
333 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
336 PERL_HASH(hash, key, klen);
338 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
339 for (; entry; entry = HeNEXT(entry)) {
340 if (HeHASH(entry) != hash) /* strings can't be equal */
342 if (HeKLEN(entry) != klen)
344 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
346 if (HeKUTF8(entry) != (char)is_utf8)
352 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
353 if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
355 char *env = PerlEnv_ENVgetenv_len(key,&len);
357 sv = newSVpvn(env,len);
359 return hv_store_ent(hv,keysv,sv,hash);
365 if (lval) { /* gonna assign to this, so it better be there */
367 return hv_store_ent(hv,keysv,sv,hash);
373 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
375 MAGIC *mg = SvMAGIC(hv);
379 if (isUPPER(mg->mg_type)) {
381 switch (mg->mg_type) {
382 case PERL_MAGIC_tied:
384 *needs_store = FALSE;
387 mg = mg->mg_moremagic;
394 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
395 the length of the key. The C<hash> parameter is the precomputed hash
396 value; if it is zero then Perl will compute it. The return value will be
397 NULL if the operation failed or if the value did not need to be actually
398 stored within the hash (as in the case of tied hashes). Otherwise it can
399 be dereferenced to get the original C<SV*>. Note that the caller is
400 responsible for suitably incrementing the reference count of C<val> before
401 the call, and decrementing it if the function returned NULL.
403 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
404 information on how to use this function on tied hashes.
410 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash)
415 register HE **oentry;
416 bool is_utf8 = FALSE;
417 const char *keysave = key;
427 xhv = (XPVHV*)SvANY(hv);
431 hv_magic_check (hv, &needs_copy, &needs_store);
433 mg_copy((SV*)hv, val, key, klen);
434 if (!xhv->xhv_array && !needs_store)
436 #ifdef ENV_IS_CASELESS
437 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
438 key = savepvn(key,klen);
445 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
446 STRLEN tmplen = klen;
447 /* See the note in hv_fetch(). --jhi */
448 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
453 PERL_HASH(hash, key, klen);
456 Newz(505, xhv->xhv_array,
457 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
459 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
462 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
463 if (HeHASH(entry) != hash) /* strings can't be equal */
465 if (HeKLEN(entry) != klen)
467 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
469 if (HeKUTF8(entry) != (char)is_utf8)
471 SvREFCNT_dec(HeVAL(entry));
475 return &HeVAL(entry);
480 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
481 else /* gotta do the real thing */
482 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
486 HeNEXT(entry) = *oentry;
490 if (i) { /* initial entry? */
492 if (xhv->xhv_keys > xhv->xhv_max)
496 return &HeVAL(entry);
500 =for apidoc hv_store_ent
502 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
503 parameter is the precomputed hash value; if it is zero then Perl will
504 compute it. The return value is the new hash entry so created. It will be
505 NULL if the operation failed or if the value did not need to be actually
506 stored within the hash (as in the case of tied hashes). Otherwise the
507 contents of the return value can be accessed using the C<He???> macros
508 described here. Note that the caller is responsible for suitably
509 incrementing the reference count of C<val> before the call, and
510 decrementing it if the function returned NULL.
512 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
513 information on how to use this function on tied hashes.
519 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
526 register HE **oentry;
533 xhv = (XPVHV*)SvANY(hv);
537 hv_magic_check (hv, &needs_copy, &needs_store);
539 bool save_taint = PL_tainted;
541 PL_tainted = SvTAINTED(keysv);
542 keysv = sv_2mortal(newSVsv(keysv));
543 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
544 TAINT_IF(save_taint);
545 if (!xhv->xhv_array && !needs_store)
547 #ifdef ENV_IS_CASELESS
548 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
549 key = SvPV(keysv, klen);
550 keysv = sv_2mortal(newSVpvn(key,klen));
551 (void)strupr(SvPVX(keysv));
558 keysave = key = SvPV(keysv, klen);
559 is_utf8 = (SvUTF8(keysv) != 0);
561 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
562 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
565 PERL_HASH(hash, key, klen);
568 Newz(505, xhv->xhv_array,
569 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
571 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
574 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
575 if (HeHASH(entry) != hash) /* strings can't be equal */
577 if (HeKLEN(entry) != klen)
579 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
581 if (HeKUTF8(entry) != (char)is_utf8)
583 SvREFCNT_dec(HeVAL(entry));
592 HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
593 else /* gotta do the real thing */
594 HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
598 HeNEXT(entry) = *oentry;
602 if (i) { /* initial entry? */
604 if (xhv->xhv_keys > xhv->xhv_max)
612 =for apidoc hv_delete
614 Deletes a key/value pair in the hash. The value SV is removed from the
615 hash and returned to the caller. The C<klen> is the length of the key.
616 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
623 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
629 register HE **oentry;
632 bool is_utf8 = FALSE;
633 const char *keysave = key;
641 if (SvRMAGICAL(hv)) {
644 hv_magic_check (hv, &needs_copy, &needs_store);
646 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
650 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
651 /* No longer an element */
652 sv_unmagic(sv, PERL_MAGIC_tiedelem);
655 return Nullsv; /* element cannot be deleted */
657 #ifdef ENV_IS_CASELESS
658 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
659 sv = sv_2mortal(newSVpvn(key,klen));
660 key = strupr(SvPVX(sv));
665 xhv = (XPVHV*)SvANY(hv);
669 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
670 STRLEN tmplen = klen;
671 /* See the note in hv_fetch(). --jhi */
672 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
676 PERL_HASH(hash, key, klen);
678 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
681 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
682 if (HeHASH(entry) != hash) /* strings can't be equal */
684 if (HeKLEN(entry) != klen)
686 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
688 if (HeKUTF8(entry) != (char)is_utf8)
692 *oentry = HeNEXT(entry);
695 if (flags & G_DISCARD)
698 sv = sv_2mortal(HeVAL(entry));
699 HeVAL(entry) = &PL_sv_undef;
701 if (entry == xhv->xhv_eiter)
704 hv_free_ent(hv, entry);
714 =for apidoc hv_delete_ent
716 Deletes a key/value pair in the hash. The value SV is removed from the
717 hash and returned to the caller. The C<flags> value will normally be zero;
718 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
719 precomputed hash value, or 0 to ask for it to be computed.
725 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
732 register HE **oentry;
739 if (SvRMAGICAL(hv)) {
742 hv_magic_check (hv, &needs_copy, &needs_store);
744 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
748 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
749 /* No longer an element */
750 sv_unmagic(sv, PERL_MAGIC_tiedelem);
753 return Nullsv; /* element cannot be deleted */
755 #ifdef ENV_IS_CASELESS
756 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
757 key = SvPV(keysv, klen);
758 keysv = sv_2mortal(newSVpvn(key,klen));
759 (void)strupr(SvPVX(keysv));
765 xhv = (XPVHV*)SvANY(hv);
769 keysave = key = SvPV(keysv, klen);
770 is_utf8 = (SvUTF8(keysv) != 0);
772 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
773 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
776 PERL_HASH(hash, key, klen);
778 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
781 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
782 if (HeHASH(entry) != hash) /* strings can't be equal */
784 if (HeKLEN(entry) != klen)
786 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
788 if (HeKUTF8(entry) != (char)is_utf8)
792 *oentry = HeNEXT(entry);
795 if (flags & G_DISCARD)
798 sv = sv_2mortal(HeVAL(entry));
799 HeVAL(entry) = &PL_sv_undef;
801 if (entry == xhv->xhv_eiter)
804 hv_free_ent(hv, entry);
814 =for apidoc hv_exists
816 Returns a boolean indicating whether the specified hash key exists. The
817 C<klen> is the length of the key.
823 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
829 bool is_utf8 = FALSE;
830 const char *keysave = key;
840 if (SvRMAGICAL(hv)) {
841 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
843 mg_copy((SV*)hv, sv, key, klen);
844 magic_existspack(sv, mg_find(sv, PERL_MAGIC_tiedelem));
847 #ifdef ENV_IS_CASELESS
848 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
849 sv = sv_2mortal(newSVpvn(key,klen));
850 key = strupr(SvPVX(sv));
855 xhv = (XPVHV*)SvANY(hv);
856 #ifndef DYNAMIC_ENV_FETCH
861 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
862 STRLEN tmplen = klen;
863 /* See the note in hv_fetch(). --jhi */
864 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
868 PERL_HASH(hash, key, klen);
870 #ifdef DYNAMIC_ENV_FETCH
871 if (!xhv->xhv_array) entry = Null(HE*);
874 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
875 for (; entry; entry = HeNEXT(entry)) {
876 if (HeHASH(entry) != hash) /* strings can't be equal */
878 if (HeKLEN(entry) != klen)
880 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
882 if (HeKUTF8(entry) != (char)is_utf8)
888 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
889 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
891 char *env = PerlEnv_ENVgetenv_len(key,&len);
893 sv = newSVpvn(env,len);
895 (void)hv_store(hv,key,klen,sv,hash);
907 =for apidoc hv_exists_ent
909 Returns a boolean indicating whether the specified hash key exists. C<hash>
910 can be a valid precomputed hash value, or 0 to ask for it to be
917 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
930 if (SvRMAGICAL(hv)) {
931 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
932 SV* svret = sv_newmortal();
934 keysv = sv_2mortal(newSVsv(keysv));
935 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
936 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
937 return SvTRUE(svret);
939 #ifdef ENV_IS_CASELESS
940 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
941 key = SvPV(keysv, klen);
942 keysv = sv_2mortal(newSVpvn(key,klen));
943 (void)strupr(SvPVX(keysv));
949 xhv = (XPVHV*)SvANY(hv);
950 #ifndef DYNAMIC_ENV_FETCH
955 keysave = key = SvPV(keysv, klen);
956 is_utf8 = (SvUTF8(keysv) != 0);
957 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
958 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
960 PERL_HASH(hash, key, klen);
962 #ifdef DYNAMIC_ENV_FETCH
963 if (!xhv->xhv_array) entry = Null(HE*);
966 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
967 for (; entry; entry = HeNEXT(entry)) {
968 if (HeHASH(entry) != hash) /* strings can't be equal */
970 if (HeKLEN(entry) != klen)
972 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
974 if (HeKUTF8(entry) != (char)is_utf8)
980 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
981 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
983 char *env = PerlEnv_ENVgetenv_len(key,&len);
985 sv = newSVpvn(env,len);
987 (void)hv_store_ent(hv,keysv,sv,hash);
998 S_hsplit(pTHX_ HV *hv)
1000 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1001 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
1002 register I32 newsize = oldsize * 2;
1004 register char *a = xhv->xhv_array;
1008 register HE **oentry;
1011 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1012 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1018 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1023 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
1024 if (oldsize >= 64) {
1025 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1028 Safefree(xhv->xhv_array);
1032 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1033 xhv->xhv_max = --newsize;
1037 for (i=0; i<oldsize; i++,aep++) {
1038 if (!*aep) /* non-existent */
1041 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1042 if ((HeHASH(entry) & newsize) != i) {
1043 *oentry = HeNEXT(entry);
1044 HeNEXT(entry) = *bep;
1051 oentry = &HeNEXT(entry);
1053 if (!*aep) /* everything moved */
1059 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1061 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1062 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
1063 register I32 newsize;
1069 register HE **oentry;
1071 newsize = (I32) newmax; /* possible truncation here */
1072 if (newsize != newmax || newmax <= oldsize)
1074 while ((newsize & (1 + ~newsize)) != newsize) {
1075 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1077 if (newsize < newmax)
1079 if (newsize < newmax)
1080 return; /* overflow detection */
1085 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1086 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1092 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1097 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
1098 if (oldsize >= 64) {
1099 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1102 Safefree(xhv->xhv_array);
1105 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1108 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1110 xhv->xhv_max = --newsize;
1112 if (!xhv->xhv_fill) /* skip rest if no entries */
1116 for (i=0; i<oldsize; i++,aep++) {
1117 if (!*aep) /* non-existent */
1119 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1120 if ((j = (HeHASH(entry) & newsize)) != i) {
1122 *oentry = HeNEXT(entry);
1123 if (!(HeNEXT(entry) = aep[j]))
1129 oentry = &HeNEXT(entry);
1131 if (!*aep) /* everything moved */
1139 Creates a new HV. The reference count is set to 1.
1148 register XPVHV* xhv;
1150 hv = (HV*)NEWSV(502,0);
1151 sv_upgrade((SV *)hv, SVt_PVHV);
1152 xhv = (XPVHV*)SvANY(hv);
1155 #ifndef NODEFAULT_SHAREKEYS
1156 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1158 xhv->xhv_max = 7; /* start with 8 buckets */
1160 xhv->xhv_pmroot = 0;
1161 (void)hv_iterinit(hv); /* so each() will start off right */
1166 Perl_newHVhv(pTHX_ HV *ohv)
1169 STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1170 STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1173 while (hv_max && hv_max + 1 >= hv_fill * 2)
1174 hv_max = hv_max / 2; /* Is always 2^n-1 */
1180 if (! SvTIED_mg((SV*)ohv, PERL_MAGIC_tied)) {
1187 I32 hv_riter = HvRITER(ohv); /* current root of iterator */
1188 HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
1192 while ((entry = hv_iternext(ohv))) {
1193 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1194 newSVsv(HeVAL(entry)), HeHASH(entry));
1196 HvRITER(ohv) = hv_riter;
1197 HvEITER(ohv) = hv_eiter;
1204 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1211 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1212 PL_sub_generation++; /* may be deletion of method from stash */
1214 if (HeKLEN(entry) == HEf_SVKEY) {
1215 SvREFCNT_dec(HeKEY_sv(entry));
1216 Safefree(HeKEY_hek(entry));
1218 else if (HvSHAREKEYS(hv))
1219 unshare_hek(HeKEY_hek(entry));
1221 Safefree(HeKEY_hek(entry));
1226 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1230 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1231 PL_sub_generation++; /* may be deletion of method from stash */
1232 sv_2mortal(HeVAL(entry)); /* free between statements */
1233 if (HeKLEN(entry) == HEf_SVKEY) {
1234 sv_2mortal(HeKEY_sv(entry));
1235 Safefree(HeKEY_hek(entry));
1237 else if (HvSHAREKEYS(hv))
1238 unshare_hek(HeKEY_hek(entry));
1240 Safefree(HeKEY_hek(entry));
1245 =for apidoc hv_clear
1247 Clears a hash, making it empty.
1253 Perl_hv_clear(pTHX_ HV *hv)
1255 register XPVHV* xhv;
1258 xhv = (XPVHV*)SvANY(hv);
1263 (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
1270 S_hfreeentries(pTHX_ HV *hv)
1272 register HE **array;
1274 register HE *oentry = Null(HE*);
1285 array = HvARRAY(hv);
1290 entry = HeNEXT(entry);
1291 hv_free_ent(hv, oentry);
1296 entry = array[riter];
1299 (void)hv_iterinit(hv);
1303 =for apidoc hv_undef
1311 Perl_hv_undef(pTHX_ HV *hv)
1313 register XPVHV* xhv;
1316 xhv = (XPVHV*)SvANY(hv);
1318 Safefree(xhv->xhv_array);
1320 Safefree(HvNAME(hv));
1324 xhv->xhv_max = 7; /* it's a normal hash */
1333 =for apidoc hv_iterinit
1335 Prepares a starting point to traverse a hash table. Returns the number of
1336 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1337 currently only meaningful for hashes without tie magic.
1339 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1340 hash buckets that happen to be in use. If you still need that esoteric
1341 value, you can get it through the macro C<HvFILL(tb)>.
1347 Perl_hv_iterinit(pTHX_ HV *hv)
1349 register XPVHV* xhv;
1353 Perl_croak(aTHX_ "Bad hash");
1354 xhv = (XPVHV*)SvANY(hv);
1355 entry = xhv->xhv_eiter;
1356 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1358 hv_free_ent(hv, entry);
1360 xhv->xhv_riter = -1;
1361 xhv->xhv_eiter = Null(HE*);
1362 return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
1366 =for apidoc hv_iternext
1368 Returns entries from a hash iterator. See C<hv_iterinit>.
1374 Perl_hv_iternext(pTHX_ HV *hv)
1376 register XPVHV* xhv;
1382 Perl_croak(aTHX_ "Bad hash");
1383 xhv = (XPVHV*)SvANY(hv);
1384 oldentry = entry = xhv->xhv_eiter;
1386 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1387 SV *key = sv_newmortal();
1389 sv_setsv(key, HeSVKEY_force(entry));
1390 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1396 xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
1398 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1400 HeKEY_hek(entry) = hek;
1401 HeKLEN(entry) = HEf_SVKEY;
1403 magic_nextpack((SV*) hv,mg,key);
1405 /* force key to stay around until next time */
1406 HeSVKEY_set(entry, SvREFCNT_inc(key));
1407 return entry; /* beware, hent_val is not set */
1410 SvREFCNT_dec(HeVAL(entry));
1411 Safefree(HeKEY_hek(entry));
1413 xhv->xhv_eiter = Null(HE*);
1416 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1417 if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1421 if (!xhv->xhv_array)
1422 Newz(506, xhv->xhv_array,
1423 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
1425 entry = HeNEXT(entry);
1428 if (xhv->xhv_riter > xhv->xhv_max) {
1429 xhv->xhv_riter = -1;
1432 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1435 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1437 hv_free_ent(hv, oldentry);
1440 xhv->xhv_eiter = entry;
1445 =for apidoc hv_iterkey
1447 Returns the key from the current position of the hash iterator. See
1454 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1456 if (HeKLEN(entry) == HEf_SVKEY) {
1458 char *p = SvPV(HeKEY_sv(entry), len);
1463 *retlen = HeKLEN(entry);
1464 return HeKEY(entry);
1468 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1470 =for apidoc hv_iterkeysv
1472 Returns the key as an C<SV*> from the current position of the hash
1473 iterator. The return value will always be a mortal copy of the key. Also
1480 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1482 if (HeKLEN(entry) == HEf_SVKEY)
1483 return sv_mortalcopy(HeKEY_sv(entry));
1485 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1486 HeKLEN_UTF8(entry), HeHASH(entry)));
1490 =for apidoc hv_iterval
1492 Returns the value from the current position of the hash iterator. See
1499 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1501 if (SvRMAGICAL(hv)) {
1502 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1503 SV* sv = sv_newmortal();
1504 if (HeKLEN(entry) == HEf_SVKEY)
1505 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1506 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1510 return HeVAL(entry);
1514 =for apidoc hv_iternextsv
1516 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1523 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1526 if ( (he = hv_iternext(hv)) == NULL)
1528 *key = hv_iterkey(he, retlen);
1529 return hv_iterval(hv, he);
1533 =for apidoc hv_magic
1535 Adds magic to a hash. See C<sv_magic>.
1541 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1543 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1547 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1549 return HEK_KEY(share_hek(sv, len, hash));
1552 /* possibly free a shared string if no one has access to it
1553 * len and hash must both be valid for str.
1556 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1558 register XPVHV* xhv;
1560 register HE **oentry;
1563 bool is_utf8 = FALSE;
1564 const char *save = str;
1569 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1570 STRLEN tmplen = len;
1571 /* See the note in hv_fetch(). --jhi */
1572 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1577 /* what follows is the moral equivalent of:
1578 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1579 if (--*Svp == Nullsv)
1580 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1582 xhv = (XPVHV*)SvANY(PL_strtab);
1583 /* assert(xhv_array != 0) */
1585 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1586 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1587 if (HeHASH(entry) != hash) /* strings can't be equal */
1589 if (HeKLEN(entry) != len)
1591 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1593 if (HeKUTF8(entry) != (char)is_utf8)
1596 if (--HeVAL(entry) == Nullsv) {
1597 *oentry = HeNEXT(entry);
1600 Safefree(HeKEY_hek(entry));
1606 UNLOCK_STRTAB_MUTEX;
1609 if (!found && ckWARN_d(WARN_INTERNAL))
1610 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1613 /* get a (constant) string ptr from the global string table
1614 * string will get added if it is not already there.
1615 * len and hash must both be valid for str.
1618 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1620 register XPVHV* xhv;
1622 register HE **oentry;
1625 bool is_utf8 = FALSE;
1626 const char *save = str;
1631 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1632 STRLEN tmplen = len;
1633 /* See the note in hv_fetch(). --jhi */
1634 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1639 /* what follows is the moral equivalent of:
1641 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1642 hv_store(PL_strtab, str, len, Nullsv, hash);
1644 xhv = (XPVHV*)SvANY(PL_strtab);
1645 /* assert(xhv_array != 0) */
1647 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1648 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1649 if (HeHASH(entry) != hash) /* strings can't be equal */
1651 if (HeKLEN(entry) != len)
1653 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1655 if (HeKUTF8(entry) != (char)is_utf8)
1662 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1663 HeVAL(entry) = Nullsv;
1664 HeNEXT(entry) = *oentry;
1667 if (i) { /* initial entry? */
1669 if (xhv->xhv_keys > xhv->xhv_max)
1674 ++HeVAL(entry); /* use value slot as REFCNT */
1675 UNLOCK_STRTAB_MUTEX;
1678 return HeKEY_hek(entry);