X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/47f1cf770212f10b8ffbc1777e95c1dbfe120c9d..33ce5db243675c87fba8ecb575cafeb2109889f0:/hv.c diff --git a/hv.c b/hv.c index c3db1c6..a230c16 100644 --- a/hv.c +++ b/hv.c @@ -604,21 +604,18 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } } - if (HvREHASH(hv)) { - PERL_HASH_INTERNAL(hash, key, klen); - /* We don't have a pointer to the hv, so we have to replicate the - flag into every HEK, so that hv_iterkeysv can see it. */ - /* And yes, you do need this even though you are not "storing" because - you can flip the flags below if doing an lval lookup. (And that - was put in to give the semantics Andreas was expecting.) */ + if (HvREHASH(hv) || (!hash && !(keysv && (SvIsCOW_shared_hash(keysv))))) + PERL_HASH_INTERNAL_(hash, key, klen, HvREHASH(hv)); + else if (!hash) + hash = SvSHARED_HASH(keysv); + + /* We don't have a pointer to the hv, so we have to replicate the + flag into every HEK, so that hv_iterkeysv can see it. + And yes, you do need this even though you are not "storing" because + you can flip the flags below if doing an lval lookup. (And that + was put in to give the semantics Andreas was expecting.) */ + if (HvREHASH(hv)) flags |= HVhek_REHASH; - } else if (!hash) { - if (keysv && (SvIsCOW_shared_hash(keysv))) { - hash = SvSHARED_HASH(keysv); - } else { - PERL_HASH(hash, key, klen); - } - } masked_flags = (flags & HVhek_MASK); @@ -682,7 +679,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, much back at this point (in hv_store's code). */ break; } - /* LVAL fetch which actaully needs a store. */ + /* LVAL fetch which actually needs a store. */ val = newSV(0); HvPLACEHOLDERS(hv)--; } else { @@ -800,6 +797,12 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if (!counter) { /* initial entry? */ } else if (xhv->xhv_keys > xhv->xhv_max) { + /* Use only the old HvUSEDKEYS(hv) > HvMAX(hv) condition to limit + bucket splits on a rehashed hash, as we're not going to + split it again, and if someone is lucky (evil) enough to + get all the keys in one list they could exhaust our memory + as we repeatedly double the number of buckets on every + entry. Linear search feels a less worse thing to do. */ hsplit(hv); } else if(!HvREHASH(hv)) { U32 n_links = 1; @@ -808,12 +811,6 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, n_links++; if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) { - /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit - bucket splits on a rehashed hash, as we're not going to - split it again, and if someone is lucky (evil) enough to - get all the keys in one list they could exhaust our memory - as we repeatedly double the number of buckets on every - entry. Linear search feels a less worse thing to do. */ hsplit(hv); } } @@ -904,7 +901,6 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, register XPVHV* xhv; register HE *entry; register HE **oentry; - HE *const *first_entry; bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE; int masked_flags; @@ -971,25 +967,19 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HvHASKFLAGS_on(MUTABLE_SV(hv)); } - if (HvREHASH(hv)) { - PERL_HASH_INTERNAL(hash, key, klen); - } else if (!hash) { - if (keysv && (SvIsCOW_shared_hash(keysv))) { - hash = SvSHARED_HASH(keysv); - } else { - PERL_HASH(hash, key, klen); - } - } + if (HvREHASH(hv) || (!hash && !(keysv && (SvIsCOW_shared_hash(keysv))))) + PERL_HASH_INTERNAL_(hash, key, klen, HvREHASH(hv)); + else if (!hash) + hash = SvSHARED_HASH(keysv); masked_flags = (k_flags & HVhek_MASK); - first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; + 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 */ - const char *name = NULL; - STRLEN namlen; + GV *gv = NULL; HV *stash = NULL; if (HeHASH(entry) != hash) /* strings can't be equal */ @@ -1013,7 +1003,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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"); @@ -1023,46 +1014,45 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* 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] == ':' + if (( + (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':') + || + (klen == 1 && key[0] == ':') + ) && (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 (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 @@ -1070,18 +1060,20 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, * 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); @@ -1089,7 +1081,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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; } @@ -1474,20 +1466,20 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) 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 */ - SvREFCNT_dec(val); if (HeKLEN(entry) == HEf_SVKEY) { SvREFCNT_dec(HeKEY_sv(entry)); Safefree(HeKEY_hek(entry)); @@ -1497,6 +1489,22 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) 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); } @@ -1520,7 +1528,8 @@ Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) /* =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. =cut */ @@ -1545,7 +1554,8 @@ Perl_hv_clear(pTHX_ HV *hv) 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", @@ -1557,20 +1567,17 @@ Perl_hv_clear(pTHX_ HV *hv) } } } - goto reset; } + else { + hfreeentries(hv); + HvPLACEHOLDERS_set(hv, 0); - hfreeentries(hv); - HvPLACEHOLDERS_set(hv, 0); - if (HvARRAY(hv)) - Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*); - - if (SvRMAGICAL(hv)) - mg_clear(MUTABLE_SV(hv)); + if (SvRMAGICAL(hv)) + mg_clear(MUTABLE_SV(hv)); - HvHASKFLAGS_off(hv); - HvREHASH_off(hv); - reset: + HvHASKFLAGS_off(hv); + HvREHASH_off(hv); + } if (SvOOK(hv)) { if(HvENAME_get(hv)) mro_isa_changed_in(hv); @@ -1618,7 +1625,6 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) i = HvMAX(hv); do { /* Loop down the linked list heads */ - bool first = TRUE; HE **oentry = &(HvARRAY(hv))[i]; HE *entry; @@ -1627,20 +1633,23 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) *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. */ HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv); - if (HvKEYS(hv) == 0) + if (HvUSEDKEYS(hv) == 0) HvHASKFLAGS_off(hv); HvPLACEHOLDERS_set(hv, 0); return; } } else { oentry = &HeNEXT(entry); - first = FALSE; } } } while (--i >= 0); @@ -1652,182 +1661,98 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) STATIC void S_hfreeentries(pTHX_ HV *hv) { - /* This is the array that we're going to restore */ - HE **const orig_array = HvARRAY(hv); - HE **tmp_array = NULL; - const bool has_aux = SvOOK(hv); - struct xpvhv_aux * current_aux = NULL; - int attempts = 100; + STRLEN index = 0; + XPVHV * const xhv = (XPVHV*)SvANY(hv); PERL_ARGS_ASSERT_HFREEENTRIES; - if (!orig_array) - return; - - /* 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 - array to the new HvARRAY, and try again. */ - - while (1) { - /* This is the one we're going to try to empty. First time round - it's the original array. (Hopefully there will only be 1 time - round) */ - HE ** const array = HvARRAY(hv); - I32 i = HvMAX(hv); - - 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; - - 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 - * will continue to live. - * Because while freeing the entries we fake up a NULL HvARRAY - * (and hence HvAUX), we need to store the backref array - * somewhere else; but it still needs to be visible in case - * any the things we free happen to call sv_del_backref(). - * We do this by storing it in magic instead. - * If, during the entry freeing, a destructor happens to add - * a new weak backref, then sv_add_backref will look in both - * places (magic in HvAUX) for the AV, but will create a new - * AV in HvAUX if it can't find one (if it finds it in magic, - * it moves it back into HvAUX. So at the end of the iteration - * we have to allow for this. */ - - - if (iter->xhv_backreferences) { - if (SvTYPE(iter->xhv_backreferences) == SVt_PVAV) { - /* The sv_magic will increase the reference count of the AV, - so we need to drop it first. */ - SvREFCNT_dec(iter->xhv_backreferences); - if (AvFILLp(iter->xhv_backreferences) == -1) { - /* Turns out that the array is empty. Just free it. */ - SvREFCNT_dec(iter->xhv_backreferences); - - } else { - sv_magic(MUTABLE_SV(hv), - MUTABLE_SV(iter->xhv_backreferences), - PERL_MAGIC_backref, NULL, 0); - } - } - else { - MAGIC *mg; - sv_magic(MUTABLE_SV(hv), NULL, PERL_MAGIC_backref, NULL, 0); - mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_backref); - mg->mg_obj = (SV*)iter->xhv_backreferences; - } - iter->xhv_backreferences = NULL; - } - - entry = iter->xhv_eiter; /* HvEITER(hv) */ - if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ - HvLAZYDEL_off(hv); - hv_free_ent(hv, entry); - } - iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ - iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ - - /* There are now no allocated pointers in the aux structure. */ - } - - /* 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; + while (xhv->xhv_keys) { + SvREFCNT_dec(Perl_hfree_next_entry(aTHX_ hv, &index)); + } +} - do { - /* Loop down the linked list heads */ - HE *entry = array[i]; - while (entry) { - register HE * const oentry = entry; - entry = HeNEXT(entry); - hv_free_ent(hv, oentry); - } - } while (--i >= 0); +/* 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. */ - /* As there are no allocated pointers in the aux structure, it's now - safe to free the array we just cleaned up, if it's not the one we're - going to put back. */ - if (array != orig_array) { - Safefree(array); - } +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 - if (!HvARRAY(hv)) { - /* Good. No-one added anything this time round. */ - break; - } + PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY; - if (--attempts == 0) { - Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries"); + 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 */ } - - /* 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 (has_aux) - SvFLAGS(hv) |= SVf_OOK; - else - SvFLAGS(hv) &=~SVf_OOK; + if (!((XPVHV*)SvANY(hv))->xhv_keys) + return NULL; - /* 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; + 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 (tmp_array) Safefree(tmp_array); + 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. =cut */ void -Perl_hv_undef(pTHX_ HV *hv) +Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) { dVAR; register XPVHV* xhv; @@ -1838,15 +1763,17 @@ Perl_hv_undef(pTHX_ HV *hv) DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); - if ((name = HvENAME_get(hv)) && PL_phase != PERL_PHASE_DESTRUCT) - { - /* Delete the @ISA element before calling mro_package_moved, so it - does not see it. */ - (void)hv_delete(hv, "ISA", 3, G_DISCARD); - mro_package_moved(NULL, hv, NULL, name, HvENAMELEN_get(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. */ + /* 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); hv_name_set(hv, NULL, 0, 0); @@ -1855,10 +1782,23 @@ Perl_hv_undef(pTHX_ HV *hv) if (SvOOK(hv)) { struct xpvhv_aux * const aux = HvAUX(hv); struct mro_meta *meta; - if ((name = HvNAME(hv))) { + + if ((name = HvENAME_get(hv))) { + if (PL_phase != PERL_PHASE_DESTRUCT) + 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 ? !!aux->xhv_name_u.xhvnameu_name : !!name) { + if (name && PL_stashcache) (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); - hv_name_set(hv, NULL, 0, 0); + hv_name_set(hv, NULL, 0, flags); } if((meta = aux->xhv_mro_meta)) { if (meta->mro_linear_all) { @@ -1877,11 +1817,14 @@ Perl_hv_undef(pTHX_ HV *hv) Safefree(meta); aux->xhv_mro_meta = NULL; } + if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences) + SvFLAGS(hv) &= ~SVf_OOK; + } + if (!SvOOK(hv)) { + Safefree(HvARRAY(hv)); + xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */ + HvARRAY(hv) = 0; } - SvFLAGS(hv) &= ~SVf_OOK; - 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)) @@ -1942,7 +1885,7 @@ S_hv_auxinit(HV *hv) { iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ - iter->xhv_name = 0; + iter->xhv_name_u.xhvnameu_name = 0; iter->xhv_name_count = 0; iter->xhv_backreferences = 0; iter->xhv_mro_meta = NULL; @@ -1953,7 +1896,7 @@ S_hv_auxinit(HV *hv) { =for apidoc hv_iterinit Prepares a starting point to traverse a hash table. Returns the number of -keys in the hash (i.e. the same as C). The return value is +keys in the hash (i.e. the same as C). The return value is currently only meaningful for hashes without tie magic. NOTE: Before version 5.004_65, C used to return the number of @@ -2075,10 +2018,10 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) if (SvOOK(hv)) { iter = HvAUX(hv); - if (iter->xhv_name) { + if (iter->xhv_name_u.xhvnameu_name) { if(iter->xhv_name_count) { - if(!name) { - HEK ** const name = (HEK **)HvAUX(hv)->xhv_name; + if(flags & HV_NAME_SETALL) { + HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names; HEK **hekp = name + ( iter->xhv_name_count < 0 ? -iter->xhv_name_count @@ -2089,38 +2032,47 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) /* The first elem may be null. */ if(*name) unshare_hek_or_pvn(*name, 0, 0, 0); Safefree(name); - spot = &iter->xhv_name; + spot = &iter->xhv_name_u.xhvnameu_name; 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]; + Renew( + iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK * + ); + spot = iter->xhv_name_u.xhvnameu_names; + 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 = iter->xhv_name_u.xhvnameu_names)) { unshare_hek_or_pvn(*spot, 0, 0, 0); } } } + else if (flags & HV_NAME_SETALL) { + unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0); + spot = &iter->xhv_name_u.xhvnameu_name; + } else { - unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0); - spot = &iter->xhv_name; + HEK * const existing_name = iter->xhv_name_u.xhvnameu_name; + Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *); + iter->xhv_name_count = -2; + spot = iter->xhv_name_u.xhvnameu_names; + spot[1] = existing_name; } } - else spot = &iter->xhv_name; + else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; } } else { if (name == 0) return; iter = hv_auxinit(hv); - spot = &iter->xhv_name; + spot = &iter->xhv_name_u.xhvnameu_name; } PERL_HASH(hash, name, len); *spot = name ? share_hek(name, len, hash) : NULL; - iter->xhv_name_count = 0; } /* @@ -2136,13 +2088,14 @@ table. */ void -Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len) +Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags) { dVAR; struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); 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); @@ -2150,7 +2103,7 @@ Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len) PERL_HASH(hash, name, len); if (aux->xhv_name_count) { - HEK ** const xhv_name = (HEK **)aux->xhv_name; + HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names; I32 count = aux->xhv_name_count; HEK **hekp = xhv_name + (count < 0 ? -count : count); while (hekp-- > xhv_name) @@ -2163,19 +2116,19 @@ Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len) } if (count < 0) aux->xhv_name_count--, count = -count; else aux->xhv_name_count++; - Renewc(aux->xhv_name, count + 1, HEK *, HEK); - ((HEK **)aux->xhv_name)[count] = share_hek(name, len, hash); + Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *); + (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, len, hash); } else { - HEK *existing_name = aux->xhv_name; + 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) ) return; - Newxc(aux->xhv_name, 2, HEK *, HEK); + Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *); aux->xhv_name_count = existing_name ? 2 : -2; - *(HEK **)aux->xhv_name = existing_name; - ((HEK **)aux->xhv_name)[1] = share_hek(name, len, hash); + *aux->xhv_name_u.xhvnameu_names = existing_name; + (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, len, hash); } } @@ -2192,12 +2145,13 @@ This is called when a stash is deleted from the symbol table. */ void -Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len) +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; + PERL_UNUSED_ARG(flags); if (len > I32_MAX) Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); @@ -2205,10 +2159,10 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len) if (!SvOOK(hv)) return; aux = HvAUX(hv); - if (!aux->xhv_name) return; + if (!aux->xhv_name_u.xhvnameu_name) return; if (aux->xhv_name_count) { - HEK ** const namep = (HEK **)aux->xhv_name; + HEK ** const namep = aux->xhv_name_u.xhvnameu_names; I32 const count = aux->xhv_name_count; HEK **victim = namep + (count < 0 ? -count : count); while (victim-- > namep + 1) @@ -2224,7 +2178,7 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len) && !*namep ) { /* if there are none left */ Safefree(namep); - aux->xhv_name = NULL; + aux->xhv_name_u.xhvnameu_names = NULL; aux->xhv_name_count = 0; } else { @@ -2242,12 +2196,12 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len) } } else if( - HEK_LEN(aux->xhv_name) == (I32)len - && memEQ(HEK_KEY(aux->xhv_name), name, len) + HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len + && memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len) ) { - const HEK * const namehek = aux->xhv_name; - Newxc(aux->xhv_name, 1, HEK *, HEK); - *(const HEK **)aux->xhv_name = namehek; + HEK * const namehek = aux->xhv_name_u.xhvnameu_name; + Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *); + *aux->xhv_name_u.xhvnameu_names = namehek; aux->xhv_name_count = -1; } } @@ -2572,7 +2526,6 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) register XPVHV* xhv; HE *entry; register HE **oentry; - HE **first; bool is_utf8 = FALSE; int k_flags = 0; const char * const save = str; @@ -2613,7 +2566,7 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) } */ xhv = (XPVHV*)SvANY(PL_strtab); /* assert(xhv_array != 0) */ - first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; + oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; if (he) { const HE *const he_he = &(he->shared_he_he); for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { @@ -2757,7 +2710,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if (!next) { /* initial entry? */ - } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { + } else if (xhv->xhv_keys > xhv->xhv_max /* HvUSEDKEYS(hv) > HvMAX(hv) */) { hsplit(PL_strtab); } } @@ -3324,6 +3277,7 @@ to this function: no action occurs and a null pointer is returned. struct refcounted_he * Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he) { + dVAR; if (he) { HINTS_REFCNT_LOCK; he->refcounted_he_refcnt++; @@ -3378,7 +3332,7 @@ Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len, if (flags & ~(SVf_UTF8)) Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf, (UV)flags); - labelsv = sv_2mortal(newSVpvn(label, len)); + labelsv = newSVpvn_flags(label, len, SVs_TEMP); if (flags & SVf_UTF8) SvUTF8_on(labelsv); cop->cop_hints_hash