From: Nicholas Clark <nick@ccl4.org>
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