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,'P')) {
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,'E')) {
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,'P')) {
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,'E')) {
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) {
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,'E')) {
438 SV *sv = sv_2mortal(newSVpvn(key,klen));
439 key = strupr(SvPVX(sv));
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,'E')) {
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, 'p')) {
651 sv_unmagic(sv, 'p'); /* No longer an element */
654 return Nullsv; /* element cannot be deleted */
656 #ifdef ENV_IS_CASELESS
657 else if (mg_find((SV*)hv,'E')) {
658 sv = sv_2mortal(newSVpvn(key,klen));
659 key = strupr(SvPVX(sv));
664 xhv = (XPVHV*)SvANY(hv);
668 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
669 STRLEN tmplen = klen;
670 /* See the note in hv_fetch(). --jhi */
671 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
675 PERL_HASH(hash, key, klen);
677 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
680 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
681 if (HeHASH(entry) != hash) /* strings can't be equal */
683 if (HeKLEN(entry) != klen)
685 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
687 if (HeKUTF8(entry) != (char)is_utf8)
691 *oentry = HeNEXT(entry);
694 if (flags & G_DISCARD)
697 sv = sv_2mortal(HeVAL(entry));
698 HeVAL(entry) = &PL_sv_undef;
700 if (entry == xhv->xhv_eiter)
703 hv_free_ent(hv, entry);
713 =for apidoc hv_delete_ent
715 Deletes a key/value pair in the hash. The value SV is removed from the
716 hash and returned to the caller. The C<flags> value will normally be zero;
717 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
718 precomputed hash value, or 0 to ask for it to be computed.
724 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
731 register HE **oentry;
738 if (SvRMAGICAL(hv)) {
741 hv_magic_check (hv, &needs_copy, &needs_store);
743 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
747 if (mg_find(sv, 'p')) {
748 sv_unmagic(sv, 'p'); /* No longer an element */
751 return Nullsv; /* element cannot be deleted */
753 #ifdef ENV_IS_CASELESS
754 else if (mg_find((SV*)hv,'E')) {
755 key = SvPV(keysv, klen);
756 keysv = sv_2mortal(newSVpvn(key,klen));
757 (void)strupr(SvPVX(keysv));
763 xhv = (XPVHV*)SvANY(hv);
767 keysave = key = SvPV(keysv, klen);
768 is_utf8 = (SvUTF8(keysv) != 0);
770 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
771 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
774 PERL_HASH(hash, key, klen);
776 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
779 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
780 if (HeHASH(entry) != hash) /* strings can't be equal */
782 if (HeKLEN(entry) != klen)
784 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
786 if (HeKUTF8(entry) != (char)is_utf8)
790 *oentry = HeNEXT(entry);
793 if (flags & G_DISCARD)
796 sv = sv_2mortal(HeVAL(entry));
797 HeVAL(entry) = &PL_sv_undef;
799 if (entry == xhv->xhv_eiter)
802 hv_free_ent(hv, entry);
812 =for apidoc hv_exists
814 Returns a boolean indicating whether the specified hash key exists. The
815 C<klen> is the length of the key.
821 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
827 bool is_utf8 = FALSE;
828 const char *keysave = key;
838 if (SvRMAGICAL(hv)) {
839 if (mg_find((SV*)hv,'P')) {
841 mg_copy((SV*)hv, sv, key, klen);
842 magic_existspack(sv, mg_find(sv, 'p'));
845 #ifdef ENV_IS_CASELESS
846 else if (mg_find((SV*)hv,'E')) {
847 sv = sv_2mortal(newSVpvn(key,klen));
848 key = strupr(SvPVX(sv));
853 xhv = (XPVHV*)SvANY(hv);
854 #ifndef DYNAMIC_ENV_FETCH
859 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
860 STRLEN tmplen = klen;
861 /* See the note in hv_fetch(). --jhi */
862 key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
866 PERL_HASH(hash, key, klen);
868 #ifdef DYNAMIC_ENV_FETCH
869 if (!xhv->xhv_array) entry = Null(HE*);
872 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
873 for (; entry; entry = HeNEXT(entry)) {
874 if (HeHASH(entry) != hash) /* strings can't be equal */
876 if (HeKLEN(entry) != klen)
878 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
880 if (HeKUTF8(entry) != (char)is_utf8)
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(hv,key,klen,sv,hash);
905 =for apidoc hv_exists_ent
907 Returns a boolean indicating whether the specified hash key exists. C<hash>
908 can be a valid precomputed hash value, or 0 to ask for it to be
915 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
928 if (SvRMAGICAL(hv)) {
929 if (mg_find((SV*)hv,'P')) {
931 keysv = sv_2mortal(newSVsv(keysv));
932 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
933 magic_existspack(sv, mg_find(sv, 'p'));
936 #ifdef ENV_IS_CASELESS
937 else if (mg_find((SV*)hv,'E')) {
938 key = SvPV(keysv, klen);
939 keysv = sv_2mortal(newSVpvn(key,klen));
940 (void)strupr(SvPVX(keysv));
946 xhv = (XPVHV*)SvANY(hv);
947 #ifndef DYNAMIC_ENV_FETCH
952 keysave = key = SvPV(keysv, klen);
953 is_utf8 = (SvUTF8(keysv) != 0);
954 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
955 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
957 PERL_HASH(hash, key, klen);
959 #ifdef DYNAMIC_ENV_FETCH
960 if (!xhv->xhv_array) entry = Null(HE*);
963 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
964 for (; entry; entry = HeNEXT(entry)) {
965 if (HeHASH(entry) != hash) /* strings can't be equal */
967 if (HeKLEN(entry) != klen)
969 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
971 if (HeKUTF8(entry) != (char)is_utf8)
977 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
978 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
980 char *env = PerlEnv_ENVgetenv_len(key,&len);
982 sv = newSVpvn(env,len);
984 (void)hv_store_ent(hv,keysv,sv,hash);
995 S_hsplit(pTHX_ HV *hv)
997 register XPVHV* xhv = (XPVHV*)SvANY(hv);
998 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
999 register I32 newsize = oldsize * 2;
1001 register char *a = xhv->xhv_array;
1005 register HE **oentry;
1008 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1009 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1015 #define MALLOC_OVERHEAD 16
1016 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1021 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
1022 if (oldsize >= 64) {
1023 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1026 Safefree(xhv->xhv_array);
1030 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1031 xhv->xhv_max = --newsize;
1035 for (i=0; i<oldsize; i++,aep++) {
1036 if (!*aep) /* non-existent */
1039 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1040 if ((HeHASH(entry) & newsize) != i) {
1041 *oentry = HeNEXT(entry);
1042 HeNEXT(entry) = *bep;
1049 oentry = &HeNEXT(entry);
1051 if (!*aep) /* everything moved */
1057 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1059 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1060 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
1061 register I32 newsize;
1067 register HE **oentry;
1069 newsize = (I32) newmax; /* possible truncation here */
1070 if (newsize != newmax || newmax <= oldsize)
1072 while ((newsize & (1 + ~newsize)) != newsize) {
1073 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1075 if (newsize < newmax)
1077 if (newsize < newmax)
1078 return; /* overflow detection */
1083 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1084 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1090 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1095 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
1096 if (oldsize >= 64) {
1097 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1100 Safefree(xhv->xhv_array);
1103 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1106 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1108 xhv->xhv_max = --newsize;
1110 if (!xhv->xhv_fill) /* skip rest if no entries */
1114 for (i=0; i<oldsize; i++,aep++) {
1115 if (!*aep) /* non-existent */
1117 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1118 if ((j = (HeHASH(entry) & newsize)) != i) {
1120 *oentry = HeNEXT(entry);
1121 if (!(HeNEXT(entry) = aep[j]))
1127 oentry = &HeNEXT(entry);
1129 if (!*aep) /* everything moved */
1137 Creates a new HV. The reference count is set to 1.
1146 register XPVHV* xhv;
1148 hv = (HV*)NEWSV(502,0);
1149 sv_upgrade((SV *)hv, SVt_PVHV);
1150 xhv = (XPVHV*)SvANY(hv);
1153 #ifndef NODEFAULT_SHAREKEYS
1154 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1156 xhv->xhv_max = 7; /* start with 8 buckets */
1158 xhv->xhv_pmroot = 0;
1159 (void)hv_iterinit(hv); /* so each() will start off right */
1164 Perl_newHVhv(pTHX_ HV *ohv)
1167 STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1168 STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1171 while (hv_max && hv_max + 1 >= hv_fill * 2)
1172 hv_max = hv_max / 2; /* Is always 2^n-1 */
1178 if (! SvTIED_mg((SV*)ohv, 'P')) {
1185 I32 hv_riter = HvRITER(ohv); /* current root of iterator */
1186 HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
1190 while ((entry = hv_iternext(ohv))) {
1191 hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
1192 newSVsv(HeVAL(entry)), HeHASH(entry));
1194 HvRITER(ohv) = hv_riter;
1195 HvEITER(ohv) = hv_eiter;
1202 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1209 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1210 PL_sub_generation++; /* may be deletion of method from stash */
1212 if (HeKLEN(entry) == HEf_SVKEY) {
1213 SvREFCNT_dec(HeKEY_sv(entry));
1214 Safefree(HeKEY_hek(entry));
1216 else if (HvSHAREKEYS(hv))
1217 unshare_hek(HeKEY_hek(entry));
1219 Safefree(HeKEY_hek(entry));
1224 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1228 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1229 PL_sub_generation++; /* may be deletion of method from stash */
1230 sv_2mortal(HeVAL(entry)); /* free between statements */
1231 if (HeKLEN(entry) == HEf_SVKEY) {
1232 sv_2mortal(HeKEY_sv(entry));
1233 Safefree(HeKEY_hek(entry));
1235 else if (HvSHAREKEYS(hv))
1236 unshare_hek(HeKEY_hek(entry));
1238 Safefree(HeKEY_hek(entry));
1243 =for apidoc hv_clear
1245 Clears a hash, making it empty.
1251 Perl_hv_clear(pTHX_ HV *hv)
1253 register XPVHV* xhv;
1256 xhv = (XPVHV*)SvANY(hv);
1261 (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
1268 S_hfreeentries(pTHX_ HV *hv)
1270 register HE **array;
1272 register HE *oentry = Null(HE*);
1283 array = HvARRAY(hv);
1288 entry = HeNEXT(entry);
1289 hv_free_ent(hv, oentry);
1294 entry = array[riter];
1297 (void)hv_iterinit(hv);
1301 =for apidoc hv_undef
1309 Perl_hv_undef(pTHX_ HV *hv)
1311 register XPVHV* xhv;
1314 xhv = (XPVHV*)SvANY(hv);
1316 Safefree(xhv->xhv_array);
1318 Safefree(HvNAME(hv));
1322 xhv->xhv_max = 7; /* it's a normal hash */
1331 =for apidoc hv_iterinit
1333 Prepares a starting point to traverse a hash table. Returns the number of
1334 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1335 currently only meaningful for hashes without tie magic.
1337 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1338 hash buckets that happen to be in use. If you still need that esoteric
1339 value, you can get it through the macro C<HvFILL(tb)>.
1345 Perl_hv_iterinit(pTHX_ HV *hv)
1347 register XPVHV* xhv;
1351 Perl_croak(aTHX_ "Bad hash");
1352 xhv = (XPVHV*)SvANY(hv);
1353 entry = xhv->xhv_eiter;
1354 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1356 hv_free_ent(hv, entry);
1358 xhv->xhv_riter = -1;
1359 xhv->xhv_eiter = Null(HE*);
1360 return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
1364 =for apidoc hv_iternext
1366 Returns entries from a hash iterator. See C<hv_iterinit>.
1372 Perl_hv_iternext(pTHX_ HV *hv)
1374 register XPVHV* xhv;
1380 Perl_croak(aTHX_ "Bad hash");
1381 xhv = (XPVHV*)SvANY(hv);
1382 oldentry = entry = xhv->xhv_eiter;
1384 if ((mg = SvTIED_mg((SV*)hv, 'P'))) {
1385 SV *key = sv_newmortal();
1387 sv_setsv(key, HeSVKEY_force(entry));
1388 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1394 xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
1396 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1398 HeKEY_hek(entry) = hek;
1399 HeKLEN(entry) = HEf_SVKEY;
1401 magic_nextpack((SV*) hv,mg,key);
1403 /* force key to stay around until next time */
1404 HeSVKEY_set(entry, SvREFCNT_inc(key));
1405 return entry; /* beware, hent_val is not set */
1408 SvREFCNT_dec(HeVAL(entry));
1409 Safefree(HeKEY_hek(entry));
1411 xhv->xhv_eiter = Null(HE*);
1414 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1415 if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1419 if (!xhv->xhv_array)
1420 Newz(506, xhv->xhv_array,
1421 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
1423 entry = HeNEXT(entry);
1426 if (xhv->xhv_riter > xhv->xhv_max) {
1427 xhv->xhv_riter = -1;
1430 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1433 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1435 hv_free_ent(hv, oldentry);
1438 xhv->xhv_eiter = entry;
1443 =for apidoc hv_iterkey
1445 Returns the key from the current position of the hash iterator. See
1452 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1454 if (HeKLEN(entry) == HEf_SVKEY) {
1456 char *p = SvPV(HeKEY_sv(entry), len);
1461 *retlen = HeKLEN(entry);
1462 return HeKEY(entry);
1466 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1468 =for apidoc hv_iterkeysv
1470 Returns the key as an C<SV*> from the current position of the hash
1471 iterator. The return value will always be a mortal copy of the key. Also
1478 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1480 if (HeKLEN(entry) == HEf_SVKEY)
1481 return sv_mortalcopy(HeKEY_sv(entry));
1483 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1484 HeKLEN_UTF8(entry), HeHASH(entry)));
1488 =for apidoc hv_iterval
1490 Returns the value from the current position of the hash iterator. See
1497 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1499 if (SvRMAGICAL(hv)) {
1500 if (mg_find((SV*)hv,'P')) {
1501 SV* sv = sv_newmortal();
1502 if (HeKLEN(entry) == HEf_SVKEY)
1503 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1504 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1508 return HeVAL(entry);
1512 =for apidoc hv_iternextsv
1514 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1521 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1524 if ( (he = hv_iternext(hv)) == NULL)
1526 *key = hv_iterkey(he, retlen);
1527 return hv_iterval(hv, he);
1531 =for apidoc hv_magic
1533 Adds magic to a hash. See C<sv_magic>.
1539 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1541 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1545 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1547 return HEK_KEY(share_hek(sv, len, hash));
1550 /* possibly free a shared string if no one has access to it
1551 * len and hash must both be valid for str.
1554 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1556 register XPVHV* xhv;
1558 register HE **oentry;
1561 bool is_utf8 = FALSE;
1562 const char *save = str;
1567 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1568 STRLEN tmplen = len;
1569 /* See the note in hv_fetch(). --jhi */
1570 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1575 /* what follows is the moral equivalent of:
1576 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1577 if (--*Svp == Nullsv)
1578 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1580 xhv = (XPVHV*)SvANY(PL_strtab);
1581 /* assert(xhv_array != 0) */
1583 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1584 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1585 if (HeHASH(entry) != hash) /* strings can't be equal */
1587 if (HeKLEN(entry) != len)
1589 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1591 if (HeKUTF8(entry) != (char)is_utf8)
1594 if (--HeVAL(entry) == Nullsv) {
1595 *oentry = HeNEXT(entry);
1598 Safefree(HeKEY_hek(entry));
1604 UNLOCK_STRTAB_MUTEX;
1607 if (!found && ckWARN_d(WARN_INTERNAL))
1608 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1611 /* get a (constant) string ptr from the global string table
1612 * string will get added if it is not already there.
1613 * len and hash must both be valid for str.
1616 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1618 register XPVHV* xhv;
1620 register HE **oentry;
1623 bool is_utf8 = FALSE;
1624 const char *save = str;
1629 if (!(PL_hints & HINT_UTF8_DISTINCT)) {
1630 STRLEN tmplen = len;
1631 /* See the note in hv_fetch(). --jhi */
1632 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1637 /* what follows is the moral equivalent of:
1639 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1640 hv_store(PL_strtab, str, len, Nullsv, hash);
1642 xhv = (XPVHV*)SvANY(PL_strtab);
1643 /* assert(xhv_array != 0) */
1645 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1646 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1647 if (HeHASH(entry) != hash) /* strings can't be equal */
1649 if (HeKLEN(entry) != len)
1651 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1653 if (HeKUTF8(entry) != (char)is_utf8)
1660 HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
1661 HeVAL(entry) = Nullsv;
1662 HeNEXT(entry) = *oentry;
1665 if (i) { /* initial entry? */
1667 if (xhv->xhv_keys > xhv->xhv_max)
1672 ++HeVAL(entry); /* use value slot as REFCNT */
1673 UNLOCK_STRTAB_MUTEX;
1676 return HeKEY_hek(entry);