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)
79 New(54, k, HEK_BASESIZE + len + 1, char);
81 Copy(str, HEK_KEY(hek), len, char);
82 *(HEK_KEY(hek) + len) = '\0';
89 Perl_unshare_hek(pTHX_ HEK *hek)
91 unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
94 #if defined(USE_ITHREADS)
96 Perl_he_dup(pTHX_ HE *e, bool shared)
102 /* look for it in the table first */
103 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
107 /* create anew and remember what it is */
109 ptr_table_store(PL_ptr_table, e, ret);
111 HeNEXT(ret) = he_dup(HeNEXT(e),shared);
112 if (HeKLEN(e) == HEf_SVKEY)
113 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
115 HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
117 HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
118 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
121 #endif /* USE_ITHREADS */
123 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
129 Returns the SV which corresponds to the specified key in the hash. The
130 C<klen> is the length of the key. If C<lval> is set then the fetch will be
131 part of a store. Check that the return value is non-null before
132 dereferencing it to a C<SV*>.
134 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
135 information on how to use this function on tied hashes.
141 Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
151 if (SvRMAGICAL(hv)) {
152 if (mg_find((SV*)hv,'P')) {
155 mg_copy((SV*)hv, sv, key, klen);
157 return &PL_hv_fetch_sv;
159 #ifdef ENV_IS_CASELESS
160 else if (mg_find((SV*)hv,'E')) {
162 for (i = 0; i < klen; ++i)
163 if (isLOWER(key[i])) {
164 char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
165 SV **ret = hv_fetch(hv, nkey, klen, 0);
167 ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
174 xhv = (XPVHV*)SvANY(hv);
175 if (!xhv->xhv_array) {
177 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
178 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
181 Newz(503, xhv->xhv_array,
182 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
187 PERL_HASH(hash, key, klen);
189 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
190 for (; entry; entry = HeNEXT(entry)) {
191 if (HeHASH(entry) != hash) /* strings can't be equal */
193 if (HeKLEN(entry) != klen)
195 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
197 return &HeVAL(entry);
199 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
200 if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
202 char *env = PerlEnv_ENVgetenv_len(key,&len);
204 sv = newSVpvn(env,len);
206 return hv_store(hv,key,klen,sv,hash);
210 if (lval) { /* gonna assign to this, so it better be there */
212 return hv_store(hv,key,klen,sv,hash);
217 /* returns a HE * structure with the all fields set */
218 /* note that hent_val will be a mortal sv for MAGICAL hashes */
220 =for apidoc hv_fetch_ent
222 Returns the hash entry which corresponds to the specified key in the hash.
223 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
224 if you want the function to compute it. IF C<lval> is set then the fetch
225 will be part of a store. Make sure the return value is non-null before
226 accessing it. The return value when C<tb> is a tied hash is a pointer to a
227 static location, so be sure to make a copy of the structure if you need to
230 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
231 information on how to use this function on tied hashes.
237 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
248 if (SvRMAGICAL(hv)) {
249 if (mg_find((SV*)hv,'P')) {
252 keysv = sv_2mortal(newSVsv(keysv));
253 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
254 if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
256 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
257 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
259 HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
260 HeVAL(&PL_hv_fetch_ent_mh) = sv;
261 return &PL_hv_fetch_ent_mh;
263 #ifdef ENV_IS_CASELESS
264 else if (mg_find((SV*)hv,'E')) {
266 key = SvPV(keysv, klen);
267 for (i = 0; i < klen; ++i)
268 if (isLOWER(key[i])) {
269 SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
270 (void)strupr(SvPVX(nkeysv));
271 entry = hv_fetch_ent(hv, nkeysv, 0, 0);
273 entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
280 xhv = (XPVHV*)SvANY(hv);
281 if (!xhv->xhv_array) {
283 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
284 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
287 Newz(503, xhv->xhv_array,
288 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
293 key = SvPV(keysv, klen);
296 PERL_HASH(hash, key, klen);
298 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
299 for (; entry; entry = HeNEXT(entry)) {
300 if (HeHASH(entry) != hash) /* strings can't be equal */
302 if (HeKLEN(entry) != klen)
304 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
308 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
309 if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
311 char *env = PerlEnv_ENVgetenv_len(key,&len);
313 sv = newSVpvn(env,len);
315 return hv_store_ent(hv,keysv,sv,hash);
319 if (lval) { /* gonna assign to this, so it better be there */
321 return hv_store_ent(hv,keysv,sv,hash);
327 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
329 MAGIC *mg = SvMAGIC(hv);
333 if (isUPPER(mg->mg_type)) {
335 switch (mg->mg_type) {
338 *needs_store = FALSE;
341 mg = mg->mg_moremagic;
348 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
349 the length of the key. The C<hash> parameter is the precomputed hash
350 value; if it is zero then Perl will compute it. The return value will be
351 NULL if the operation failed or if the value did not need to be actually
352 stored within the hash (as in the case of tied hashes). Otherwise it can
353 be dereferenced to get the original C<SV*>. Note that the caller is
354 responsible for suitably incrementing the reference count of C<val> before
355 the call, and decrementing it if the function returned NULL.
357 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
358 information on how to use this function on tied hashes.
364 Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
369 register HE **oentry;
374 xhv = (XPVHV*)SvANY(hv);
378 hv_magic_check (hv, &needs_copy, &needs_store);
380 mg_copy((SV*)hv, val, key, klen);
381 if (!xhv->xhv_array && !needs_store)
383 #ifdef ENV_IS_CASELESS
384 else if (mg_find((SV*)hv,'E')) {
385 SV *sv = sv_2mortal(newSVpvn(key,klen));
386 key = strupr(SvPVX(sv));
393 PERL_HASH(hash, key, klen);
396 Newz(505, xhv->xhv_array,
397 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
399 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
402 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
403 if (HeHASH(entry) != hash) /* strings can't be equal */
405 if (HeKLEN(entry) != klen)
407 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
409 SvREFCNT_dec(HeVAL(entry));
411 return &HeVAL(entry);
416 HeKEY_hek(entry) = share_hek(key, klen, hash);
417 else /* gotta do the real thing */
418 HeKEY_hek(entry) = save_hek(key, klen, hash);
420 HeNEXT(entry) = *oentry;
424 if (i) { /* initial entry? */
426 if (xhv->xhv_keys > xhv->xhv_max)
430 return &HeVAL(entry);
434 =for apidoc hv_store_ent
436 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
437 parameter is the precomputed hash value; if it is zero then Perl will
438 compute it. The return value is the new hash entry so created. It will be
439 NULL if the operation failed or if the value did not need to be actually
440 stored within the hash (as in the case of tied hashes). Otherwise the
441 contents of the return value can be accessed using the C<He???> macros
442 described here. Note that the caller is responsible for suitably
443 incrementing the reference count of C<val> before the call, and
444 decrementing it if the function returned NULL.
446 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
447 information on how to use this function on tied hashes.
453 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
460 register HE **oentry;
465 xhv = (XPVHV*)SvANY(hv);
470 hv_magic_check (hv, &needs_copy, &needs_store);
472 bool save_taint = PL_tainted;
474 PL_tainted = SvTAINTED(keysv);
475 keysv = sv_2mortal(newSVsv(keysv));
476 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
477 TAINT_IF(save_taint);
478 if (!xhv->xhv_array && !needs_store)
480 #ifdef ENV_IS_CASELESS
481 else if (mg_find((SV*)hv,'E')) {
482 key = SvPV(keysv, klen);
483 keysv = sv_2mortal(newSVpvn(key,klen));
484 (void)strupr(SvPVX(keysv));
491 key = SvPV(keysv, klen);
494 PERL_HASH(hash, key, klen);
497 Newz(505, xhv->xhv_array,
498 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
500 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
503 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
504 if (HeHASH(entry) != hash) /* strings can't be equal */
506 if (HeKLEN(entry) != klen)
508 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
510 SvREFCNT_dec(HeVAL(entry));
517 HeKEY_hek(entry) = share_hek(key, klen, hash);
518 else /* gotta do the real thing */
519 HeKEY_hek(entry) = save_hek(key, klen, hash);
521 HeNEXT(entry) = *oentry;
525 if (i) { /* initial entry? */
527 if (xhv->xhv_keys > xhv->xhv_max)
535 =for apidoc hv_delete
537 Deletes a key/value pair in the hash. The value SV is removed from the
538 hash and returned to the caller. The C<klen> is the length of the key.
539 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
546 Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
552 register HE **oentry;
558 if (SvRMAGICAL(hv)) {
561 hv_magic_check (hv, &needs_copy, &needs_store);
563 if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
567 if (mg_find(sv, 'p')) {
568 sv_unmagic(sv, 'p'); /* No longer an element */
571 return Nullsv; /* element cannot be deleted */
573 #ifdef ENV_IS_CASELESS
574 else if (mg_find((SV*)hv,'E')) {
575 sv = sv_2mortal(newSVpvn(key,klen));
576 key = strupr(SvPVX(sv));
581 xhv = (XPVHV*)SvANY(hv);
585 PERL_HASH(hash, key, klen);
587 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
590 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
591 if (HeHASH(entry) != hash) /* strings can't be equal */
593 if (HeKLEN(entry) != klen)
595 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
597 *oentry = HeNEXT(entry);
600 if (flags & G_DISCARD)
603 sv = sv_2mortal(HeVAL(entry));
604 HeVAL(entry) = &PL_sv_undef;
606 if (entry == xhv->xhv_eiter)
609 hv_free_ent(hv, entry);
617 =for apidoc hv_delete_ent
619 Deletes a key/value pair in the hash. The value SV is removed from the
620 hash and returned to the caller. The C<flags> value will normally be zero;
621 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
622 precomputed hash value, or 0 to ask for it to be computed.
628 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
635 register HE **oentry;
640 if (SvRMAGICAL(hv)) {
643 hv_magic_check (hv, &needs_copy, &needs_store);
645 if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
649 if (mg_find(sv, 'p')) {
650 sv_unmagic(sv, 'p'); /* No longer an element */
653 return Nullsv; /* element cannot be deleted */
655 #ifdef ENV_IS_CASELESS
656 else if (mg_find((SV*)hv,'E')) {
657 key = SvPV(keysv, klen);
658 keysv = sv_2mortal(newSVpvn(key,klen));
659 (void)strupr(SvPVX(keysv));
665 xhv = (XPVHV*)SvANY(hv);
669 key = SvPV(keysv, klen);
672 PERL_HASH(hash, key, klen);
674 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
677 for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
678 if (HeHASH(entry) != hash) /* strings can't be equal */
680 if (HeKLEN(entry) != klen)
682 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
684 *oentry = HeNEXT(entry);
687 if (flags & G_DISCARD)
690 sv = sv_2mortal(HeVAL(entry));
691 HeVAL(entry) = &PL_sv_undef;
693 if (entry == xhv->xhv_eiter)
696 hv_free_ent(hv, entry);
704 =for apidoc hv_exists
706 Returns a boolean indicating whether the specified hash key exists. The
707 C<klen> is the length of the key.
713 Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
723 if (SvRMAGICAL(hv)) {
724 if (mg_find((SV*)hv,'P')) {
727 mg_copy((SV*)hv, sv, key, klen);
728 magic_existspack(sv, mg_find(sv, 'p'));
731 #ifdef ENV_IS_CASELESS
732 else if (mg_find((SV*)hv,'E')) {
733 sv = sv_2mortal(newSVpvn(key,klen));
734 key = strupr(SvPVX(sv));
739 xhv = (XPVHV*)SvANY(hv);
740 #ifndef DYNAMIC_ENV_FETCH
745 PERL_HASH(hash, key, klen);
747 #ifdef DYNAMIC_ENV_FETCH
748 if (!xhv->xhv_array) entry = Null(HE*);
751 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
752 for (; entry; entry = HeNEXT(entry)) {
753 if (HeHASH(entry) != hash) /* strings can't be equal */
755 if (HeKLEN(entry) != klen)
757 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
761 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
762 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
764 char *env = PerlEnv_ENVgetenv_len(key,&len);
766 sv = newSVpvn(env,len);
768 (void)hv_store(hv,key,klen,sv,hash);
778 =for apidoc hv_exists_ent
780 Returns a boolean indicating whether the specified hash key exists. C<hash>
781 can be a valid precomputed hash value, or 0 to ask for it to be
788 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
799 if (SvRMAGICAL(hv)) {
800 if (mg_find((SV*)hv,'P')) {
801 dTHR; /* just for SvTRUE */
803 keysv = sv_2mortal(newSVsv(keysv));
804 mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
805 magic_existspack(sv, mg_find(sv, 'p'));
808 #ifdef ENV_IS_CASELESS
809 else if (mg_find((SV*)hv,'E')) {
810 key = SvPV(keysv, klen);
811 keysv = sv_2mortal(newSVpvn(key,klen));
812 (void)strupr(SvPVX(keysv));
818 xhv = (XPVHV*)SvANY(hv);
819 #ifndef DYNAMIC_ENV_FETCH
824 key = SvPV(keysv, klen);
826 PERL_HASH(hash, key, klen);
828 #ifdef DYNAMIC_ENV_FETCH
829 if (!xhv->xhv_array) entry = Null(HE*);
832 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
833 for (; entry; entry = HeNEXT(entry)) {
834 if (HeHASH(entry) != hash) /* strings can't be equal */
836 if (HeKLEN(entry) != klen)
838 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
842 #ifdef DYNAMIC_ENV_FETCH /* is it out there? */
843 if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
845 char *env = PerlEnv_ENVgetenv_len(key,&len);
847 sv = newSVpvn(env,len);
849 (void)hv_store_ent(hv,keysv,sv,hash);
858 S_hsplit(pTHX_ HV *hv)
860 register XPVHV* xhv = (XPVHV*)SvANY(hv);
861 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
862 register I32 newsize = oldsize * 2;
864 register char *a = xhv->xhv_array;
868 register HE **oentry;
871 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
872 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
878 #define MALLOC_OVERHEAD 16
879 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
884 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
886 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
889 Safefree(xhv->xhv_array);
893 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
894 xhv->xhv_max = --newsize;
898 for (i=0; i<oldsize; i++,aep++) {
899 if (!*aep) /* non-existent */
902 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
903 if ((HeHASH(entry) & newsize) != i) {
904 *oentry = HeNEXT(entry);
905 HeNEXT(entry) = *bep;
912 oentry = &HeNEXT(entry);
914 if (!*aep) /* everything moved */
920 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
922 register XPVHV* xhv = (XPVHV*)SvANY(hv);
923 I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
924 register I32 newsize;
930 register HE **oentry;
932 newsize = (I32) newmax; /* possible truncation here */
933 if (newsize != newmax || newmax <= oldsize)
935 while ((newsize & (1 + ~newsize)) != newsize) {
936 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
938 if (newsize < newmax)
940 if (newsize < newmax)
941 return; /* overflow detection */
946 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
947 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
953 New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
958 Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
960 offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
963 Safefree(xhv->xhv_array);
966 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
969 Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
971 xhv->xhv_max = --newsize;
973 if (!xhv->xhv_fill) /* skip rest if no entries */
977 for (i=0; i<oldsize; i++,aep++) {
978 if (!*aep) /* non-existent */
980 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
981 if ((j = (HeHASH(entry) & newsize)) != i) {
983 *oentry = HeNEXT(entry);
984 if (!(HeNEXT(entry) = aep[j]))
990 oentry = &HeNEXT(entry);
992 if (!*aep) /* everything moved */
1000 Creates a new HV. The reference count is set to 1.
1009 register XPVHV* xhv;
1011 hv = (HV*)NEWSV(502,0);
1012 sv_upgrade((SV *)hv, SVt_PVHV);
1013 xhv = (XPVHV*)SvANY(hv);
1016 #ifndef NODEFAULT_SHAREKEYS
1017 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1019 xhv->xhv_max = 7; /* start with 8 buckets */
1021 xhv->xhv_pmroot = 0;
1022 (void)hv_iterinit(hv); /* so each() will start off right */
1027 Perl_newHVhv(pTHX_ HV *ohv)
1030 STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1031 STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1034 while (hv_max && hv_max + 1 >= hv_fill * 2)
1035 hv_max = hv_max / 2; /* Is always 2^n-1 */
1041 if (! SvTIED_mg((SV*)ohv, 'P')) {
1048 I32 hv_riter = HvRITER(ohv); /* current root of iterator */
1049 HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
1053 while ((entry = hv_iternext(ohv))) {
1054 hv_store(hv, HeKEY(entry), HeKLEN(entry),
1055 SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
1057 HvRITER(ohv) = hv_riter;
1058 HvEITER(ohv) = hv_eiter;
1065 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1072 if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1073 PL_sub_generation++; /* may be deletion of method from stash */
1075 if (HeKLEN(entry) == HEf_SVKEY) {
1076 SvREFCNT_dec(HeKEY_sv(entry));
1077 Safefree(HeKEY_hek(entry));
1079 else if (HvSHAREKEYS(hv))
1080 unshare_hek(HeKEY_hek(entry));
1082 Safefree(HeKEY_hek(entry));
1087 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1091 if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1092 PL_sub_generation++; /* may be deletion of method from stash */
1093 sv_2mortal(HeVAL(entry)); /* free between statements */
1094 if (HeKLEN(entry) == HEf_SVKEY) {
1095 sv_2mortal(HeKEY_sv(entry));
1096 Safefree(HeKEY_hek(entry));
1098 else if (HvSHAREKEYS(hv))
1099 unshare_hek(HeKEY_hek(entry));
1101 Safefree(HeKEY_hek(entry));
1106 =for apidoc hv_clear
1108 Clears a hash, making it empty.
1114 Perl_hv_clear(pTHX_ HV *hv)
1116 register XPVHV* xhv;
1119 xhv = (XPVHV*)SvANY(hv);
1124 (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
1131 S_hfreeentries(pTHX_ HV *hv)
1133 register HE **array;
1135 register HE *oentry = Null(HE*);
1146 array = HvARRAY(hv);
1151 entry = HeNEXT(entry);
1152 hv_free_ent(hv, oentry);
1157 entry = array[riter];
1160 (void)hv_iterinit(hv);
1164 =for apidoc hv_undef
1172 Perl_hv_undef(pTHX_ HV *hv)
1174 register XPVHV* xhv;
1177 xhv = (XPVHV*)SvANY(hv);
1179 Safefree(xhv->xhv_array);
1181 Safefree(HvNAME(hv));
1185 xhv->xhv_max = 7; /* it's a normal hash */
1194 =for apidoc hv_iterinit
1196 Prepares a starting point to traverse a hash table. Returns the number of
1197 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1198 currently only meaningful for hashes without tie magic.
1200 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1201 hash buckets that happen to be in use. If you still need that esoteric
1202 value, you can get it through the macro C<HvFILL(tb)>.
1208 Perl_hv_iterinit(pTHX_ HV *hv)
1210 register XPVHV* xhv;
1214 Perl_croak(aTHX_ "Bad hash");
1215 xhv = (XPVHV*)SvANY(hv);
1216 entry = xhv->xhv_eiter;
1217 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1219 hv_free_ent(hv, entry);
1221 xhv->xhv_riter = -1;
1222 xhv->xhv_eiter = Null(HE*);
1223 return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
1227 =for apidoc hv_iternext
1229 Returns entries from a hash iterator. See C<hv_iterinit>.
1235 Perl_hv_iternext(pTHX_ HV *hv)
1237 register XPVHV* xhv;
1243 Perl_croak(aTHX_ "Bad hash");
1244 xhv = (XPVHV*)SvANY(hv);
1245 oldentry = entry = xhv->xhv_eiter;
1247 if ((mg = SvTIED_mg((SV*)hv, 'P'))) {
1248 SV *key = sv_newmortal();
1250 sv_setsv(key, HeSVKEY_force(entry));
1251 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1257 xhv->xhv_eiter = entry = new_HE(); /* one HE per MAGICAL hash */
1259 Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1261 HeKEY_hek(entry) = hek;
1262 HeKLEN(entry) = HEf_SVKEY;
1264 magic_nextpack((SV*) hv,mg,key);
1266 /* force key to stay around until next time */
1267 HeSVKEY_set(entry, SvREFCNT_inc(key));
1268 return entry; /* beware, hent_val is not set */
1271 SvREFCNT_dec(HeVAL(entry));
1272 Safefree(HeKEY_hek(entry));
1274 xhv->xhv_eiter = Null(HE*);
1277 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1278 if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1282 if (!xhv->xhv_array)
1283 Newz(506, xhv->xhv_array,
1284 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
1286 entry = HeNEXT(entry);
1289 if (xhv->xhv_riter > xhv->xhv_max) {
1290 xhv->xhv_riter = -1;
1293 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1296 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1298 hv_free_ent(hv, oldentry);
1301 xhv->xhv_eiter = entry;
1306 =for apidoc hv_iterkey
1308 Returns the key from the current position of the hash iterator. See
1315 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1317 if (HeKLEN(entry) == HEf_SVKEY) {
1319 char *p = SvPV(HeKEY_sv(entry), len);
1324 *retlen = HeKLEN(entry);
1325 return HeKEY(entry);
1329 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1331 =for apidoc hv_iterkeysv
1333 Returns the key as an C<SV*> from the current position of the hash
1334 iterator. The return value will always be a mortal copy of the key. Also
1341 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1343 if (HeKLEN(entry) == HEf_SVKEY)
1344 return sv_mortalcopy(HeKEY_sv(entry));
1346 return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
1347 HeKLEN(entry), HeHASH(entry)));
1352 =for apidoc hv_iterval
1354 Returns the value from the current position of the hash iterator. See
1361 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1363 if (SvRMAGICAL(hv)) {
1364 if (mg_find((SV*)hv,'P')) {
1365 SV* sv = sv_newmortal();
1366 if (HeKLEN(entry) == HEf_SVKEY)
1367 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1368 else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1372 return HeVAL(entry);
1376 =for apidoc hv_iternextsv
1378 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1385 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1388 if ( (he = hv_iternext(hv)) == NULL)
1390 *key = hv_iterkey(he, retlen);
1391 return hv_iterval(hv, he);
1395 =for apidoc hv_magic
1397 Adds magic to a hash. See C<sv_magic>.
1403 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1405 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1409 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1411 return HEK_KEY(share_hek(sv, len, hash));
1414 /* possibly free a shared string if no one has access to it
1415 * len and hash must both be valid for str.
1418 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1420 register XPVHV* xhv;
1422 register HE **oentry;
1426 /* what follows is the moral equivalent of:
1427 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1428 if (--*Svp == Nullsv)
1429 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1431 xhv = (XPVHV*)SvANY(PL_strtab);
1432 /* assert(xhv_array != 0) */
1434 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1435 for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1436 if (HeHASH(entry) != hash) /* strings can't be equal */
1438 if (HeKLEN(entry) != len)
1440 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1443 if (--HeVAL(entry) == Nullsv) {
1444 *oentry = HeNEXT(entry);
1447 Safefree(HeKEY_hek(entry));
1453 UNLOCK_STRTAB_MUTEX;
1457 if (!found && ckWARN_d(WARN_INTERNAL))
1458 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
1462 /* get a (constant) string ptr from the global string table
1463 * string will get added if it is not already there.
1464 * len and hash must both be valid for str.
1467 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1469 register XPVHV* xhv;
1471 register HE **oentry;
1475 /* what follows is the moral equivalent of:
1477 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1478 hv_store(PL_strtab, str, len, Nullsv, hash);
1480 xhv = (XPVHV*)SvANY(PL_strtab);
1481 /* assert(xhv_array != 0) */
1483 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1484 for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1485 if (HeHASH(entry) != hash) /* strings can't be equal */
1487 if (HeKLEN(entry) != len)
1489 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1496 HeKEY_hek(entry) = save_hek(str, len, hash);
1497 HeVAL(entry) = Nullsv;
1498 HeNEXT(entry) = *oentry;
1501 if (i) { /* initial entry? */
1503 if (xhv->xhv_keys > xhv->xhv_max)
1508 ++HeVAL(entry); /* use value slot as REFCNT */
1509 UNLOCK_STRTAB_MUTEX;
1510 return HeKEY_hek(entry);