STATIC HE*
S_new_he(pTHX)
{
- dVAR;
HE* he;
void ** const root = &PL_body_roots[HE_SVSLOT];
void
Perl_free_tied_hv_pool(pTHX)
{
- dVAR;
HE *he = PL_hv_fetch_ent_mh;
while (he) {
HE * const ohe = he;
bool is_utf8;
int masked_flags;
const int return_svp = action & HV_FETCH_JUST_SV;
+ HEK *keysv_hek = NULL;
if (!hv)
return NULL;
}
}
- if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv)))
- hash = SvSHARED_HASH(keysv);
- else
- PERL_HASH(hash, key, klen);
+ if (keysv && (SvIsCOW_shared_hash(keysv))) {
+ if (HvSHAREKEYS(hv))
+ keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
+ hash = SvSHARED_HASH(keysv);
}
+ else if (!hash)
+ PERL_HASH(hash, key, klen);
masked_flags = (flags & HVhek_MASK);
{
entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
}
+
+ if (!entry)
+ goto not_found;
+
+ if (keysv_hek) {
+ /* keysv is actually a HEK in disguise, so we can match just by
+ * comparing the HEK pointers in the HE chain. There is a slight
+ * caveat: on something like "\x80", which has both plain and utf8
+ * representations, perl's hashes do encoding-insensitive lookups,
+ * but preserve the encoding of the stored key. Thus a particular
+ * key could map to two different HEKs in PL_strtab. We only
+ * conclude 'not found' if all the flags are the same; otherwise
+ * we fall back to a full search (this should only happen in rare
+ * cases).
+ */
+ int keysv_flags = HEK_FLAGS(keysv_hek);
+ HE *orig_entry = entry;
+
+ for (; entry; entry = HeNEXT(entry)) {
+ HEK *hek = HeKEY_hek(entry);
+ if (hek == keysv_hek)
+ goto found;
+ if (HEK_FLAGS(hek) != keysv_flags)
+ break; /* need to do full match */
+ }
+ if (!entry)
+ goto not_found;
+ /* failed on shortcut - do full search loop */
+ entry = orig_entry;
+ }
+
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? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
continue;
+ found:
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
}
return entry;
}
+
+ not_found:
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (!(action & HV_FETCH_ISSTORE)
&& SvRMAGICAL((const SV *)hv)
XPVHV* xhv;
HE *entry;
HE **oentry;
- HE *const *first_entry;
+ HE **first_entry;
bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
int masked_flags;
+ HEK *keysv_hek = NULL;
+ U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
+ SV *sv;
+ GV *gv = NULL;
+ HV *stash = NULL;
if (SvRMAGICAL(hv)) {
bool needs_copy;
HvHASKFLAGS_on(MUTABLE_SV(hv));
}
- if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv)))
- hash = SvSHARED_HASH(keysv);
- else
- PERL_HASH(hash, key, klen);
+ if (keysv && (SvIsCOW_shared_hash(keysv))) {
+ if (HvSHAREKEYS(hv))
+ keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv));
+ hash = SvSHARED_HASH(keysv);
}
+ else if (!hash)
+ PERL_HASH(hash, key, klen);
masked_flags = (k_flags & HVhek_MASK);
first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
entry = *oentry;
- for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
- SV *sv;
- U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
- GV *gv = NULL;
- HV *stash = NULL;
+ if (!entry)
+ goto not_found;
+
+ if (keysv_hek) {
+ /* keysv is actually a HEK in disguise, so we can match just by
+ * comparing the HEK pointers in the HE chain. There is a slight
+ * caveat: on something like "\x80", which has both plain and utf8
+ * representations, perl's hashes do encoding-insensitive lookups,
+ * but preserve the encoding of the stored key. Thus a particular
+ * key could map to two different HEKs in PL_strtab. We only
+ * conclude 'not found' if all the flags are the same; otherwise
+ * we fall back to a full search (this should only happen in rare
+ * cases).
+ */
+ int keysv_flags = HEK_FLAGS(keysv_hek);
+
+ for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
+ HEK *hek = HeKEY_hek(entry);
+ if (hek == keysv_hek)
+ goto found;
+ if (HEK_FLAGS(hek) != keysv_flags)
+ break; /* need to do full match */
+ }
+ if (!entry)
+ goto not_found;
+ /* failed on shortcut - do full search loop */
+ oentry = first_entry;
+ entry = *oentry;
+ }
+
+ for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
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? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
continue;
+ found:
if (hv == PL_strtab) {
if (k_flags & HVhek_FREEKEY)
Safefree(key);
return sv;
}
+
+ not_found:
if (SvREADONLY(hv)) {
hv_notallowed(k_flags, key, klen,
"Attempt to delete disallowed key '%"SVf"' from"
STATIC void
S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
{
- dVAR;
STRLEN i = 0;
char *a = (char*) HvARRAY(hv);
HE **aep;
dest->xhv_fill_lazy = 0;
} else {
/* no existing aux structure, but we allocated space for one
- * so intialize it properly. This unrolls hv_auxinit() a bit,
+ * so initialize it properly. This unrolls hv_auxinit() a bit,
* since we have to do the realloc anyway. */
/* first we set the iterator's xhv_rand so it can be copied into lastrand below */
#ifdef PERL_HASH_RANDOMIZE_KEYS
void
Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
{
- dVAR;
XPVHV* xhv = (XPVHV*)SvANY(hv);
const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
I32 newsize;
STATIC SV*
S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
{
- dVAR;
SV *val;
PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
void
Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
{
- dVAR;
SV *val;
PERL_ARGS_ASSERT_HV_FREE_ENT;
void
Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
{
- dVAR;
-
PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
if (!entry)
void
Perl_hv_clear_placeholders(pTHX_ HV *hv)
{
- dVAR;
const U32 items = (U32)HvPLACEHOLDERS_get(hv);
PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
} while (--i >= 0);
/* You can't get here, hence assertion should always fail. */
assert (items == 0);
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
}
STATIC void
void
Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
{
- dVAR;
XPVHV* xhv;
bool save;
{
PERL_ARGS_ASSERT_HV_ITERINIT;
- /* FIXME: Are we not NULL, or do we croak? Place bets now! */
-
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
if (SvOOK(hv)) {
struct xpvhv_aux * iter = HvAUX(hv);
HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
PERL_ARGS_ASSERT_HV_RITER_P;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
return &(iter->xhv_riter);
}
PERL_ARGS_ASSERT_HV_EITER_P;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
return &(iter->xhv_eiter);
}
PERL_ARGS_ASSERT_HV_RITER_SET;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
if (SvOOK(hv)) {
iter = HvAUX(hv);
} else {
PERL_ARGS_ASSERT_HV_RAND_SET;
#ifdef PERL_HASH_RANDOMIZE_KEYS
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
if (SvOOK(hv)) {
iter = HvAUX(hv);
} else {
PERL_ARGS_ASSERT_HV_EITER_SET;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
if (SvOOK(hv)) {
iter = HvAUX(hv);
} else {
PERL_HASH(hash, name, len);
if (aux->xhv_name_count) {
- HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
I32 count = aux->xhv_name_count;
- HEK **hekp = xhv_name + (count < 0 ? -count : count);
+ HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0);
+ HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count);
while (hekp-- > xhv_name)
+ {
+ assert(*hekp);
if (
(HEK_UTF8(*hekp) || (flags & SVf_UTF8))
? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
aux->xhv_name_count = -count;
return;
}
+ }
if (count < 0) aux->xhv_name_count--, count = -count;
else aux->xhv_name_count++;
Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
void
Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
{
- dVAR;
struct xpvhv_aux *aux;
PERL_ARGS_ASSERT_HV_ENAME_DELETE;
AV **
Perl_hv_backreferences_p(pTHX_ HV *hv) {
- struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
-
PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
-
- return &(iter->xhv_backreferences);
+ /* See also Perl_sv_get_backrefs in sv.c where this logic is unrolled */
+ {
+ struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
+ return &(iter->xhv_backreferences);
+ }
}
void
PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
- if (!hv)
- Perl_croak(aTHX_ "Bad hash");
-
xhv = (XPVHV*)SvANY(hv);
if (!SvOOK(hv)) {
STATIC void
S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
{
- dVAR;
XPVHV* xhv;
HE *entry;
HE **oentry;
STATIC HEK *
S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
{
- dVAR;
HE *entry;
const int flags_masked = flags & HVhek_MASK;
const U32 hindex = hash & (I32) HvMAX(PL_strtab);
SSize_t *
Perl_hv_placeholders_p(pTHX_ HV *hv)
{
- dVAR;
MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
I32
Perl_hv_placeholders_get(pTHX_ const HV *hv)
{
- dVAR;
MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
void
Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
{
- dVAR;
MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
void
Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+#ifdef USE_ITHREADS
dVAR;
+#endif
PERL_UNUSED_CONTEXT;
while (he) {
struct refcounted_he *
Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
PERL_UNUSED_CONTEXT;
if (he) {
HINTS_REFCNT_LOCK;
https://perl5.git.perl.org / perl5.git / blobdiff