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;
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;
}
(lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
}
-HE *
+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)
{
return 0;
if (keysv) {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
key = SvPV(keysv, klen);
flags = 0;
is_utf8 = (SvUTF8(keysv) != 0);
U32 i;
for (i = 0; i < klen; ++i)
if (isLOWER(key[i])) {
- const char *keysave = key;
- /* Will need to free this, so set FREEKEY flag
- on call to hv_fetch_common. */
- key = savepvn(key,klen);
- key = (const char*)strupr((char*)key);
-
- if (flags & HVhek_FREEKEY)
- Safefree(keysave);
-
- /* This isn't strictly the same as the old hv_fetch
- magic, which made a call to hv_fetch, followed
- by a call to hv_store if that failed and lvalue
- was true.
- Which I believe could have been done by simply
- passing the lvalue through to the first hv_fetch.
- So I will do that here. */
- return hv_fetch_common(hv, Nullsv, key, klen,
- HVhek_FREEKEY,
- action, Nullsv, 0);
+ /* 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
else
#endif
{
- /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- entry = *oentry;
+ /* 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 */
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)) {
+ 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,keylen,HV_FETCH_ISSTORE,sv,
+ return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
hash);
}
}
/* Welcome to hv_store... */
- if (!oentry) {
+ 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];
}
+ 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
bad API design. */
}
/*
+=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
Deletes a key/value pair in the hash. The value SV is removed from the
return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
}
-SV *
+STATIC SV *
S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
int k_flags, I32 d_flags, U32 hash)
{
return Nullsv;
if (keysv) {
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
key = SvPV(keysv, klen);
k_flags = 0;
is_utf8 = (SvUTF8(keysv) != 0);
}
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));
- key = strupr(SvPVX(keysv));
-
- if (k_flags & HVhek_FREEKEY) {
- Safefree(keysave);
+ 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;
}
-
- is_utf8 = 0;
- k_flags = 0;
- hash = 0;
- }
#endif
+ }
}
}
xhv = (XPVHV*)SvANY(hv);
} else {
PERL_HASH(hash, key, klen);
}
- PERL_HASH(hash, key, klen);
}
masked_flags = (k_flags & HVhek_MASK);
}
}
}
- return;
+ goto reset;
}
hfreeentries(hv);
HvHASKFLAGS_off(hv);
HvREHASH_off(hv);
+ reset:
+ HvEITER(hv) = NULL;
}
/*
}
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff