/*
=for apidoc hv_store
-Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
-the length of the key. The C<hash> parameter is the precomputed hash
-value; if it is zero then Perl will compute it. The return value will be
+Stores an SV in a hash. The hash key is specified as C<key> and the
+absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode. The
+C<hash> parameter is the precomputed hash value; if it is zero then
+Perl will compute it.
+
+The return value will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise it can
be dereferenced to get the original C<SV*>. Note that the caller is
=for apidoc hv_exists
Returns a boolean indicating whether the specified hash key exists. The
-C<klen> is the length of the key.
+absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode.
=for apidoc hv_fetch
-Returns the SV which corresponds to the specified key in the hash. The
-C<klen> is the length of the key. If C<lval> is set then the fetch will be
-part of a store. Check that the return value is non-null before
-dereferencing it to an C<SV*>.
+Returns the SV which corresponds to the specified key in the hash.
+The absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode. If
+C<lval> is set then the fetch will be part of a store. Check that the
+return value is non-null before dereferencing it to an C<SV*>.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
if (!hv)
return NULL;
- if (SvTYPE(hv) == SVTYPEMASK)
+ if (SvTYPE(hv) == (svtype)SVTYPEMASK)
return NULL;
assert(SvTYPE(hv) == SVt_PVHV);
/*
=for apidoc hv_delete
-Deletes a key/value pair in the hash. The value's SV is removed from the
-hash, made mortal, and returned to the caller. The C<klen> is the length of
-the key. The C<flags> value will normally be zero; if set to G_DISCARD then
-NULL will be returned. NULL will also be returned if the key is not found.
+Deletes a key/value pair in the hash. The value's SV is removed from
+the hash, made mortal, and returned to the caller. The absolute
+value of C<klen> is the length of the key. If C<klen> is negative the
+key is assumed to be in UTF-8-encoded Unicode. The C<flags> value
+will normally be zero; if set to G_DISCARD then NULL will be returned.
+NULL will also be returned if the key is not found.
=for apidoc hv_delete_ent
Safefree(key);
return NULL;
}
- if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))
+ && !SvIsCOW(HeVAL(entry))) {
hv_notallowed(k_flags, key, klen,
"Attempt to delete readonly key '%"SVf"' from"
" a restricted hash");
mro_changes = 1;
}
- if (d_flags & G_DISCARD)
- sv = NULL;
+ if (d_flags & G_DISCARD) {
+ sv = HeVAL(entry);
+ HeVAL(entry) = &PL_sv_placeholder;
+ if (sv) {
+ /* deletion of method from stash */
+ if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
+ && HvENAME_get(hv))
+ mro_method_changed_in(hv);
+ SvREFCNT_dec(sv);
+ sv = NULL;
+ }
+ }
else {
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_placeholder;
* we can still access via not-really-existing key without raising
* an error.
*/
- if (SvREADONLY(hv)) {
- SvREFCNT_dec(HeVAL(entry));
- HeVAL(entry) = &PL_sv_placeholder;
+ if (SvREADONLY(hv))
/* We'll be saving this slot, so the number of allocated keys
* doesn't go down, but the number placeholders goes up */
HvPLACEHOLDERS(hv)++;
- } else {
+ else {
*oentry = HeNEXT(entry);
if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
- else
+ else {
+ if (SvOOK(hv) && HvLAZYDEL(hv) &&
+ entry == HeNEXT(HvAUX(hv)->xhv_eiter))
+ HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
hv_free_ent(hv, entry);
+ }
xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
if (xhv->xhv_keys == 0)
HvHASKFLAGS_off(hv);
return hv;
}
-void
-Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
+/* like hv_free_ent, but returns the SV rather than freeing it */
+STATIC SV*
+S_hv_free_ent_ret(pTHX_ HV *hv, register HE *entry)
{
dVAR;
SV *val;
- PERL_ARGS_ASSERT_HV_FREE_ENT;
+ PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
if (!entry)
- return;
+ return NULL;
val = HeVAL(entry);
if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvENAME(hv))
mro_method_changed_in(hv); /* deletion of method from stash */
else
Safefree(HeKEY_hek(entry));
del_HE(entry);
+ return val;
+}
+
+
+void
+Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
+{
+ dVAR;
+ SV *val;
+
+ PERL_ARGS_ASSERT_HV_FREE_ENT;
+
+ if (!entry)
+ return;
+ val = hv_free_ent_ret(hv, entry);
SvREFCNT_dec(val);
}
/*
=for apidoc hv_clear
-Clears a hash, making it empty.
+Frees the all the elements of a hash, leaving it empty.
+The XS equivalent of %hash = (). See also L</hv_undef>.
=cut
*/
for (; entry; entry = HeNEXT(entry)) {
/* not already placeholder */
if (HeVAL(entry) != &PL_sv_placeholder) {
- if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ if (HeVAL(entry) && SvREADONLY(HeVAL(entry))
+ && !SvIsCOW(HeVAL(entry))) {
SV* const keysv = hv_iterkeysv(entry);
Perl_croak(aTHX_
"Attempt to delete readonly key '%"SVf"' from a restricted hash",
*oentry = HeNEXT(entry);
if (entry == HvEITER_get(hv))
HvLAZYDEL_on(hv);
- else
+ else {
+ if (SvOOK(hv) && HvLAZYDEL(hv) &&
+ entry == HeNEXT(HvAUX(hv)->xhv_eiter))
+ HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
hv_free_ent(hv, entry);
+ }
if (--items == 0) {
/* Finished. */
STATIC void
S_hfreeentries(pTHX_ HV *hv)
{
- int attempts = 100;
- STRLEN i = 0;
- const bool mpm = PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv);
+ STRLEN index = 0;
+ XPVHV * const xhv = (XPVHV*)SvANY(hv);
+ SV *sv;
PERL_ARGS_ASSERT_HFREEENTRIES;
- if (!HvARRAY(hv))
- return;
+ while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
+ SvREFCNT_dec(sv);
+ }
+}
- /* keep looping until all keys are removed. This may take multiple
- * passes through the array, since destructors may add things back. */
- while (((XPVHV*)SvANY(hv))->xhv_keys) {
- struct xpvhv_aux *iter;
- HE *entry;
- HE ** array;
-
- if (SvOOK(hv) && ((iter = HvAUX(hv)))
- && ((entry = iter->xhv_eiter)) )
- {
- /* the iterator may get resurrected after each
- * destructor call, so check each time */
- if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
- HvLAZYDEL_off(hv);
- hv_free_ent(hv, entry);
- /* warning: at this point HvARRAY may have been
- * re-allocated, HvMAX changed etc */
- }
- iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
- iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
- }
+/* hfree_next_entry()
+ * For use only by S_hfreeentries() and sv_clear().
+ * Delete the next available HE from hv and return the associated SV.
+ * Returns null on empty hash. Nevertheless null is not a reliable
+ * indicator that the hash is empty, as the deleted entry may have a
+ * null value.
+ * indexp is a pointer to the current index into HvARRAY. The index should
+ * initially be set to 0. hfree_next_entry() may update it. */
- array = HvARRAY(hv);
- entry = array[i];
- if (entry) {
- /* Detach and free this entry. Note that destructors may be
- * called which will manipulate this hash, so make sure
- * its internal structure remains consistent throughout */
- array[i] = HeNEXT(entry);
- ((XPVHV*) SvANY(hv))->xhv_keys--;
-
- if ( mpm && HeVAL(entry) && isGV(HeVAL(entry))
- && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
- ) {
- STRLEN klen;
- const char * const key = HePV(entry,klen);
- if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
- || (klen == 1 && key[0] == ':')) {
- mro_package_moved(
- NULL, GvHV(HeVAL(entry)),
- (GV *)HeVAL(entry), 0
- );
- }
- }
+SV*
+Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
+{
+ struct xpvhv_aux *iter;
+ HE *entry;
+ HE ** array;
+#ifdef DEBUGGING
+ STRLEN orig_index = *indexp;
+#endif
+
+ PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
+
+ if (SvOOK(hv) && ((iter = HvAUX(hv)))
+ && ((entry = iter->xhv_eiter)) )
+ {
+ /* the iterator may get resurrected after each
+ * destructor call, so check each time */
+ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
+ HvLAZYDEL_off(hv);
hv_free_ent(hv, entry);
/* warning: at this point HvARRAY may have been
* re-allocated, HvMAX changed etc */
- continue;
}
- if (i++ >= HvMAX(hv)) {
- i = 0;
- if (--attempts == 0) {
- Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
- }
+ iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+ }
+
+ if (!((XPVHV*)SvANY(hv))->xhv_keys)
+ return NULL;
+
+ array = HvARRAY(hv);
+ assert(array);
+ while ( ! ((entry = array[*indexp])) ) {
+ if ((*indexp)++ >= HvMAX(hv))
+ *indexp = 0;
+ assert(*indexp != orig_index);
+ }
+ array[*indexp] = HeNEXT(entry);
+ ((XPVHV*) SvANY(hv))->xhv_keys--;
+
+ if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
+ && HeVAL(entry) && isGV(HeVAL(entry))
+ && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
+ ) {
+ STRLEN klen;
+ const char * const key = HePV(entry,klen);
+ if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
+ || (klen == 1 && key[0] == ':')) {
+ mro_package_moved(
+ NULL, GvHV(HeVAL(entry)),
+ (GV *)HeVAL(entry), 0
+ );
}
- } /* while */
+ }
+ return hv_free_ent_ret(hv, entry);
}
+
/*
=for apidoc hv_undef
-Undefines the hash.
+Undefines the hash. The XS equivalent of undef(%hash).
+
+As well as freeing all the elements of the hash (like hv_clear()), this
+also frees any auxiliary data and storage associated with the hash.
+See also L</hv_clear>.
=cut
*/
allocate an array for storing the effective name. We can skip that
during global destruction, as it does not matter where the CVs point
if they will be freed anyway. */
+ /* note that the code following prior to hfreeentries is duplicated
+ * in sv_clear(), and changes here should be done there too */
if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
if (PL_stashcache)
- (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
+ (void)hv_delete(PL_stashcache, name,
+ HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
+ G_DISCARD
+ );
hv_name_set(hv, NULL, 0, 0);
}
hfreeentries(hv);
mro_isa_changed_in(hv);
if (PL_stashcache)
(void)hv_delete(
- PL_stashcache, name, HvENAMELEN_get(hv), G_DISCARD
+ PL_stashcache, name,
+ HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
+ G_DISCARD
);
}
name = HvNAME(hv);
if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
if (name && PL_stashcache)
- (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
+ (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
hv_name_set(hv, NULL, 0, flags);
}
if((meta = aux->xhv_mro_meta)) {
SvREFCNT_dec(meta->mro_linear_current);
meta->mro_linear_current = NULL;
}
- if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
+ SvREFCNT_dec(meta->mro_nextmethod);
SvREFCNT_dec(meta->isa);
Safefree(meta);
aux->xhv_mro_meta = NULL;
+ sizeof(struct xpvhv_aux), char);
}
HvARRAY(hv) = (HE**) array;
- /* SvOOK_on(hv) attacks the IV flags. */
- SvFLAGS(hv) |= SVf_OOK;
+ SvOOK_on(hv);
iter = HvAUX(hv);
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
HEK **spot;
PERL_ARGS_ASSERT_HV_NAME_SET;
- PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
spot = &iter->xhv_name_u.xhvnameu_name;
}
PERL_HASH(hash, name, len);
- *spot = name ? share_hek(name, len, hash) : NULL;
+ *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
+}
+
+/*
+This is basically sv_eq_flags() in sv.c, but we avoid the magic
+and bytes checking.
+*/
+
+STATIC I32
+hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
+ if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
+ if (flags & SVf_UTF8)
+ return (bytes_cmp_utf8(
+ (const U8*)HEK_KEY(hek), HEK_LEN(hek),
+ (const U8*)pv, pvlen) == 0);
+ else
+ return (bytes_cmp_utf8(
+ (const U8*)pv, pvlen,
+ (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
+ }
+ else
+ return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
+ || memEQ(HEK_KEY(hek), pv, pvlen));
}
/*
U32 hash;
PERL_ARGS_ASSERT_HV_ENAME_ADD;
- PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
HEK **hekp = xhv_name + (count < 0 ? -count : count);
while (hekp-- > xhv_name)
if (
- HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
- ) {
+ (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
+ : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
+ ) {
if (hekp == xhv_name && count < 0)
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 *);
- (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, len, hash);
+ (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
}
else {
HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
if (
- existing_name && HEK_LEN(existing_name) == (I32)len
- && memEQ(HEK_KEY(existing_name), name, len)
+ existing_name && (
+ (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
+ : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
+ )
) return;
Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
aux->xhv_name_count = existing_name ? 2 : -2;
*aux->xhv_name_u.xhvnameu_names = existing_name;
- (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, len, hash);
+ (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
}
}
struct xpvhv_aux *aux;
PERL_ARGS_ASSERT_HV_ENAME_DELETE;
- PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
HEK **victim = namep + (count < 0 ? -count : count);
while (victim-- > namep + 1)
if (
- HEK_LEN(*victim) == (I32)len
- && memEQ(HEK_KEY(*victim), name, len)
+ (HEK_UTF8(*victim) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
+ : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
) {
unshare_hek_or_pvn(*victim, 0, 0, 0);
if (count < 0) ++aux->xhv_name_count;
return;
}
if (
- count > 0 && HEK_LEN(*namep) == (I32)len
- && memEQ(HEK_KEY(*namep),name,len)
+ count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
+ : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
) {
aux->xhv_name_count = -count;
}
}
else if(
- HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len
- && memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len)
+ (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
+ : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
+ memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
) {
HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
}
#endif
- /* hv_iterint now ensures this. */
+ /* hv_iterinit now ensures this. */
assert (HvARRAY(hv));
/* At start of hash, entry is NULL. */
or if we run through it and find only placeholders. */
}
}
+ else iter->xhv_riter = -1;
if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
HvLAZYDEL_off(hv);
if (!entry)
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free non-existent shared string '%s'%s"
+ "Attempt to free nonexistent shared string '%s'%s"
pTHX__FORMAT,
hek ? HEK_KEY(hek) : str,
((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
/* If we found we were able to downgrade the string to bytes, then
we should flag that it needs upgrading on keys or each. Also flag
that we need share_hek_flags to free the string. */
- if (str != save)
+ if (str != save) {
+ PERL_HASH(hash, str, len);
flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
}
return share_hek_flags (str, len, hash, flags);
/* We don't actually store a HE from the arena and a regular HEK.
Instead we allocate one chunk of memory big enough for both,
and put the HEK straight after the HE. This way we can find the
- HEK directly from the HE.
+ HE directly from the HEK.
*/
Newx(k, STRUCT_OFFSET(struct shared_he,
struct refcounted_he *
Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
{
+ dVAR;
if (he) {
HINTS_REFCNT_LOCK;
he->refcounted_he_refcnt++;
return he;
}
+/*
+=for apidoc cop_fetch_label
+
+Returns the label attached to a cop.
+The flags pointer may be set to C<SVf_UTF8> or 0.
+
+=cut
+*/
+
/* pp_entereval is aware that labels are stored with a key ':' at the top of
the linked list. */
const char *
-Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
+Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
struct refcounted_he *const chain = cop->cop_hints_hash;
- PERL_ARGS_ASSERT_FETCH_COP_LABEL;
+ PERL_ARGS_ASSERT_COP_FETCH_LABEL;
if (!chain)
return NULL;
return chain->refcounted_he_data + 1;
}
+/*
+=for apidoc cop_store_label
+
+Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
+for a utf-8 label.
+
+=cut
+*/
+
void
-Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
+Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
U32 flags)
{
SV *labelsv;
- PERL_ARGS_ASSERT_STORE_COP_LABEL;
+ PERL_ARGS_ASSERT_COP_STORE_LABEL;
if (flags & ~(SVf_UTF8))
- Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
+ Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
(UV)flags);
labelsv = newSVpvn_flags(label, len, SVs_TEMP);
if (flags & SVf_UTF8)
https://perl5.git.perl.org / perl5.git / blobdiff