- 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;
https://perl5.git.perl.org / perl5.git / commitdiff