for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
SV *sv;
U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
- const char *name = NULL;
- STRLEN namlen;
+ GV *gv = NULL;
HV *stash = NULL;
if (HeHASH(entry) != hash) /* strings can't be equal */
/* If this is a stash and the key ends with ::, then someone is
* deleting a package.
- * Check whether the gv (HeVAL(entry)) is still in the symbol
- * table and then save the name to pass to mro_package_moved after
- * the deletion.
- * We cannot pass the gv to mro_package_moved directly, as that
- * function also checks whether the gv is to be found at the loca-
- * tion its name indicates, which will no longer be the case once
- * this element is deleted. So we have to do that check here.
*/
if (HeVAL(entry) && HvENAME_get(hv)) {
- sv = HeVAL(entry);
+ gv = (GV *)HeVAL(entry);
if (keysv) key = SvPV(keysv, klen);
if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':'
&& (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
- && SvTYPE(sv) == SVt_PVGV && (stash = GvHV((GV *)sv))
+ && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
&& HvENAME_get(stash)) {
- SV * const namesv = sv_newmortal();
- gv_fullname4(namesv, (GV *)sv, NULL, 0);
- if (
- gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV)
- == (GV *)sv
- ) {
+ /* A previous version of this code checked that the
+ * GV was still in the symbol table by fetching the
+ * GV with its name. That is not necessary (and
+ * sometimes incorrect), as HvENAME cannot be set
+ * on hv if it is not in the symtab. */
mro_changes = 2;
- name = SvPV_const(namesv, namlen);
- namlen -= 2; /* skip trailing :: */
/* Hang on to it for a bit. */
SvREFCNT_inc_simple_void_NN(
- sv_2mortal((SV *)stash)
+ sv_2mortal((SV *)gv)
);
- }
}
else if (klen == 3 && strnEQ(key, "ISA", 3))
mro_changes = 1;
if (mro_changes == 1) mro_isa_changed_in(hv);
else if (mro_changes == 2)
- mro_package_moved(NULL, stash, NULL, name, namlen);
+ mro_package_moved(NULL, stash, gv, 1);
return sv;
}
{
/* This is the array that we're going to restore */
HE **const orig_array = HvARRAY(hv);
- HEK *name;
- I32 name_count;
+ HE **tmp_array = NULL;
+ const bool has_aux = SvOOK(hv);
+ struct xpvhv_aux * current_aux = NULL;
int attempts = 100;
+
+ const bool mpm = PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv);
PERL_ARGS_ASSERT_HFREEENTRIES;
if (!orig_array)
return;
- if (SvOOK(hv)) {
- /* If the hash is actually a symbol table with a name, look after the
- name. */
- struct xpvhv_aux *iter = HvAUX(hv);
-
- name = iter->xhv_name;
- name_count = iter->xhv_name_count;
- iter->xhv_name = NULL;
- } else {
- name = NULL;
- name_count = 0;
- }
-
/* orig_array remains unchanged throughout the loop. If after freeing all
the entries it turns out that one of the little blighters has triggered
an action that has caused HvARRAY to be re-allocated, then we set
HE ** const array = HvARRAY(hv);
I32 i = HvMAX(hv);
- /* Because we have taken xhv_name out, the only allocated pointer
- in the aux structure that might exist is the backreference array.
- */
+ struct xpvhv_aux *iter = SvOOK(hv) ? HvAUX(hv) : NULL;
+
+ /* make everyone else think the array is empty, so that the destructors
+ * called for freed entries can't recursively mess with us */
+ HvARRAY(hv) = NULL;
if (SvOOK(hv)) {
HE *entry;
- struct mro_meta *meta;
- struct xpvhv_aux *iter = HvAUX(hv);
+
+ SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
+ /* What aux structure? */
+ /* (But we still have a pointer to it in iter.) */
+
+ /* Copy the name and MRO stuff to a new aux structure
+ if present. */
+ if (iter->xhv_name || iter->xhv_mro_meta) {
+ struct xpvhv_aux * const newaux = hv_auxinit(hv);
+ newaux->xhv_name = iter->xhv_name;
+ newaux->xhv_name_count = iter->xhv_name_count;
+ iter->xhv_name = NULL;
+ newaux->xhv_mro_meta = iter->xhv_mro_meta;
+ iter->xhv_mro_meta = NULL;
+ }
+
+ /* Because we have taken xhv_name and
+ xhv_mro_meta out, the only allocated
+ pointers in the aux structure that might exist are the back-
+ reference array and xhv_eiter.
+ */
+
/* weak references: if called from sv_clear(), the backrefs
* should already have been killed; if there are any left, its
* because we're doing hv_clear() or hv_undef(), and the HV
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
- if((meta = iter->xhv_mro_meta)) {
- if (meta->mro_linear_all) {
- SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
- meta->mro_linear_all = NULL;
- /* This is just acting as a shortcut pointer. */
- meta->mro_linear_current = NULL;
- } else if (meta->mro_linear_current) {
- /* Only the current MRO is stored, so this owns the data.
- */
- SvREFCNT_dec(meta->mro_linear_current);
- meta->mro_linear_current = NULL;
- }
- if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
- SvREFCNT_dec(meta->isa);
- Safefree(meta);
- iter->xhv_mro_meta = NULL;
- }
-
/* There are now no allocated pointers in the aux structure. */
-
- SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
- /* What aux structure? */
}
- /* make everyone else think the array is empty, so that the destructors
- * called for freed entries can't recursively mess with us */
- HvARRAY(hv) = NULL;
- ((XPVHV*) SvANY(hv))->xhv_keys = 0;
+ /* If there are no keys, there is nothing left to free. */
+ if (!((XPVHV*) SvANY(hv))->xhv_keys) break;
+ /* Since we have removed the HvARRAY (and possibly replaced it by
+ calling hv_auxinit), set the number of keys accordingly. */
+ ((XPVHV*) SvANY(hv))->xhv_keys = 0;
do {
/* Loop down the linked list heads */
while (entry) {
register HE * const oentry = entry;
entry = HeNEXT(entry);
+ if (
+ mpm && HeVAL(oentry) && isGV(HeVAL(oentry)) &&
+ GvHV(HeVAL(oentry)) && HvENAME(GvHV(HeVAL(oentry)))
+ ) {
+ STRLEN klen;
+ const char * const key = HePV(oentry,klen);
+ if (klen > 1 && key[klen-1]==':' && key[klen-2]==':') {
+ mro_package_moved(
+ NULL, GvHV(HeVAL(oentry)),
+ (GV *)HeVAL(oentry), 0
+ );
+ }
+ }
hv_free_ent(hv, oentry);
}
} while (--i >= 0);
break;
}
- if (SvOOK(hv)) {
- /* Someone attempted to iterate or set the hash name while we had
- the array set to 0. We'll catch backferences on the next time
- round the while loop. */
- assert(HvARRAY(hv));
-
- if (HvAUX(hv)->xhv_name) {
- if(HvAUX(hv)->xhv_name_count) {
- HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
- I32 const count = HvAUX(hv)->xhv_name_count;
- HEK **hekp = name + (count < 0 ? -count : count);
- while(hekp-- > name)
- unshare_hek_or_pvn(*hekp, 0, 0, 0);
- Safefree(name);
- }
- else unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
- }
- }
-
if (--attempts == 0) {
Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
}
}
+ /* Set aside the current array for now, in case we still need it. */
+ if (SvOOK(hv)) current_aux = HvAUX(hv);
+ if (HvARRAY(hv) && HvARRAY(hv) != orig_array)
+ tmp_array = HvARRAY(hv);
+
HvARRAY(hv) = orig_array;
- /* If the hash was actually a symbol table, put the name back. */
- if (name) {
- /* We have restored the original array. If name is non-NULL, then
- the original array had an aux structure at the end. So this is
- valid: */
- struct xpvhv_aux * const aux = HvAUX(hv);
+ if (has_aux)
SvFLAGS(hv) |= SVf_OOK;
- aux->xhv_name = name;
- aux->xhv_name_count = name_count;
+ else
+ SvFLAGS(hv) &=~SVf_OOK;
+
+ /* If the hash was actually a symbol table, put the name and MRO
+ caches back. */
+ if (current_aux) {
+ struct xpvhv_aux * const aux
+ = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
+ aux->xhv_name = current_aux->xhv_name;
+ aux->xhv_name_count = current_aux->xhv_name_count;
+ aux->xhv_mro_meta = current_aux->xhv_mro_meta;
}
+
+ if (tmp_array) Safefree(tmp_array);
}
/*
*/
void
-Perl_hv_undef(pTHX_ HV *hv)
+Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
{
dVAR;
register XPVHV* xhv;
DEBUG_A(Perl_hv_assert(aTHX_ hv));
xhv = (XPVHV*)SvANY(hv);
- if ((name = HvENAME_get(hv)) && !PL_dirty)
- mro_isa_changed_in(hv);
-
- hfreeentries(hv);
- if (name || (name = HvNAME(hv))) {
+ /* The name must be deleted before the call to hfreeeeentries so that
+ CVs are anonymised properly. But the effective name must be pre-
+ served until after that call (and only deleted afterwards if the
+ call originated from sv_clear). For stashes with one name that is
+ both the canonical name and the effective name, hv_name_set has to
+ 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. */
+ if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
if (PL_stashcache)
(void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
hv_name_set(hv, NULL, 0, 0);
}
- SvFLAGS(hv) &= ~SVf_OOK;
- Safefree(HvARRAY(hv));
- xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
- HvARRAY(hv) = 0;
+ hfreeentries(hv);
+ if (SvOOK(hv)) {
+ struct xpvhv_aux * const aux = HvAUX(hv);
+ struct mro_meta *meta;
+ bool zeroed = FALSE;
+
+ if ((name = HvENAME_get(hv))) {
+ if (PL_phase != PERL_PHASE_DESTRUCT) {
+ /* This must come at this point in case
+ mro_isa_changed_in dies. */
+ Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
+ zeroed = TRUE;
+
+ mro_isa_changed_in(hv);
+ }
+ if (PL_stashcache)
+ (void)hv_delete(
+ PL_stashcache, name, HvENAMELEN_get(hv), G_DISCARD
+ );
+ }
+
+ /* If this call originated from sv_clear, then we must check for
+ * effective names that need freeing, as well as the usual name. */
+ name = HvNAME(hv);
+ if (flags & HV_NAME_SETALL ? (const char *)aux->xhv_name : name) {
+ if (name && PL_stashcache)
+ (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
+ hv_name_set(hv, NULL, 0, flags);
+ }
+ if((meta = aux->xhv_mro_meta)) {
+ if (meta->mro_linear_all) {
+ SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
+ meta->mro_linear_all = NULL;
+ /* This is just acting as a shortcut pointer. */
+ meta->mro_linear_current = NULL;
+ } else if (meta->mro_linear_current) {
+ /* Only the current MRO is stored, so this owns the data.
+ */
+ SvREFCNT_dec(meta->mro_linear_current);
+ meta->mro_linear_current = NULL;
+ }
+ if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
+ SvREFCNT_dec(meta->isa);
+ Safefree(meta);
+ aux->xhv_mro_meta = NULL;
+ }
+ if (!aux->xhv_name)
+ SvFLAGS(hv) &= ~SVf_OOK;
+ else if (!zeroed)
+ Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
+ }
+ if (!SvOOK(hv)) {
+ Safefree(HvARRAY(hv));
+ xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
+ HvARRAY(hv) = 0;
+ }
HvPLACEHOLDERS_set(hv, 0);
if (SvRMAGICAL(hv))
iter = HvAUX(hv);
if (iter->xhv_name) {
if(iter->xhv_name_count) {
- if(!name) {
+ if(flags & HV_NAME_SETALL) {
HEK ** const name = (HEK **)HvAUX(hv)->xhv_name;
HEK **hekp = name + (
iter->xhv_name_count < 0
iter->xhv_name_count = 0;
}
else {
- spot = (HEK **)iter->xhv_name;
if(iter->xhv_name_count > 0) {
/* shift some things over */
- Renew(spot, iter->xhv_name_count, HEK *);
- spot[iter->xhv_name_count++] = spot[1];
+ Renewc(
+ iter->xhv_name, iter->xhv_name_count + 1, HEK *, HEK
+ );
+ spot = (HEK **)iter->xhv_name;
+ spot[iter->xhv_name_count] = spot[1];
spot[1] = spot[0];
+ iter->xhv_name_count = -(iter->xhv_name_count + 1);
}
- else if(*spot) {
+ else if(*(spot = (HEK **)iter->xhv_name)) {
unshare_hek_or_pvn(*spot, 0, 0, 0);
}
}
}
- else {
+ else if (flags & HV_NAME_SETALL) {
unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
spot = &iter->xhv_name;
}
+ else {
+ HEK * const existing_name = iter->xhv_name;
+ Newxc(iter->xhv_name, 2, HEK *, HEK);
+ iter->xhv_name_count = -2;
+ spot = (HEK **)iter->xhv_name;
+ spot[1] = existing_name;
+ }
}
- else spot = &iter->xhv_name;
+ else { spot = &iter->xhv_name; iter->xhv_name_count = 0; }
} else {
if (name == 0)
return;
}
PERL_HASH(hash, name, len);
*spot = name ? share_hek(name, len, hash) : NULL;
- iter->xhv_name_count = 0;
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff