if (!hv)
return NULL;
- if (SvTYPE(hv) == SVTYPEMASK)
+ if (SvTYPE(hv) == (svtype)SVTYPEMASK)
return NULL;
assert(SvTYPE(hv) == SVt_PVHV);
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;
- else {
- sv = sv_2mortal(HeVAL(entry));
- HeVAL(entry) = &PL_sv_placeholder;
- }
+ if (d_flags & G_DISCARD) {
+ sv = HeVAL(entry);
+ 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;
/*
* If a restricted hash, rather than really deleting the entry, put
* 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)
{
- 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;
- } /* while */
+ 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
+ );
+ }
+ }
+ 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);
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;
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