X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/570c4e91603ac3337464d8508243e4c088399778..ffb05e06c71730527accd4c1399a30e98fb7f6d5:/hv.c?ds=sidebyside diff --git a/hv.c b/hv.c index ece146d..ca945f6 100644 --- a/hv.c +++ b/hv.c @@ -1,7 +1,7 @@ /* hv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -80,6 +80,7 @@ S_more_he(pTHX) STATIC HEK * S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) { + int flags_masked = flags & HVhek_MASK; char *k; register HEK *hek; @@ -89,7 +90,10 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) HEK_KEY(hek)[len] = 0; HEK_LEN(hek) = len; HEK_HASH(hek) = hash; - HEK_FLAGS(hek) = (unsigned char)flags; + HEK_FLAGS(hek) = (unsigned char)flags_masked; + + if (flags & HVhek_FREEKEY) + Safefree(str); return hek; } @@ -168,290 +172,10 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot * contains an SV* */ -/* -=for apidoc hv_fetch - -Returns the SV which corresponds to the specified key in the hash. The -C is the length of the key. If C is set then the fetch will be -part of a store. Check that the return value is non-null before -dereferencing it to an C. - -See L for more -information on how to use this function on tied hashes. - -=cut -*/ - -#define HV_FETCH_LVALUE 0x01 -#define HV_FETCH_JUST_SV 0x02 - -SV** -Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval) -{ - HE *hek = hv_fetch_common (hv, NULL, key, klen, 0, - HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0), - 0); - return hek ? &HeVAL(hek) : NULL; -} - -/* returns an HE * structure with the all fields set */ -/* note that hent_val will be a mortal sv for MAGICAL hashes */ -/* -=for apidoc hv_fetch_ent - -Returns the hash entry which corresponds to the specified key in the hash. -C must be a valid precomputed hash number for the given C, or 0 -if you want the function to compute it. IF C is set then the fetch -will be part of a store. Make sure the return value is non-null before -accessing it. The return value when C is a tied hash is a pointer to a -static location, so be sure to make a copy of the structure if you need to -store it somewhere. - -See L for more -information on how to use this function on tied hashes. - -=cut -*/ - -HE * -Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) -{ - return hv_fetch_common(hv, keysv, NULL, 0, 0, lval ? HV_FETCH_LVALUE : 0, - hash); -} - -HE * -S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, - int flags, int action, register U32 hash) -{ - register XPVHV* xhv; - STRLEN klen; - register HE *entry; - SV *sv; - bool is_utf8; - const char *keysave; - int masked_flags; - - if (!hv) - return 0; - - if (keysv) { - key = SvPV(keysv, klen); - is_utf8 = (SvUTF8(keysv) != 0); - } else { - if (klen_i32 < 0) { - klen = -klen_i32; - is_utf8 = TRUE; - } else { - klen = klen_i32; - is_utf8 = FALSE; - } - } - keysave = key; - - if (SvRMAGICAL(hv)) { - if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { - sv = sv_newmortal(); - - /* XXX should be able to skimp on the HE/HEK here when - HV_FETCH_JUST_SV is true. */ - - if (!keysv) { - keysv = newSVpvn(key, klen); - if (is_utf8) { - SvUTF8_on(keysv); - } - } else { - keysv = newSVsv(keysv); - } - mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY); - - - /* grab a fake HE/HEK pair from the pool or make a new one */ - entry = PL_hv_fetch_ent_mh; - if (entry) - PL_hv_fetch_ent_mh = HeNEXT(entry); - else { - char *k; - entry = new_HE(); - New(54, k, HEK_BASESIZE + sizeof(SV*), char); - HeKEY_hek(entry) = (HEK*)k; - } - HeNEXT(entry) = Nullhe; - HeSVKEY_set(entry, keysv); - HeVAL(entry) = sv; - sv_upgrade(sv, SVt_PVLV); - LvTYPE(sv) = 'T'; - LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */ - - /* XXX remove at some point? */ - if (flags & HVhek_FREEKEY) - Safefree(key); - - return entry; - } -#ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { - U32 i; - for (i = 0; i < klen; ++i) - if (isLOWER(key[i])) { - SV *nkeysv = sv_2mortal(newSVpvn(key,klen)); - (void)strupr(SvPVX(nkeysv)); - entry = hv_fetch_common(hv, nkeysv, NULL, 0, 0, 0); - if (!entry && (action & HV_FETCH_LVALUE)) - entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash); - - /* XXX remove at some point? */ - if (flags & HVhek_FREEKEY) - Safefree(key); - - return entry; - } - } -#endif - } - - xhv = (XPVHV*)SvANY(hv); - if (!xhv->xhv_array /* !HvARRAY(hv) */) { - if ((action & HV_FETCH_LVALUE) -#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ - || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) -#endif - ) - Newz(503, xhv->xhv_array /* HvARRAY(hv) */, - PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), - char); - else { - /* XXX remove at some point? */ - if (flags & HVhek_FREEKEY) - Safefree(key); - - return 0; - } - } - - if (is_utf8) { - int oldflags = flags; - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); - if (is_utf8) - flags = HVhek_UTF8; - if (key != keysave) - flags |= HVhek_WASUTF8 | HVhek_FREEKEY; - if (oldflags & HVhek_FREEKEY) - Safefree(keysave); - - } - - if (HvREHASH(hv)) { - PERL_HASH_INTERNAL(hash, key, klen); - /* Yes, you do need this even though you are not "storing" because - you can flip the flags below if doing an lval lookup. (And that - was put in to give the semantics Andreas was expecting.) */ - flags |= HVhek_REHASH; - } else if (!hash) { - if (keysv && (SvIsCOW_shared_hash(keysv))) { - hash = SvUVX(keysv); - } else { - PERL_HASH(hash, key, klen); - } - } - - masked_flags = (flags & HVhek_MASK); - - /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; - for (; entry; entry = HeNEXT(entry)) { - if (HeHASH(entry) != hash) /* strings can't be equal */ - continue; - if (HeKLEN(entry) != (I32)klen) - continue; - if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ - continue; - if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) - continue; - if ((action & HV_FETCH_LVALUE) && HeKFLAGS(entry) != masked_flags) { - /* We match if HVhek_UTF8 bit in our flags and hash key's match. - But if entry was set previously with HVhek_WASUTF8 and key now - doesn't (or vice versa) then we should change the key's flag, - as this is assignment. */ - if (HvSHAREKEYS(hv)) { - /* Need to swap the key we have for a key with the flags we - need. As keys are shared we can't just write to the flag, - so we share the new one, unshare the old one. */ - HEK *new_hek = share_hek_flags(key, klen, hash, masked_flags); - unshare_hek (HeKEY_hek(entry)); - HeKEY_hek(entry) = new_hek; - } - else - HeKFLAGS(entry) = masked_flags; - if (masked_flags & HVhek_ENABLEHVKFLAGS) - HvHASKFLAGS_on(hv); - } - /* if we find a placeholder, we pretend we haven't found anything */ - if (HeVAL(entry) == &PL_sv_placeholder) - break; - if (flags & HVhek_FREEKEY) - Safefree(key); - return entry; - } -#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ - if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { - unsigned long len; - char *env = PerlEnv_ENVgetenv_len(key,&len); - if (env) { - /* XXX remove once common API complete */ - if (!keysv) { - nkeysv = sv_2mortal(newSVpvn(key,klen)); - } - - sv = newSVpvn(env,len); - SvTAINTED_on(sv); - if (flags & HVhek_FREEKEY) - Safefree(key); - return hv_store_ent(hv,keysv,sv,hash); - } - } -#endif - if (!entry && SvREADONLY(hv)) { - S_hv_notallowed(aTHX_ flags, key, klen, - "access disallowed key '%"SVf"' in" - ); - } - if (action & HV_FETCH_LVALUE) { - /* XXX remove once common API complete */ - if (!keysv) { - keysv = sv_2mortal(newSVpvn(key,klen)); - } - } - - if (flags & HVhek_FREEKEY) - Safefree(key); - if (action & HV_FETCH_LVALUE) { - /* gonna assign to this, so it better be there */ - sv = NEWSV(61,0); - return hv_store_ent(hv,keysv,sv,hash); - } - return 0; -} - -STATIC void -S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store) -{ - MAGIC *mg = SvMAGIC(hv); - *needs_copy = FALSE; - *needs_store = TRUE; - while (mg) { - if (isUPPER(mg->mg_type)) { - *needs_copy = TRUE; - switch (mg->mg_type) { - case PERL_MAGIC_tied: - case PERL_MAGIC_sig: - *needs_store = FALSE; - } - } - mg = mg->mg_moremagic; - } -} +#define HV_FETCH_ISSTORE 0x01 +#define HV_FETCH_ISEXISTS 0x02 +#define HV_FETCH_LVALUE 0x04 +#define HV_FETCH_JUST_SV 0x08 /* =for apidoc hv_store @@ -480,9 +204,21 @@ information on how to use this function on tied hashes. */ SV** -Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash) +Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) { - HE *hek = hv_store_common (hv, NULL, key, klen, 0, val, hash); + HE *hek; + STRLEN klen; + int flags; + + if (klen_i32 < 0) { + klen = -klen_i32; + flags = HVhek_UTF8; + } else { + klen = klen_i32; + flags = 0; + } + hek = hv_fetch_common (hv, NULL, key, klen, flags, + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0); return hek ? &HeVAL(hek) : NULL; } @@ -490,7 +226,8 @@ SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash, int flags) { - HE *hek = hv_store_common (hv, NULL, key, klen, flags, val, hash); + HE *hek = hv_fetch_common (hv, NULL, key, klen, flags, + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); return hek ? &HeVAL(hek) : NULL; } @@ -526,124 +263,366 @@ information on how to use this function on tied hashes. HE * Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) { - return hv_store_common(hv, keysv, NULL, 0, 0, val, hash); + return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash); +} + +/* +=for apidoc hv_exists + +Returns a boolean indicating whether the specified hash key exists. The +C is the length of the key. + +=cut +*/ + +bool +Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32) +{ + STRLEN klen; + int flags; + + if (klen_i32 < 0) { + klen = -klen_i32; + flags = HVhek_UTF8; + } else { + klen = klen_i32; + flags = 0; + } + return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0) + ? TRUE : FALSE; +} + +/* +=for apidoc hv_fetch + +Returns the SV which corresponds to the specified key in the hash. The +C is the length of the key. If C is set then the fetch will be +part of a store. Check that the return value is non-null before +dereferencing it to an C. + +See L for more +information on how to use this function on tied hashes. + +=cut +*/ + +SV** +Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) +{ + HE *hek; + STRLEN klen; + int flags; + + if (klen_i32 < 0) { + klen = -klen_i32; + flags = HVhek_UTF8; + } else { + klen = klen_i32; + flags = 0; + } + hek = hv_fetch_common (hv, NULL, key, klen, flags, + HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0), + Nullsv, 0); + return hek ? &HeVAL(hek) : NULL; +} + +/* +=for apidoc hv_exists_ent + +Returns a boolean indicating whether the specified hash key exists. C +can be a valid precomputed hash value, or 0 to ask for it to be +computed. + +=cut +*/ + +bool +Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) +{ + return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash) + ? TRUE : FALSE; } +/* returns an HE * structure with the all fields set */ +/* note that hent_val will be a mortal sv for MAGICAL hashes */ +/* +=for apidoc hv_fetch_ent + +Returns the hash entry which corresponds to the specified key in the hash. +C must be a valid precomputed hash number for the given C, or 0 +if you want the function to compute it. IF C is set then the fetch +will be part of a store. Make sure the return value is non-null before +accessing it. The return value when C is a tied hash is a pointer to a +static location, so be sure to make a copy of the structure if you need to +store it somewhere. + +See L for more +information on how to use this function on tied hashes. + +=cut +*/ + HE * -S_hv_store_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, - int flags, SV *val, U32 hash) +Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) +{ + return hv_fetch_common(hv, keysv, NULL, 0, 0, + (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash); +} + +STATIC HE * +S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, + int flags, int action, SV *val, register U32 hash) { XPVHV* xhv; - STRLEN klen; U32 n_links; HE *entry; HE **oentry; + SV *sv; bool is_utf8; - const char *keysave; + int masked_flags; if (!hv) return 0; if (keysv) { + if (flags & HVhek_FREEKEY) + Safefree(key); key = SvPV(keysv, klen); + flags = 0; is_utf8 = (SvUTF8(keysv) != 0); } else { - if (klen_i32 < 0) { - klen = -klen_i32; - is_utf8 = TRUE; - } else { - klen = klen_i32; - /* XXX Need to fix this one level out. */ - is_utf8 = (flags & HVhek_UTF8) ? TRUE : FALSE; - } + is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); } - keysave = key; xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { - bool needs_copy; - bool needs_store; - hv_magic_check (hv, &needs_copy, &needs_store); - if (needs_copy) { - bool save_taint = PL_tainted; - if (keysv || is_utf8) { + if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) + { + if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { + sv = sv_newmortal(); + + /* XXX should be able to skimp on the HE/HEK here when + HV_FETCH_JUST_SV is true. */ + if (!keysv) { keysv = newSVpvn(key, klen); - SvUTF8_on(keysv); + if (is_utf8) { + SvUTF8_on(keysv); + } + } else { + keysv = newSVsv(keysv); } - if (PL_tainting) - PL_tainted = SvTAINTED(keysv); - keysv = sv_2mortal(newSVsv(keysv)); - mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY); - } else { - mg_copy((SV*)hv, val, key, klen); + mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY); + + /* grab a fake HE/HEK pair from the pool or make a new one */ + entry = PL_hv_fetch_ent_mh; + if (entry) + PL_hv_fetch_ent_mh = HeNEXT(entry); + else { + char *k; + entry = new_HE(); + New(54, k, HEK_BASESIZE + sizeof(SV*), char); + HeKEY_hek(entry) = (HEK*)k; + } + HeNEXT(entry) = Nullhe; + HeSVKEY_set(entry, keysv); + HeVAL(entry) = sv; + sv_upgrade(sv, SVt_PVLV); + LvTYPE(sv) = 'T'; + /* so we can free entry when freeing sv */ + LvTARG(sv) = (SV*)entry; + + /* XXX remove at some point? */ + if (flags & HVhek_FREEKEY) + Safefree(key); + + return entry; } - - TAINT_IF(save_taint); - if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) { - if (flags & HVhek_FREEKEY) - Safefree(key); - return Nullhe; +#ifdef ENV_IS_CASELESS + else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + U32 i; + for (i = 0; i < klen; ++i) + if (isLOWER(key[i])) { + /* Would be nice if we had a routine to do the + copy and upercase in a single pass through. */ + char *nkey = strupr(savepvn(key,klen)); + /* Note that this fetch is for nkey (the uppercased + key) whereas the store is for key (the original) */ + entry = hv_fetch_common(hv, Nullsv, nkey, klen, + HVhek_FREEKEY, /* free nkey */ + 0 /* non-LVAL fetch */, + Nullsv /* no value */, + 0 /* compute hash */); + if (!entry && (action & HV_FETCH_LVALUE)) { + /* This call will free key if necessary. + Do it this way to encourage compiler to tail + call optimise. */ + entry = hv_fetch_common(hv, keysv, key, klen, + flags, HV_FETCH_ISSTORE, + NEWSV(61,0), hash); + } else { + if (flags & HVhek_FREEKEY) + Safefree(key); + } + return entry; + } } +#endif + } /* ISFETCH */ + else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { + if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { + SV* svret; + /* I don't understand why hv_exists_ent has svret and sv, + whereas hv_exists only had one. */ + svret = sv_newmortal(); + sv = sv_newmortal(); + + if (keysv || is_utf8) { + if (!keysv) { + keysv = newSVpvn(key, klen); + SvUTF8_on(keysv); + } else { + keysv = newSVsv(keysv); + } + mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY); + } else { + mg_copy((SV*)hv, sv, key, klen); + } + if (flags & HVhek_FREEKEY) + Safefree(key); + magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem)); + /* This cast somewhat evil, but I'm merely using NULL/ + not NULL to return the boolean exists. + And I know hv is not NULL. */ + return SvTRUE(svret) ? (HE *)hv : NULL; + } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + const char *keysave = key; + /* Will need to free this, so set FREEKEY flag. */ key = savepvn(key,klen); key = (const char*)strupr((char*)key); + is_utf8 = 0; hash = 0; - if (flags & HVhek_FREEKEY) - Safefree(keysave); - keysave = key; + if (flags & HVhek_FREEKEY) { + Safefree(keysave); + } + flags |= HVhek_FREEKEY; } #endif - } - } + } /* ISEXISTS */ + else if (action & HV_FETCH_ISSTORE) { + bool needs_copy; + bool needs_store; + hv_magic_check (hv, &needs_copy, &needs_store); + if (needs_copy) { + bool save_taint = PL_tainted; + if (keysv || is_utf8) { + if (!keysv) { + keysv = newSVpvn(key, klen); + SvUTF8_on(keysv); + } + if (PL_tainting) + PL_tainted = SvTAINTED(keysv); + keysv = sv_2mortal(newSVsv(keysv)); + mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY); + } else { + mg_copy((SV*)hv, val, key, klen); + } + TAINT_IF(save_taint); + if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) { + if (flags & HVhek_FREEKEY) + Safefree(key); + return Nullhe; + } +#ifdef ENV_IS_CASELESS + else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + const char *keysave = key; + /* Will need to free this, so set FREEKEY flag. */ + key = savepvn(key,klen); + key = (const char*)strupr((char*)key); + is_utf8 = 0; + hash = 0; + + if (flags & HVhek_FREEKEY) { + Safefree(keysave); + } + flags |= HVhek_FREEKEY; + } +#endif + } + } /* ISSTORE */ + } /* SvMAGICAL */ + + if (!xhv->xhv_array /* !HvARRAY(hv) */) { + if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) +#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ + || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) +#endif + ) + Newz(503, xhv->xhv_array /* HvARRAY(hv) */, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), + char); +#ifdef DYNAMIC_ENV_FETCH + else if (action & HV_FETCH_ISEXISTS) { + /* for an %ENV exists, if we do an insert it's by a recursive + store call, so avoid creating HvARRAY(hv) right now. */ + } +#endif + else { + /* XXX remove at some point? */ + if (flags & HVhek_FREEKEY) + Safefree(key); - if (flags & HVhek_PLACEHOLD) { - /* We have been requested to insert a placeholder. Currently - only Storable is allowed to do this. */ - val = &PL_sv_placeholder; + return 0; + } } if (is_utf8) { + const char *keysave = key; key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); - - if (flags & HVhek_FREEKEY) { - /* This shouldn't happen if our caller does what we expect, - but strictly the API allows it. */ - Safefree(keysave); - } - if (is_utf8) - flags |= HVhek_UTF8; - if (key != keysave) + flags |= HVhek_UTF8; + else + flags &= ~HVhek_UTF8; + if (key != keysave) { + if (flags & HVhek_FREEKEY) + Safefree(keysave); flags |= HVhek_WASUTF8 | HVhek_FREEKEY; - HvHASKFLAGS_on((SV*)hv); + } } if (HvREHASH(hv)) { + PERL_HASH_INTERNAL(hash, key, klen); /* We don't have a pointer to the hv, so we have to replicate the flag into every HEK, so that hv_iterkeysv can see it. */ + /* And yes, you do need this even though you are not "storing" because + you can flip the flags below if doing an lval lookup. (And that + was put in to give the semantics Andreas was expecting.) */ flags |= HVhek_REHASH; - PERL_HASH_INTERNAL(hash, key, klen); } else if (!hash) { - if (keysv && SvIsCOW_shared_hash(keysv)) { + if (keysv && (SvIsCOW_shared_hash(keysv))) { hash = SvUVX(keysv); } else { PERL_HASH(hash, key, klen); - } - } - - if (!xhv->xhv_array /* !HvARRAY(hv) */) - Newz(505, xhv->xhv_array /* HvARRAY(hv) */, - PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), - char); + } + } - /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; + masked_flags = (flags & HVhek_MASK); n_links = 0; - entry = *oentry; + +#ifdef DYNAMIC_ENV_FETCH + if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*); + else +#endif + { + /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ + entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; + } for (; entry; ++n_links, entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; @@ -651,43 +630,117 @@ S_hv_store_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; - if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8) + if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) continue; - if (HeVAL(entry) == &PL_sv_placeholder) - xhv->xhv_placeholders--; /* yes, can store into placeholder slot */ - else - SvREFCNT_dec(HeVAL(entry)); - HeVAL(entry) = val; - if (val == &PL_sv_placeholder) - xhv->xhv_placeholders++; - - if (HeKFLAGS(entry) != flags) { - /* We match if HVhek_UTF8 bit in our flags and hash key's match. - But if entry was set previously with HVhek_WASUTF8 and key now - doesn't (or vice versa) then we should change the key's flag, - as this is assignment. */ - if (HvSHAREKEYS(hv)) { - /* Need to swap the key we have for a key with the flags we - need. As keys are shared we can't just write to the flag, - so we share the new one, unshare the old one. */ - int flags_nofree = flags & ~HVhek_FREEKEY; - HEK *new_hek = share_hek_flags(key, klen, hash, flags_nofree); - unshare_hek (HeKEY_hek(entry)); - HeKEY_hek(entry) = new_hek; - } - else - HeKFLAGS(entry) = flags; - } - if (flags & HVhek_FREEKEY) + + if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) { + if (HeKFLAGS(entry) != masked_flags) { + /* We match if HVhek_UTF8 bit in our flags and hash key's + match. But if entry was set previously with HVhek_WASUTF8 + and key now doesn't (or vice versa) then we should change + the key's flag, as this is assignment. */ + if (HvSHAREKEYS(hv)) { + /* Need to swap the key we have for a key with the flags we + need. As keys are shared we can't just write to the + flag, so we share the new one, unshare the old one. */ + HEK *new_hek = share_hek_flags(key, klen, hash, + masked_flags); + unshare_hek (HeKEY_hek(entry)); + HeKEY_hek(entry) = new_hek; + } + else + HeKFLAGS(entry) = masked_flags; + if (masked_flags & HVhek_ENABLEHVKFLAGS) + HvHASKFLAGS_on(hv); + } + if (HeVAL(entry) == &PL_sv_placeholder) { + /* yes, can store into placeholder slot */ + if (action & HV_FETCH_LVALUE) { + if (SvMAGICAL(hv)) { + /* This preserves behaviour with the old hv_fetch + implementation which at this point would bail out + with a break; (at "if we find a placeholder, we + pretend we haven't found anything") + + That break mean that if a placeholder were found, it + caused a call into hv_store, which in turn would + check magic, and if there is no magic end up pretty + much back at this point (in hv_store's code). */ + break; + } + /* LVAL fetch which actaully needs a store. */ + val = NEWSV(61,0); + xhv->xhv_placeholders--; + } else { + /* store */ + if (val != &PL_sv_placeholder) + xhv->xhv_placeholders--; + } + HeVAL(entry) = val; + } else if (action & HV_FETCH_ISSTORE) { + SvREFCNT_dec(HeVAL(entry)); + HeVAL(entry) = val; + } + } else if (HeVAL(entry) == &PL_sv_placeholder) { + /* if we find a placeholder, we pretend we haven't found + anything */ + break; + } + if (flags & HVhek_FREEKEY) Safefree(key); return entry; } +#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ + if (!(action & HV_FETCH_ISSTORE) + && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { + unsigned long len; + char *env = PerlEnv_ENVgetenv_len(key,&len); + if (env) { + sv = newSVpvn(env,len); + SvTAINTED_on(sv); + return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv, + hash); + } + } +#endif - if (SvREADONLY(hv)) { + if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { S_hv_notallowed(aTHX_ flags, key, klen, - "access disallowed key '%"SVf"' to" + "access disallowed key '%"SVf"' in" ); } + if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) { + /* Not doing some form of store, so return failure. */ + if (flags & HVhek_FREEKEY) + Safefree(key); + return 0; + } + if (action & HV_FETCH_LVALUE) { + val = NEWSV(61,0); + if (SvMAGICAL(hv)) { + /* At this point the old hv_fetch code would call to hv_store, + which in turn might do some tied magic. So we need to make that + magic check happen. */ + /* gonna assign to this, so it better be there */ + return hv_fetch_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE, val, hash); + /* XXX Surely that could leak if the fetch-was-store fails? + Just like the hv_fetch. */ + } + } + + /* Welcome to hv_store... */ + + if (!xhv->xhv_array) { + /* Not sure if we can get here. I think the only case of oentry being + NULL is for %ENV with dynamic env fetch. But that should disappear + with magic in the previous code. */ + Newz(503, xhv->xhv_array /* HvARRAY(hv) */, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), + char); + } + + oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; entry = new_HE(); /* share_hek_flags will do the free for us. This might be considered @@ -702,6 +755,8 @@ S_hv_store_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, if (val == &PL_sv_placeholder) xhv->xhv_placeholders++; + if (masked_flags & HVhek_ENABLEHVKFLAGS) + HvHASKFLAGS_on(hv); xhv->xhv_keys++; /* HvKEYS(hv)++ */ if (!n_links) { /* initial entry? */ @@ -720,6 +775,54 @@ S_hv_store_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, return entry; } +STATIC void +S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store) +{ + MAGIC *mg = SvMAGIC(hv); + *needs_copy = FALSE; + *needs_store = TRUE; + while (mg) { + if (isUPPER(mg->mg_type)) { + *needs_copy = TRUE; + switch (mg->mg_type) { + case PERL_MAGIC_tied: + case PERL_MAGIC_sig: + *needs_store = FALSE; + } + } + mg = mg->mg_moremagic; + } +} + +/* +=for apidoc hv_scalar + +Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied. + +=cut +*/ + +SV * +Perl_hv_scalar(pTHX_ HV *hv) +{ + MAGIC *mg; + SV *sv; + + if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) { + sv = magic_scalarpack(hv, mg); + return sv; + } + + sv = sv_newmortal(); + if (HvFILL((HV*)hv)) + Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", + (long)HvFILL(hv), (long)HvMAX(hv) + 1); + else + sv_setiv(sv, 0); + + return sv; +} + /* =for apidoc hv_delete @@ -732,9 +835,18 @@ will be returned. */ SV * -Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) +Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags) { - return hv_delete_common(hv, NULL, key, klen, flags, 0); + STRLEN klen; + int k_flags = 0; + + if (klen_i32 < 0) { + klen = -klen_i32; + k_flags |= HVhek_UTF8; + } else { + klen = klen_i32; + } + return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0); } /* @@ -751,39 +863,33 @@ precomputed hash value, or 0 to ask for it to be computed. SV * Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) { - return hv_delete_common(hv, keysv, NULL, 0, flags, hash); + return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash); } -SV * -S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, - I32 flags, U32 hash) +STATIC SV * +S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, + int k_flags, I32 d_flags, U32 hash) { register XPVHV* xhv; register I32 i; - STRLEN klen; register HE *entry; register HE **oentry; SV *sv; bool is_utf8; - int k_flags = 0; - const char *keysave; + int masked_flags; if (!hv) return Nullsv; if (keysv) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); key = SvPV(keysv, klen); + k_flags = 0; is_utf8 = (SvUTF8(keysv) != 0); } else { - if (klen_i32 < 0) { - klen = -klen_i32; - is_utf8 = TRUE; - } else { - klen = klen_i32; - is_utf8 = FALSE; - } + is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE); } - keysave = key; if (SvRMAGICAL(hv)) { bool needs_copy; @@ -791,17 +897,10 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, hv_magic_check (hv, &needs_copy, &needs_store); if (needs_copy) { - sv = NULL; - if (keysv) { - if ((entry = hv_fetch_ent(hv, keysv, TRUE, hash))) { - sv = HeVAL(entry); - } - } else { - SV **svp; - if ((svp = hv_fetch(hv, key, is_utf8 ? -klen : klen, TRUE))) { - sv = *svp; - } - } + entry = hv_fetch_common(hv, keysv, key, klen, + k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE, + Nullsv, hash); + sv = entry ? HeVAL(entry) : NULL; if (sv) { if (SvMAGICAL(sv)) { mg_clear(sv); @@ -814,16 +913,20 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, } return Nullsv; /* element cannot be deleted */ } - } #ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - keysv = sv_2mortal(newSVpvn(key,klen)); - keysave = key = strupr(SvPVX(keysv)); - is_utf8 = 0; - hash = 0; - } + else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + keysv = sv_2mortal(newSVpvn(key,klen)); + if (k_flags & HVhek_FREEKEY) { + Safefree(key); + } + key = strupr(SvPVX(keysv)); + is_utf8 = 0; + k_flags = 0; + hash = 0; + } #endif + } } } xhv = (XPVHV*)SvANY(hv); @@ -831,19 +934,36 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, return Nullsv; if (is_utf8) { - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + const char *keysave = key; + key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + if (is_utf8) - k_flags = HVhek_UTF8; - if (key != keysave) - k_flags |= HVhek_FREEKEY; + k_flags |= HVhek_UTF8; + else + k_flags &= ~HVhek_UTF8; + if (key != keysave) { + if (k_flags & HVhek_FREEKEY) { + /* This shouldn't happen if our caller does what we expect, + but strictly the API allows it. */ + Safefree(keysave); + } + k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; + } + HvHASKFLAGS_on((SV*)hv); } if (HvREHASH(hv)) { PERL_HASH_INTERNAL(hash, key, klen); } else if (!hash) { - PERL_HASH(hash, key, klen); + if (keysv && (SvIsCOW_shared_hash(keysv))) { + hash = SvUVX(keysv); + } else { + PERL_HASH(hash, key, klen); + } } + masked_flags = (k_flags & HVhek_MASK); + /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; entry = *oentry; @@ -855,38 +975,25 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, continue; if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; - if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8) + if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) continue; - if (k_flags & HVhek_FREEKEY) - Safefree(key); /* if placeholder is here, it's already been deleted.... */ if (HeVAL(entry) == &PL_sv_placeholder) { - if (SvREADONLY(hv)) - return Nullsv; /* if still SvREADONLY, leave it deleted. */ - - /* okay, really delete the placeholder. */ - *oentry = HeNEXT(entry); - if (i && !*oentry) - xhv->xhv_fill--; /* HvFILL(hv)-- */ - if (entry == xhv->xhv_eiter /* HvEITER(hv) */) - HvLAZYDEL_on(hv); - else - hv_free_ent(hv, entry); - xhv->xhv_keys--; /* HvKEYS(hv)-- */ - if (xhv->xhv_keys == 0) - HvHASKFLAGS_off(hv); - xhv->xhv_placeholders--; - return Nullsv; + if (k_flags & HVhek_FREEKEY) + Safefree(key); + return Nullsv; } else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { S_hv_notallowed(aTHX_ k_flags, key, klen, "delete readonly key '%"SVf"' from" ); } + if (k_flags & HVhek_FREEKEY) + Safefree(key); - if (flags & G_DISCARD) + if (d_flags & G_DISCARD) sv = Nullsv; else { sv = sv_2mortal(HeVAL(entry)); @@ -900,6 +1007,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, * an error. */ if (SvREADONLY(hv)) { + SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = &PL_sv_placeholder; /* We'll be saving this slot, so the number of allocated keys * doesn't go down, but the number placeholders goes up */ @@ -929,160 +1037,6 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, return Nullsv; } -/* -=for apidoc hv_exists - -Returns a boolean indicating whether the specified hash key exists. The -C is the length of the key. - -=cut -*/ - -bool -Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen) -{ - return hv_exists_common(hv, NULL, key, klen, 0); -} - -/* -=for apidoc hv_exists_ent - -Returns a boolean indicating whether the specified hash key exists. C -can be a valid precomputed hash value, or 0 to ask for it to be -computed. - -=cut -*/ - -bool -Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) -{ - return hv_exists_common(hv, keysv, NULL, 0, hash); -} - -bool -S_hv_exists_common(pTHX_ HV *hv, SV *keysv, const char *key, I32 klen_i32, - U32 hash) -{ - register XPVHV* xhv; - STRLEN klen; - register HE *entry; - SV *sv; - bool is_utf8; - const char *keysave; - int k_flags = 0; - - if (!hv) - return 0; - - if (keysv) { - key = SvPV(keysv, klen); - is_utf8 = (SvUTF8(keysv) != 0); - } else { - if (klen_i32 < 0) { - klen = -klen_i32; - is_utf8 = TRUE; - } else { - klen = klen_i32; - is_utf8 = FALSE; - } - } - keysave = key; - - if (SvRMAGICAL(hv)) { - if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { - SV* svret; - - if (keysv || is_utf8) { - if (!keysv) { - keysv = newSVpvn(key, klen); - SvUTF8_on(keysv); - } else { - keysv = newSVsv(keysv); - } - key = (char *)sv_2mortal(keysv); - klen = HEf_SVKEY; - } - - /* I don't understand why hv_exists_ent has svret and sv, - whereas hv_exists only had one. */ - svret = sv_newmortal(); - sv = sv_newmortal(); - mg_copy((SV*)hv, sv, key, klen); - magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem)); - return (bool)SvTRUE(svret); - } -#ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - keysv = sv_2mortal(newSVpvn(key,klen)); - keysave = key = strupr(SvPVX(keysv)); - is_utf8 = 0; - hash = 0; - } -#endif - } - - xhv = (XPVHV*)SvANY(hv); -#ifndef DYNAMIC_ENV_FETCH - if (!xhv->xhv_array /* !HvARRAY(hv) */) - return 0; -#endif - - if (is_utf8) { - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); - if (is_utf8) - k_flags = HVhek_UTF8; - if (key != keysave) - k_flags |= HVhek_FREEKEY; - } - if (HvREHASH(hv)) { - PERL_HASH_INTERNAL(hash, key, klen); - } else if (!hash) - PERL_HASH(hash, key, klen); - -#ifdef DYNAMIC_ENV_FETCH - if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*); - else -#endif - /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; - for (; entry; entry = HeNEXT(entry)) { - if (HeHASH(entry) != hash) /* strings can't be equal */ - continue; - if (HeKLEN(entry) != (I32)klen) - continue; - if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ - continue; - if ((HeKFLAGS(entry) ^ k_flags) & HVhek_UTF8) - continue; - if (k_flags & HVhek_FREEKEY) - Safefree(key); - /* If we find the key, but the value is a placeholder, return false. */ - if (HeVAL(entry) == &PL_sv_placeholder) - return FALSE; - return TRUE; - } -#ifdef DYNAMIC_ENV_FETCH /* is it out there? */ - if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { - unsigned long len; - char *env = PerlEnv_ENVgetenv_len(key,&len); - if (env) { - sv = newSVpvn(env,len); - SvTAINTED_on(sv); - (void)hv_store_ent(hv,keysv,sv,hash); - if (k_flags & HVhek_FREEKEY) - Safefree(key); - return TRUE; - } - } -#endif - if (k_flags & HVhek_FREEKEY) - Safefree(key); - return FALSE; -} - - STATIC void S_hsplit(pTHX_ HV *hv) { @@ -1098,6 +1052,17 @@ S_hsplit(pTHX_ HV *hv) int longest_chain = 0; int was_shared; + /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n", + hv, (int) oldsize);*/ + + if (HvPLACEHOLDERS(hv) && !SvREADONLY(hv)) { + /* Can make this clear any placeholders first for non-restricted hashes, + even though Storable rebuilds restricted hashes by putting in all the + placeholders (first) before turning on the readonly flag, because + Storable always pre-splits the hash. */ + hv_clear_placeholders(hv); + } + PL_nomemok = TRUE; #if defined(STRANGE_MALLOC) || defined(MYMALLOC) Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); @@ -1494,7 +1459,7 @@ Perl_hv_clear(pTHX_ HV *hv) } } } - return; + goto reset; } hfreeentries(hv); @@ -1508,6 +1473,8 @@ Perl_hv_clear(pTHX_ HV *hv) HvHASKFLAGS_off(hv); HvREHASH_off(hv); + reset: + HvEITER(hv) = NULL; } /* @@ -1527,42 +1494,48 @@ See Hash::Util::lock_keys() for an example of its use. void Perl_hv_clear_placeholders(pTHX_ HV *hv) { - I32 items; - items = (I32)HvPLACEHOLDERS(hv); - if (items) { - HE *entry; - I32 riter = HvRITER(hv); - HE *eiter = HvEITER(hv); - hv_iterinit(hv); - /* This may look suboptimal with the items *after* the iternext, but - it's quite deliberate. We only get here with items==0 if we've - just deleted the last placeholder in the hash. If we've just done - that then it means that the hash is in lazy delete mode, and the - HE is now only referenced in our iterator. If we just quit the loop - and discarded our iterator then the HE leaks. So we do the && the - other way to ensure iternext is called just one more time, which - has the side effect of triggering the lazy delete. */ - while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) - && items) { - SV *val = hv_iterval(hv, entry); - - if (val == &PL_sv_placeholder) { - - /* It seems that I have to go back in the front of the hash - API to delete a hash, even though I have a HE structure - pointing to the very entry I want to delete, and could hold - onto the previous HE that points to it. And it's easier to - go in with SVs as I can then specify the precomputed hash, - and don't have fun and games with utf8 keys. */ - SV *key = hv_iterkeysv(entry); - - hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry)); - items--; - } - } - HvRITER(hv) = riter; - HvEITER(hv) = eiter; - } + I32 items = (I32)HvPLACEHOLDERS(hv); + I32 i = HvMAX(hv); + + if (items == 0) + return; + + do { + /* Loop down the linked list heads */ + int first = 1; + HE **oentry = &(HvARRAY(hv))[i]; + HE *entry = *oentry; + + if (!entry) + continue; + + for (; entry; entry = *oentry) { + if (HeVAL(entry) == &PL_sv_placeholder) { + *oentry = HeNEXT(entry); + if (first && !*oentry) + HvFILL(hv)--; /* This linked list is now empty. */ + if (HvEITER(hv)) + HvLAZYDEL_on(hv); + else + hv_free_ent(hv, entry); + + if (--items == 0) { + /* Finished. */ + HvTOTALKEYS(hv) -= HvPLACEHOLDERS(hv); + if (HvKEYS(hv) == 0) + HvHASKFLAGS_off(hv); + HvPLACEHOLDERS(hv) = 0; + return; + } + } else { + oentry = &HeNEXT(entry); + first = 0; + } + } + } while (--i >= 0); + /* You can't get here, hence assertion should always fail. */ + assert (items == 0); + assert (0); } STATIC void @@ -2043,9 +2016,10 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) UNLOCK_STRTAB_MUTEX; if (!found && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free non-existent shared string '%s'%s", + "Attempt to free non-existent shared string '%s'%s" + pTHX__FORMAT, hek ? HEK_KEY(hek) : str, - (k_flags & HVhek_UTF8) ? " (utf8)" : ""); + ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); if (k_flags & HVhek_FREEKEY) Safefree(str); } @@ -2118,7 +2092,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) } if (!found) { entry = new_HE(); - HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags); + HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked); HeVAL(entry) = Nullsv; HeNEXT(entry) = *oentry; *oentry = entry;