From: Nicholas Clark Date: Wed, 19 Nov 2003 22:28:25 +0000 (+0000) Subject: merge hv_fetch and hv_fetch_ent into hv_fetch_common X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=113738bb099c38d994cf82554560490df0f6d525;p=p5sagit%2Fp5-mst-13.2.git merge hv_fetch and hv_fetch_ent into hv_fetch_common remove S_hv_fetch_flags hv.c now 13% smaller than when I started. hv_store TODO p4raw-id: //depot/perl@21753 --- diff --git a/embed.fnc b/embed.fnc index 0ca7dd4..32cb2f8 100644 --- a/embed.fnc +++ b/embed.fnc @@ -994,8 +994,6 @@ s |HEK* |save_hek_flags |const char *str|I32 len|U32 hash|int flags s |void |hv_magic_check |HV *hv|bool *needs_copy|bool *needs_store s |void |unshare_hek_or_pvn|HEK* hek|const char* sv|I32 len|U32 hash s |HEK* |share_hek_flags|const char* sv|I32 len|U32 hash|int flags -s |SV** |hv_fetch_flags |HV* tb|const char* key|I32 klen|I32 lval \ - |int flags s |void |hv_notallowed |int flags|const char *key|I32 klen|const char *msg #endif @@ -1398,6 +1396,7 @@ Apod |void |hv_assert |HV* tb #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) sM |SV* |hv_delete_common|HV* tb|SV* key_sv|const char* key|I32 klen|I32 flags|U32 hash sM |bool |hv_exists_common|HV* tb|SV* key_sv|const char* key|I32 klen|U32 hash +sM |HE* |hv_fetch_common|HV* tb|SV* key_sv|const char* key|I32 klen|int flags|int action|U32 hash #endif END_EXTERN_C diff --git a/embed.h b/embed.h index ce0cbd2..7a9889a 100644 --- a/embed.h +++ b/embed.h @@ -1313,9 +1313,6 @@ #define share_hek_flags S_share_hek_flags #endif #ifdef PERL_CORE -#define hv_fetch_flags S_hv_fetch_flags -#endif -#ifdef PERL_CORE #define hv_notallowed S_hv_notallowed #endif #endif @@ -2153,6 +2150,9 @@ #ifdef PERL_CORE #define hv_exists_common S_hv_exists_common #endif +#ifdef PERL_CORE +#define hv_fetch_common S_hv_fetch_common +#endif #endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop @@ -3804,9 +3804,6 @@ #define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d) #endif #ifdef PERL_CORE -#define hv_fetch_flags(a,b,c,d,e) S_hv_fetch_flags(aTHX_ a,b,c,d,e) -#endif -#ifdef PERL_CORE #define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d) #endif #endif @@ -4643,6 +4640,9 @@ #ifdef PERL_CORE #define hv_exists_common(a,b,c,d,e) S_hv_exists_common(aTHX_ a,b,c,d,e) #endif +#ifdef PERL_CORE +#define hv_fetch_common(a,b,c,d,e,f,g) S_hv_fetch_common(aTHX_ a,b,c,d,e,f,g) +#endif #endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) diff --git a/hv.c b/hv.c index 42cae8c..eb75a30 100644 --- a/hv.c +++ b/hv.c @@ -182,184 +182,16 @@ 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) { - bool is_utf8 = FALSE; - const char *keysave = key; - int flags = 0; - - if (klen < 0) { - klen = -klen; - is_utf8 = TRUE; - } - - if (is_utf8) { - STRLEN tmplen = klen; - /* Just casting the &klen to (STRLEN) won't work well - * if STRLEN and I32 are of different widths. --jhi */ - key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8); - klen = tmplen; - /* If we were able to downgrade here, then than means that we were - passed in a key which only had chars 0-255, but was utf8 encoded. */ - if (is_utf8) - flags = HVhek_UTF8; - /* If we found we were able to downgrade the string to bytes, then - we should flag that it needs upgrading on keys or each. */ - if (key != keysave) - flags |= HVhek_WASUTF8 | HVhek_FREEKEY; - } - - return hv_fetch_flags (hv, key, klen, lval, flags); -} - -STATIC SV** -S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags) -{ - register XPVHV* xhv; - register U32 hash; - register HE *entry; - SV *sv; - - if (!hv) - return 0; - - if (SvRMAGICAL(hv)) { - if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { - sv = sv_newmortal(); - sv_upgrade(sv, SVt_PVLV); - if (flags & HVhek_UTF8) { - /* This hack based on the code in hv_exists_ent seems to be - the easiest way to pass the utf8 flag through and fix - the bug in hv_exists for tied hashes with utf8 keys. */ - SV *keysv = sv_2mortal(newSVpvn(key, klen)); - SvUTF8_on(keysv); - mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY); - } else { - mg_copy((SV*)hv, sv, key, klen); - } - if (flags & HVhek_FREEKEY) - Safefree(key); - LvTYPE(sv) = 't'; - LvTARG(sv) = sv; /* fake (SV**) */ - return &(LvTARG(sv)); - } -#ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { - I32 i; - for (i = 0; i < klen; ++i) - if (isLOWER(key[i])) { - char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen)))); - SV **ret = hv_fetch(hv, nkey, klen, 0); - if (!ret && lval) { - ret = hv_store_flags(hv, key, klen, NEWSV(61,0), 0, - flags); - } else if (flags & HVhek_FREEKEY) - Safefree(key); - return ret; - } - } -#endif - } - - /* We use xhv->xhv_foo fields directly instead of HvFOO(hv) to - avoid unnecessary pointer dereferencing. */ - xhv = (XPVHV*)SvANY(hv); - if (!xhv->xhv_array /* !HvARRAY(hv) */) { - if (lval -#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 { - if (flags & HVhek_FREEKEY) - Safefree(key); - return 0; - } - } - - 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 { - PERL_HASH(hash, key, klen); - } - - /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; - for (; entry; entry = HeNEXT(entry)) { - if (!HeKEY_hek(entry)) - continue; - 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; - /* flags is 0 if not utf8. need HeKFLAGS(entry) also 0. - flags is 1 if utf8. need HeKFLAGS(entry) also 1. - xor is true if bits differ, in which case this isn't a match. */ - if ((HeKFLAGS(entry) ^ flags) & HVhek_UTF8) - continue; - if (lval && 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_ENABLEHVKFLAGS) - HvHASKFLAGS_on(hv); - } - if (flags & HVhek_FREEKEY) - Safefree(key); - /* if we find a placeholder, we pretend we haven't found anything */ - if (HeVAL(entry) == &PL_sv_placeholder) - break; - return &HeVAL(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) { - sv = newSVpvn(env,len); - SvTAINTED_on(sv); - if (flags & HVhek_FREEKEY) - Safefree(key); - return hv_store(hv,key,klen,sv,hash); - } - } -#endif - if (!entry && SvREADONLY(hv)) { - S_hv_notallowed(aTHX_ flags, key, klen, - "access disallowed key '%"SVf"' in" - ); - } - if (lval) { /* gonna assign to this, so it better be there */ - sv = NEWSV(61,0); - return hv_store_flags(hv,key,klen,sv,hash,flags); - } - if (flags & HVhek_FREEKEY) - Safefree(key); - return 0; + 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 */ @@ -384,23 +216,57 @@ information on how to use this function on tied hashes. 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; - register char *key; STRLEN klen; register HE *entry; SV *sv; bool is_utf8; - int flags = 0; - char *keysave; + 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(); - keysv = newSVsv(keysv); - mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); + + /* 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) @@ -417,29 +283,37 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) 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; - key = SvPV(keysv, klen); for (i = 0; i < klen; ++i) if (isLOWER(key[i])) { SV *nkeysv = sv_2mortal(newSVpvn(key,klen)); (void)strupr(SvPVX(nkeysv)); - entry = hv_fetch_ent(hv, nkeysv, 0, 0); - if (!entry && lval) + 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 } - keysave = key = SvPV(keysv, klen); xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array /* !HvARRAY(hv) */) { - if (lval + 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 @@ -447,18 +321,25 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) Newz(503, xhv->xhv_array /* HvARRAY(hv) */, PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), char); - else + else { + /* XXX remove at some point? */ + if (flags & HVhek_FREEKEY) + Safefree(key); + return 0; + } } - is_utf8 = (SvUTF8(keysv)!=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)) { @@ -468,13 +349,15 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) was put in to give the semantics Andreas was expecting.) */ flags |= HVhek_REHASH; } else if (!hash) { - if SvIsCOW_shared_hash(keysv) { + 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)) { @@ -484,9 +367,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) 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 (lval && HeKFLAGS(entry) != flags) { + 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, @@ -495,21 +378,20 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) /* 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); + HEK *new_hek = share_hek_flags(key, klen, hash, masked_flags); unshare_hek (HeKEY_hek(entry)); HeKEY_hek(entry) = new_hek; } else - HeKFLAGS(entry) = flags; - if (flags & HVhek_ENABLEHVKFLAGS) + HeKFLAGS(entry) = masked_flags; + if (masked_flags & HVhek_ENABLEHVKFLAGS) HvHASKFLAGS_on(hv); } - if (key != keysave) - Safefree(key); /* 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 */ @@ -517,8 +399,15 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) 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); } } @@ -528,9 +417,17 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) "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 (lval) { /* gonna assign to this, so it better be there */ + 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); } diff --git a/proto.h b/proto.h index 394ba1b..79795d7 100644 --- a/proto.h +++ b/proto.h @@ -952,7 +952,6 @@ STATIC HEK* S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags STATIC void S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store); STATIC void S_unshare_hek_or_pvn(pTHX_ HEK* hek, const char* sv, I32 len, U32 hash); STATIC HEK* S_share_hek_flags(pTHX_ const char* sv, I32 len, U32 hash, int flags); -STATIC SV** S_hv_fetch_flags(pTHX_ HV* tb, const char* key, I32 klen, I32 lval, int flags); STATIC void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg); #endif @@ -1338,6 +1337,7 @@ PERL_CALLCONV void Perl_hv_assert(pTHX_ HV* tb); #if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT) STATIC SV* S_hv_delete_common(pTHX_ HV* tb, SV* key_sv, const char* key, I32 klen, I32 flags, U32 hash); STATIC bool S_hv_exists_common(pTHX_ HV* tb, SV* key_sv, const char* key, I32 klen, U32 hash); +STATIC HE* S_hv_fetch_common(pTHX_ HV* tb, SV* key_sv, const char* key, I32 klen, int flags, int action, U32 hash); #endif END_EXTERN_C