X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=fbfdce3e738993d4872fa3abee4c929a9c748286;hb=687d3573c7533b89705e64f529b53c631cb9dec0;hp=fe74e87849644ed1805a7e9094d1b49ea8d5a83f;hpb=5b9c067131ee63b4afa00d1d71c771377deb6ff9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index fe74e87..fbfdce3 100644 --- a/hv.c +++ b/hv.c @@ -71,7 +71,8 @@ S_new_he(pTHX) LOCK_SV_MUTEX; if (!*root) S_more_he(aTHX); - he = *root; + he = (HE*) *root; + assert(he); *root = HeNEXT(he); UNLOCK_SV_MUTEX; return he; @@ -103,7 +104,7 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) HEK_KEY(hek)[len] = 0; HEK_LEN(hek) = len; HEK_HASH(hek) = hash; - HEK_FLAGS(hek) = (unsigned char)flags_masked; + HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED; if (flags & HVhek_FREEKEY) Safefree(str); @@ -435,6 +436,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return NULL; if (keysv) { + if (SvSMAGICAL(hv) && SvGMAGICAL(hv)) + keysv = hv_magic_uvar_xkey(hv, keysv, action); if (flags & HVhek_FREEKEY) Safefree(key); key = SvPV_const(keysv, klen); @@ -447,12 +450,13 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) { - if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { - sv = sv_newmortal(); - + MAGIC *regdata = NULL; + if (( regdata = mg_find((SV*)hv, PERL_MAGIC_regdata_names)) || + mg_find((SV*)hv, PERL_MAGIC_tied) || + SvGMAGICAL((SV*)hv)) + { /* XXX should be able to skimp on the HE/HEK here when HV_FETCH_JUST_SV is true. */ - if (!keysv) { keysv = newSVpvn(key, klen); if (is_utf8) { @@ -461,7 +465,14 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } else { keysv = newSVsv(keysv); } - mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY); + if (regdata) { + sv = Perl_reg_named_buff_sv(aTHX_ keysv); + if (!sv) + sv = sv_newmortal(); + } else { + sv = sv_newmortal(); + mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY); + } /* grab a fake HE/HEK pair from the pool or make a new one */ entry = PL_hv_fetch_ent_mh; @@ -964,6 +975,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return NULL; if (keysv) { + if (SvSMAGICAL(hv) && SvGMAGICAL(hv)) + keysv = hv_magic_uvar_xkey(hv, keysv, -1); if (k_flags & HVhek_FREEKEY) Safefree(key); key = SvPV_const(keysv, klen); @@ -1592,8 +1605,8 @@ Perl_hv_clear(pTHX_ HV *hv) if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) { SV* const keysv = hv_iterkeysv(entry); Perl_croak(aTHX_ - "Attempt to delete readonly key '%"SVf"' from a restricted hash", - keysv); + "Attempt to delete readonly key '%"SVf"' from a restricted hash", + (void*)keysv); } SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = &PL_sv_placeholder; @@ -1607,8 +1620,7 @@ Perl_hv_clear(pTHX_ HV *hv) hfreeentries(hv); HvPLACEHOLDERS_set(hv, 0); if (HvARRAY(hv)) - (void)memzero(HvARRAY(hv), - (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*)); + Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*); if (SvRMAGICAL(hv)) mg_clear((SV*)hv); @@ -1919,7 +1931,17 @@ Perl_hv_iterinit(pTHX_ HV *hv) } else { hv_auxinit(hv); } - + if ( SvRMAGICAL(hv) ) { + MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names); + if ( mg ) { + if (PL_curpm) { + const REGEXP * const rx = PM_GETRE(PL_curpm); + if (rx && rx->paren_names) { + (void)hv_iterinit(rx->paren_names); + } + } + } + } /* used to be xhv->xhv_fill before 5.004_65 */ return HvTOTALKEYS(hv); } @@ -2074,6 +2096,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) if (!hv) Perl_croak(aTHX_ "Bad hash"); + xhv = (XPVHV*)SvANY(hv); if (!SvOOK(hv)) { @@ -2085,39 +2108,116 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) iter = HvAUX(hv); oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ + if (SvMAGICAL(hv) && SvRMAGICAL(hv)) { + if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names) ) ) { + SV * key; + SV *val = NULL; + REGEXP * rx; + if (!PL_curpm) + return NULL; + rx = PM_GETRE(PL_curpm); + if (rx && rx->paren_names) { + hv = rx->paren_names; + } else { + return NULL; + } - if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) { - SV * const key = sv_newmortal(); - if (entry) { - sv_setsv(key, HeSVKEY_force(entry)); - SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ - } - else { - char *k; - HEK *hek; - - /* one HE per MAGICAL hash */ - iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ - Zero(entry, 1, HE); - Newxz(k, HEK_BASESIZE + sizeof(SV*), char); - hek = (HEK*)k; - HeKEY_hek(entry) = hek; - HeKLEN(entry) = HEf_SVKEY; - } - magic_nextpack((SV*) hv,mg,key); - if (SvOK(key)) { - /* force key to stay around until next time */ - HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); - return entry; /* beware, hent_val is not set */ - } - if (HeVAL(entry)) - SvREFCNT_dec(HeVAL(entry)); - Safefree(HeKEY_hek(entry)); - del_HE(entry); - iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ - return NULL; + key = sv_newmortal(); + if (entry) { + sv_setsv(key, HeSVKEY_force(entry)); + SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ + } + else { + char *k; + HEK *hek; + + /* one HE per MAGICAL hash */ + iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ + Zero(entry, 1, HE); + Newxz(k, HEK_BASESIZE + sizeof(SV*), char); + hek = (HEK*)k; + HeKEY_hek(entry) = hek; + HeKLEN(entry) = HEf_SVKEY; + } + { + while (!val) { + HE *temphe = hv_iternext_flags(hv,flags); + if (temphe) { + IV i; + IV parno = 0; + SV* sv_dat = HeVAL(temphe); + I32 *nums = (I32*)SvPVX(sv_dat); + for ( i = 0; i < SvIVX(sv_dat); i++ ) { + if ((I32)(rx->lastcloseparen) >= nums[i] && + rx->startp[nums[i]] != -1 && + rx->endp[nums[i]] != -1) + { + parno = nums[i]; + break; + } + } + if (parno) { + GV *gv_paren; + STRLEN len; + SV *sv = sv_newmortal(); + const char* pvkey = HePV(temphe, len); + + Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno); + gv_paren = Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV); + Perl_sv_setpvn(aTHX_ key, pvkey, len); + val = GvSVn(gv_paren); + } + } else { + break; + } + } + } + if (val && SvOK(key)) { + /* force key to stay around until next time */ + HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); + HeVAL(entry) = SvREFCNT_inc_simple_NN(val); + return entry; /* beware, hent_val is not set */ + } + if (HeVAL(entry)) + SvREFCNT_dec(HeVAL(entry)); + Safefree(HeKEY_hek(entry)); + del_HE(entry); + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ + return NULL; + } + else if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) { + SV * const key = sv_newmortal(); + if (entry) { + sv_setsv(key, HeSVKEY_force(entry)); + SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ + } + else { + char *k; + HEK *hek; + + /* one HE per MAGICAL hash */ + iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ + Zero(entry, 1, HE); + Newxz(k, HEK_BASESIZE + sizeof(SV*), char); + hek = (HEK*)k; + HeKEY_hek(entry) = hek; + HeKLEN(entry) = HEf_SVKEY; + } + magic_nextpack((SV*) hv,mg,key); + if (SvOK(key)) { + /* force key to stay around until next time */ + HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); + return entry; /* beware, hent_val is not set */ + } + if (HeVAL(entry)) + SvREFCNT_dec(HeVAL(entry)); + Safefree(HeKEY_hek(entry)); + del_HE(entry); + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ + return NULL; + } } -#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */ +#if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */ if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { prime_env_iter(); #ifdef VMS @@ -2307,7 +2407,6 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) HE *entry; register HE **oentry; HE **first; - bool found = 0; bool is_utf8 = FALSE; int k_flags = 0; const char * const save = str; @@ -2356,10 +2455,8 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) if (he) { const HE *const he_he = &(he->shared_he_he); for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { - if (entry != he_he) - continue; - found = 1; - break; + if (entry == he_he) + break; } } else { const int flags_masked = k_flags & HVhek_MASK; @@ -2372,13 +2469,12 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) continue; if (HeKFLAGS(entry) != flags_masked) continue; - found = 1; break; } } - if (found) { - if (--he->shared_he_he.he_valu.hent_refcount == 0) { + if (entry) { + if (--entry->he_valu.hent_refcount == 0) { *oentry = HeNEXT(entry); if (!*first) { /* There are now no entries in our slot. */ @@ -2390,7 +2486,7 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) } UNLOCK_STRTAB_MUTEX; - if (!found && ckWARN_d(WARN_INTERNAL)) + if (!entry && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-existent shared string '%s'%s" pTHX__FORMAT, @@ -2515,6 +2611,24 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) return HeKEY_hek(entry); } +STATIC SV * +S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action) +{ + MAGIC* mg; + if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) { + struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; + if (uf->uf_set == NULL) { + SV* obj = mg->mg_obj; + mg->mg_obj = keysv; /* pass key */ + uf->uf_index = action; /* pass action */ + magic_getuvar((SV*)hv, mg); + keysv = mg->mg_obj; /* may have changed */ + mg->mg_obj = obj; + } + } + return keysv; +} + I32 * Perl_hv_placeholders_p(pTHX_ HV *hv) { @@ -2556,6 +2670,52 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) /* else we don't need to add magic to record 0 placeholders. */ } +STATIC SV * +S_refcounted_he_value(pTHX_ const struct refcounted_he *he) +{ + dVAR; + SV *value; + switch(he->refcounted_he_data[0] & HVrhek_typemask) { + case HVrhek_undef: + value = newSV(0); + break; + case HVrhek_delete: + value = &PL_sv_placeholder; + break; + case HVrhek_IV: + value = (he->refcounted_he_data[0] & HVrhek_UV) + ? newSVuv(he->refcounted_he_val.refcounted_he_u_iv) + : newSViv(he->refcounted_he_val.refcounted_he_u_uv); + break; + case HVrhek_PV: + /* Create a string SV that directly points to the bytes in our + structure. */ + value = newSV(0); + sv_upgrade(value, SVt_PV); + SvPV_set(value, (char *) he->refcounted_he_data + 1); + SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len); + /* This stops anything trying to free it */ + SvLEN_set(value, 0); + SvPOK_on(value); + SvREADONLY_on(value); + if (he->refcounted_he_data[0] & HVrhek_UTF8) + SvUTF8_on(value); + break; + default: + Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x", + he->refcounted_he_data[0]); + } + return value; +} + +#ifdef USE_ITHREADS +/* A big expression to find the key offset */ +#define REF_HE_KEY(chain) \ + ((((chain->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV) \ + ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \ + + 1 + chain->refcounted_he_data) +#endif + /* =for apidoc refcounted_he_chain_2hv @@ -2567,6 +2727,7 @@ in C. HV * Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) { + dVAR; HV *hv = newHV(); U32 placeholders = 0; /* We could chase the chain once to get an idea of the number of keys, @@ -2581,24 +2742,56 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) } while (chain) { - const U32 hash = HEK_HASH(chain->refcounted_he_he.hent_hek); +#ifdef USE_ITHREADS + U32 hash = chain->refcounted_he_hash; +#else + U32 hash = HEK_HASH(chain->refcounted_he_hek); +#endif HE **oentry = &((HvARRAY(hv))[hash & max]); HE *entry = *oentry; + SV *value; for (; entry; entry = HeNEXT(entry)) { if (HeHASH(entry) == hash) { - goto next_please; + /* We might have a duplicate key here. If so, entry is older + than the key we've already put in the hash, so if they are + the same, skip adding entry. */ +#ifdef USE_ITHREADS + const STRLEN klen = HeKLEN(entry); + const char *const key = HeKEY(entry); + if (klen == chain->refcounted_he_keylen + && (!!HeKUTF8(entry) + == !!(chain->refcounted_he_data[0] & HVhek_UTF8)) + && memEQ(key, REF_HE_KEY(chain), klen)) + goto next_please; +#else + if (HeKEY_hek(entry) == chain->refcounted_he_hek) + goto next_please; + if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek) + && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek) + && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek), + HeKLEN(entry))) + goto next_please; +#endif } } assert (!entry); entry = new_HE(); - HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_he.hent_hek); - - HeVAL(entry) = chain->refcounted_he_he.he_valu.hent_val; - if (HeVAL(entry) == &PL_sv_placeholder) +#ifdef USE_ITHREADS + HeKEY_hek(entry) + = share_hek_flags(REF_HE_KEY(chain), + chain->refcounted_he_keylen, + chain->refcounted_he_hash, + (chain->refcounted_he_data[0] + & (HVhek_UTF8|HVhek_WASUTF8))); +#else + HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); +#endif + value = refcounted_he_value(chain); + if (value == &PL_sv_placeholder) placeholders++; - SvREFCNT_inc_void_NN(HeVAL(entry)); + HeVAL(entry) = value; /* Link it into the chain. */ HeNEXT(entry) = *oentry; @@ -2611,7 +2804,7 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) HvTOTALKEYS(hv)++; next_please: - chain = (struct refcounted_he *) chain->refcounted_he_he.hent_next; + chain = chain->refcounted_he_next; } if (placeholders) { @@ -2628,13 +2821,71 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) return hv; } +SV * +Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, + const char *key, STRLEN klen, int flags, U32 hash) +{ + dVAR; + /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness + of your key has to exactly match that which is stored. */ + SV *value = &PL_sv_placeholder; + bool is_utf8; + + if (keysv) { + if (flags & HVhek_FREEKEY) + Safefree(key); + key = SvPV_const(keysv, klen); + flags = 0; + is_utf8 = (SvUTF8(keysv) != 0); + } else { + is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); + } + + if (!hash) { + if (keysv && (SvIsCOW_shared_hash(keysv))) { + hash = SvSHARED_HASH(keysv); + } else { + PERL_HASH(hash, key, klen); + } + } + + for (; chain; chain = chain->refcounted_he_next) { +#ifdef USE_ITHREADS + if (hash != chain->refcounted_he_hash) + continue; + if (klen != chain->refcounted_he_keylen) + continue; + if (memNE(REF_HE_KEY(chain),key,klen)) + continue; + if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8)) + continue; +#else + if (hash != HEK_HASH(chain->refcounted_he_hek)) + continue; + if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek)) + continue; + if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen)) + continue; + if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek)) + continue; +#endif + + value = sv_2mortal(refcounted_he_value(chain)); + break; + } + + if (flags & HVhek_FREEKEY) + Safefree(key); + + return value; +} + /* =for apidoc refcounted_he_new -Creates a new C. Assumes ownership of one reference -to I. As S is copied into a shared hash key, all references remain -the property of the caller. The C is returned with a -reference count of 1. +Creates a new C. As S is copied, and value is +stored in a compact form, all references remain the property of the caller. +The C is returned with a reference count of 1. =cut */ @@ -2642,19 +2893,92 @@ reference count of 1. struct refcounted_he * Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value) { + dVAR; struct refcounted_he *he; + STRLEN key_len; + const char *key_p = SvPV_const(key, key_len); + STRLEN value_len = 0; + const char *value_p = NULL; + char value_type; + char flags; + STRLEN key_offset; U32 hash; - STRLEN len; - const char *p = SvPV_const(key, len); + bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; + + if (SvPOK(value)) { + value_type = HVrhek_PV; + } else if (SvIOK(value)) { + value_type = HVrhek_IV; + } else if (value == &PL_sv_placeholder) { + value_type = HVrhek_delete; + } else if (!SvOK(value)) { + value_type = HVrhek_undef; + } else { + value_type = HVrhek_PV; + } + + if (value_type == HVrhek_PV) { + value_p = SvPV_const(value, value_len); + key_offset = value_len + 2; + } else { + value_len = 0; + key_offset = 1; + } + flags = value_type; + +#ifdef USE_ITHREADS + he = (struct refcounted_he*) + PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + + key_len + + key_offset); +#else + he = (struct refcounted_he*) + PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + + key_offset); +#endif + - PERL_HASH(hash, p, len); + he->refcounted_he_next = parent; - Newx(he, 1, struct refcounted_he); + if (value_type == HVrhek_PV) { + Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); + he->refcounted_he_val.refcounted_he_u_len = value_len; + if (SvUTF8(value)) { + flags |= HVrhek_UTF8; + } + } else if (value_type == HVrhek_IV) { + if (SvUOK(value)) { + he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); + flags |= HVrhek_UV; + } else { + he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); + } + } - he->refcounted_he_he.hent_next = (HE *)parent; - he->refcounted_he_he.he_valu.hent_val = value; - he->refcounted_he_he.hent_hek - = share_hek(p, SvUTF8(key) ? -(I32)len : len, hash); + if (is_utf8) { + /* Hash keys are always stored normalised to (yes) ISO-8859-1. + As we're going to be building hash keys from this value in future, + normalise it now. */ + key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8); + flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8; + } + PERL_HASH(hash, key_p, key_len); + +#ifdef USE_ITHREADS + he->refcounted_he_hash = hash; + he->refcounted_he_keylen = key_len; + Copy(key_p, he->refcounted_he_data + key_offset, key_len, char); +#else + he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags); +#endif + + if (flags & HVhek_WASUTF8) { + /* If it was downgraded from UTF-8, then the pointer returned from + bytes_from_utf8 is an allocated pointer that we must free. */ + Safefree(key_p); + } + + he->refcounted_he_data[0] = flags; he->refcounted_he_refcnt = 1; return he; @@ -2672,95 +2996,29 @@ and C iterates onto the parent node. void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { + PERL_UNUSED_CONTEXT; + while (he) { struct refcounted_he *copy; + U32 new_count; - if (--he->refcounted_he_refcnt) + HINTS_REFCNT_LOCK; + new_count = --he->refcounted_he_refcnt; + HINTS_REFCNT_UNLOCK; + + if (new_count) { return; + } - unshare_hek_or_pvn (he->refcounted_he_he.hent_hek, 0, 0, 0); - SvREFCNT_dec(he->refcounted_he_he.he_valu.hent_val); +#ifndef USE_ITHREADS + unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); +#endif copy = he; - he = (struct refcounted_he *) he->refcounted_he_he.hent_next; - Safefree(copy); + he = he->refcounted_he_next; + PerlMemShared_free(copy); } } - -/* -=for apidoc refcounted_he_dup - -Duplicates the C for a new thread. - -=cut -*/ - -#if defined(USE_ITHREADS) -struct refcounted_he * -Perl_refcounted_he_dup(pTHX_ const struct refcounted_he *const he, - CLONE_PARAMS* param) -{ - struct refcounted_he *copy; - - if (!he) - return NULL; - - /* look for it in the table first */ - copy = (struct refcounted_he *)ptr_table_fetch(PL_ptr_table, he); - if (copy) - return copy; - - /* create anew and remember what it is */ - Newx(copy, 1, struct refcounted_he); - ptr_table_store(PL_ptr_table, he, copy); - - copy->refcounted_he_he.hent_next - = (HE *)Perl_refcounted_he_dup(aTHX_ - (struct refcounted_he *) - he->refcounted_he_he.hent_next, - param); - copy->refcounted_he_he.he_valu.hent_val - = SvREFCNT_inc(sv_dup(he->refcounted_he_he.he_valu.hent_val, param)); - copy->refcounted_he_he.hent_hek - = hek_dup(he->refcounted_he_he.hent_hek, param); - copy->refcounted_he_refcnt = he->refcounted_he_refcnt; - return copy; -} - -/* -=for apidoc refcounted_he_copy - -Copies a chain of C. Used by C. - -=cut -*/ - -struct refcounted_he * -Perl_refcounted_he_copy(pTHX_ const struct refcounted_he * he) -{ - struct refcounted_he *copy; - HEK *hek; - /* This is much easier to express recursively than iteratively. */ - if (!he) - return NULL; - - Newx(copy, 1, struct refcounted_he); - copy->refcounted_he_he.hent_next - = (HE *)Perl_refcounted_he_copy(aTHX_ - (struct refcounted_he *) - he->refcounted_he_he.hent_next); - copy->refcounted_he_he.he_valu.hent_val - = newSVsv(he->refcounted_he_he.he_valu.hent_val); - hek = he->refcounted_he_he.hent_hek; - copy->refcounted_he_he.hent_hek - = share_hek(HEK_KEY(hek), - HEK_UTF8(hek) ? -(I32)HEK_LEN(hek) : HEK_LEN(hek), - HEK_HASH(hek)); - copy->refcounted_he_refcnt = 1; - return copy; -} -#endif - /* =for apidoc hv_assert @@ -2774,63 +3032,62 @@ Check that a hash is in an internally consistent state. void Perl_hv_assert(pTHX_ HV *hv) { - dVAR; - HE* entry; - int withflags = 0; - int placeholders = 0; - int real = 0; - int bad = 0; - const I32 riter = HvRITER_get(hv); - HE *eiter = HvEITER_get(hv); - - (void)hv_iterinit(hv); - - while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { - /* sanity check the values */ - if (HeVAL(entry) == &PL_sv_placeholder) { - placeholders++; - } else { - real++; - } - /* sanity check the keys */ - if (HeSVKEY(entry)) { - /*EMPTY*/ /* Don't know what to check on SV keys. */ - } else if (HeKUTF8(entry)) { - withflags++; - if (HeKWASUTF8(entry)) { - PerlIO_printf(Perl_debug_log, - "hash key has both WASUFT8 and UTF8: '%.*s'\n", - (int) HeKLEN(entry), HeKEY(entry)); - bad = 1; - } - } else if (HeKWASUTF8(entry)) { - withflags++; - } - } - if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { - if (HvUSEDKEYS(hv) != real) { - PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n", - (int) real, (int) HvUSEDKEYS(hv)); - bad = 1; - } - if (HvPLACEHOLDERS_get(hv) != placeholders) { - PerlIO_printf(Perl_debug_log, - "Count %d placeholder(s), but hash reports %d\n", - (int) placeholders, (int) HvPLACEHOLDERS_get(hv)); - bad = 1; - } - } - if (withflags && ! HvHASKFLAGS(hv)) { - PerlIO_printf(Perl_debug_log, - "Hash has HASKFLAGS off but I count %d key(s) with flags\n", - withflags); - bad = 1; - } - if (bad) { - sv_dump((SV *)hv); - } - HvRITER_set(hv, riter); /* Restore hash iterator state */ - HvEITER_set(hv, eiter); + dVAR; + HE* entry; + int withflags = 0; + int placeholders = 0; + int real = 0; + int bad = 0; + const I32 riter = HvRITER_get(hv); + HE *eiter = HvEITER_get(hv); + + (void)hv_iterinit(hv); + + while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { + /* sanity check the values */ + if (HeVAL(entry) == &PL_sv_placeholder) + placeholders++; + else + real++; + /* sanity check the keys */ + if (HeSVKEY(entry)) { + NOOP; /* Don't know what to check on SV keys. */ + } else if (HeKUTF8(entry)) { + withflags++; + if (HeKWASUTF8(entry)) { + PerlIO_printf(Perl_debug_log, + "hash key has both WASUFT8 and UTF8: '%.*s'\n", + (int) HeKLEN(entry), HeKEY(entry)); + bad = 1; + } + } else if (HeKWASUTF8(entry)) + withflags++; + } + if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { + static const char bad_count[] = "Count %d %s(s), but hash reports %d\n"; + const int nhashkeys = HvUSEDKEYS(hv); + const int nhashplaceholders = HvPLACEHOLDERS_get(hv); + + if (nhashkeys != real) { + PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys ); + bad = 1; + } + if (nhashplaceholders != placeholders) { + PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders ); + bad = 1; + } + } + if (withflags && ! HvHASKFLAGS(hv)) { + PerlIO_printf(Perl_debug_log, + "Hash has HASKFLAGS off but I count %d key(s) with flags\n", + withflags); + bad = 1; + } + if (bad) { + sv_dump((SV *)hv); + } + HvRITER_set(hv, riter); /* Restore hash iterator state */ + HvEITER_set(hv, eiter); } #endif