X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=79f59730a97f1238ecc5ca8ad0db42fa487bd9c6;hb=cd22a09c8c81e5e4c639c15ad19704a0d1e0c842;hp=6418576361084ff2f3c4b076a1cd8db1009a2b02;hpb=0c289d1353d1d6a489307ffba4ca3a6f96e97809;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index 6418576..79f5973 100644 --- a/hv.c +++ b/hv.c @@ -9,7 +9,11 @@ */ /* - * "I sit beside the fire and think of all that I have seen." --Bilbo + * I sit beside the fire and think + * of all that I have seen. + * --Bilbo + * + * [p.278 of _The Lord of the Rings_, II/iii: "The Ring Goes South"] */ /* @@ -169,7 +173,7 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) HeNEXT(ret) = he_dup(HeNEXT(e),shared, param); if (HeKLEN(e) == HEf_SVKEY) { char *k; - Newx(k, HEK_BASESIZE + sizeof(SV*), char); + Newx(k, HEK_BASESIZE + sizeof(const SV *), char); HeKEY_hek(ret) = (HEK*)k; HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param)); } @@ -357,7 +361,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) { MAGIC* mg; - if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) { + if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) { struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; if (uf->uf_set == NULL) { SV* obj = mg->mg_obj; @@ -370,7 +374,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, mg->mg_obj = keysv; /* pass key */ uf->uf_index = action; /* pass action */ - magic_getuvar((SV*)hv, mg); + magic_getuvar(MUTABLE_SV(hv), mg); keysv = mg->mg_obj; /* may have changed */ mg->mg_obj = obj; @@ -384,8 +388,12 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (flags & HVhek_FREEKEY) Safefree(key); key = SvPV_const(keysv, klen); - flags = 0; is_utf8 = (SvUTF8(keysv) != 0); + if (SvIsCOW_shared_hash(keysv)) { + flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0); + } else { + flags = 0; + } } else { is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); } @@ -399,7 +407,8 @@ Perl_hv_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)) + if (mg_find((const SV *)hv, PERL_MAGIC_tied) + || SvGMAGICAL((const SV *)hv)) { /* FIXME should be able to skimp on the HE/HEK here when HV_FETCH_JUST_SV is true. */ @@ -409,7 +418,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, keysv = newSVsv(keysv); } sv = sv_newmortal(); - mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY); + mg_copy(MUTABLE_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; @@ -418,7 +427,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, else { char *k; entry = new_HE(); - Newx(k, HEK_BASESIZE + sizeof(SV*), char); + Newx(k, HEK_BASESIZE + sizeof(const SV *), char); HeKEY_hek(entry) = (HEK*)k; } HeNEXT(entry) = NULL; @@ -427,7 +436,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, sv_upgrade(sv, SVt_PVLV); LvTYPE(sv) = 'T'; /* so we can free entry when freeing sv */ - LvTARG(sv) = (SV*)entry; + LvTARG(sv) = MUTABLE_SV(entry); /* XXX remove at some point? */ if (flags & HVhek_FREEKEY) @@ -439,7 +448,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return (void *) entry; } #ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { U32 i; for (i = 0; i < klen; ++i) if (isLOWER(key[i])) { @@ -474,7 +483,8 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #endif } /* ISFETCH */ else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { - if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { + if (mg_find((const SV *)hv, PERL_MAGIC_tied) + || SvGMAGICAL((const SV *)hv)) { /* I don't understand why hv_exists_ent has svret and sv, whereas hv_exists only had one. */ SV * const svret = sv_newmortal(); @@ -486,9 +496,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } else { keysv = newSVsv(keysv); } - mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY); + mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY); } else { - mg_copy((SV*)hv, sv, key, klen); + mg_copy(MUTABLE_SV(hv), sv, key, klen); } if (flags & HVhek_FREEKEY) Safefree(key); @@ -499,7 +509,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return SvTRUE(svret) ? (void *)hv : NULL; } #ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { /* XXX This code isn't UTF8 clean. */ char * const keysave = (char * const)key; /* Will need to free this, so set FREEKEY flag. */ @@ -529,9 +539,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (PL_tainting) PL_tainted = SvTAINTED(keysv); keysv = sv_2mortal(newSVsv(keysv)); - mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY); + mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY); } else { - mg_copy((SV*)hv, val, key, klen); + mg_copy(MUTABLE_SV(hv), val, key, klen); } TAINT_IF(save_taint); @@ -541,7 +551,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return NULL; } #ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { /* XXX This code isn't UTF8 clean. */ const char *keysave = key; /* Will need to free this, so set FREEKEY flag. */ @@ -564,7 +574,8 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (!HvARRAY(hv)) { if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ - || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) + || (SvRMAGICAL((const SV *)hv) + && mg_find((const SV *)hv, PERL_MAGIC_env)) #endif ) { char *array; @@ -588,7 +599,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } } - if (is_utf8) { + if (is_utf8 & !(flags & HVhek_KEYCANONICAL)) { char * const keysave = (char *)key; key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) @@ -599,6 +610,11 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (flags & HVhek_FREEKEY) Safefree(keysave); flags |= HVhek_WASUTF8 | HVhek_FREEKEY; + /* If the caller calculated a hash, it was on the sequence of + octets that are the UTF-8 form. We've now changed the sequence + of octets stored to that of the equivalent byte representation, + so the hash we need is different. */ + hash = 0; } } @@ -707,7 +723,8 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ if (!(action & HV_FETCH_ISSTORE) - && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { + && SvRMAGICAL((const SV *)hv) + && mg_find((const SV *)hv, PERL_MAGIC_env)) { unsigned long len; const char * const env = PerlEnv_ENVgetenv_len(key,&len); if (env) { @@ -860,13 +877,13 @@ Perl_hv_scalar(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_SCALAR; if (SvRMAGICAL(hv)) { - MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied); + MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied); if (mg) return magic_scalarpack(hv, mg); } sv = sv_newmortal(); - if (HvFILL((HV*)hv)) + if (HvFILL((const HV *)hv)) Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv) + 1); else @@ -930,7 +947,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return NULL; /* element cannot be deleted */ } #ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { /* XXX This code isn't UTF8 clean. */ keysv = newSVpvn_flags(key, klen, SVs_TEMP); if (k_flags & HVhek_FREEKEY) { @@ -965,7 +982,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; } - HvHASKFLAGS_on((SV*)hv); + HvHASKFLAGS_on(MUTABLE_SV(hv)); } if (HvREHASH(hv)) { @@ -1332,7 +1349,7 @@ Perl_newHVhv(pTHX_ HV *ohv) return hv; hv_max = HvMAX(ohv); - if (!SvMAGICAL((SV *)ohv)) { + if (!SvMAGICAL((const SV *)ohv)) { /* It's an ordinary hash, so copy it fast. AMS 20010804 */ STRLEN i; const bool shared = !!HvSHAREKEYS(ohv); @@ -1525,7 +1542,7 @@ Perl_hv_clear(pTHX_ HV *hv) Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*); if (SvRMAGICAL(hv)) - mg_clear((SV*)hv); + mg_clear(MUTABLE_SV(hv)); HvHASKFLAGS_off(hv); HvREHASH_off(hv); @@ -1670,7 +1687,8 @@ S_hfreeentries(pTHX_ HV *hv) SvREFCNT_dec(iter->xhv_backreferences); } else { - sv_magic((SV*)hv, (SV*)iter->xhv_backreferences, + sv_magic(MUTABLE_SV(hv), + MUTABLE_SV(iter->xhv_backreferences), PERL_MAGIC_backref, NULL, 0); } iter->xhv_backreferences = NULL; @@ -1685,8 +1703,17 @@ S_hfreeentries(pTHX_ HV *hv) iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ if((meta = iter->xhv_mro_meta)) { - if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs); - if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3); + 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); @@ -1793,7 +1820,7 @@ Perl_hv_undef(pTHX_ HV *hv) HvPLACEHOLDERS_set(hv, 0); if (SvRMAGICAL(hv)) - mg_clear((SV*)hv); + mg_clear(MUTABLE_SV(hv)); } static struct xpvhv_aux* @@ -1985,7 +2012,7 @@ Perl_hv_kill_backrefs(pTHX_ HV *hv) { if (av) { HvAUX(hv)->xhv_backreferences = 0; - Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av); + Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av); SvREFCNT_dec(av); } } @@ -2046,7 +2073,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ if (SvMAGICAL(hv) && SvRMAGICAL(hv)) { - if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) { + if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) { SV * const key = sv_newmortal(); if (entry) { sv_setsv(key, HeSVKEY_force(entry)); @@ -2059,12 +2086,12 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /* 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); + Newxz(k, HEK_BASESIZE + sizeof(const SV *), char); hek = (HEK*)k; HeKEY_hek(entry) = hek; HeKLEN(entry) = HEf_SVKEY; } - magic_nextpack((SV*) hv,mg,key); + magic_nextpack(MUTABLE_SV(hv),mg,key); if (SvOK(key)) { /* force key to stay around until next time */ HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key)); @@ -2079,7 +2106,8 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) } } #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */ - if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { + if (!entry && SvRMAGICAL((const SV *)hv) + && mg_find((const SV *)hv, PERL_MAGIC_env)) { prime_env_iter(); #ifdef VMS /* The prime_env_iter() on VMS just loaded up new hash values @@ -2203,12 +2231,12 @@ Perl_hv_iterval(pTHX_ HV *hv, register HE *entry) PERL_ARGS_ASSERT_HV_ITERVAL; if (SvRMAGICAL(hv)) { - if (mg_find((SV*)hv, PERL_MAGIC_tied)) { + if (mg_find((const SV *)hv, PERL_MAGIC_tied)) { SV* const sv = sv_newmortal(); if (HeKLEN(entry) == HEf_SVKEY) - mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY); + mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY); else - mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry)); + mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry)); return sv; } } @@ -2490,12 +2518,12 @@ I32 * Perl_hv_placeholders_p(pTHX_ HV *hv) { dVAR; - MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash); + MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P; if (!mg) { - mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0); + mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0); if (!mg) { Perl_die(aTHX_ "panic: hv_placeholders_p"); @@ -2520,14 +2548,14 @@ void Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) { dVAR; - MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash); + MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET; if (mg) { mg->mg_len = ph; } else if (ph) { - if (!sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, ph)) + if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph)) Perl_die(aTHX_ "panic: hv_placeholders_set"); } /* else we don't need to add magic to record 0 placeholders. */ @@ -2768,7 +2796,7 @@ Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, if (SvPOK(value)) { value_type = HVrhek_PV; } else if (SvIOK(value)) { - value_type = SvUOK((SV*)value) ? HVrhek_UV : HVrhek_IV; + value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; } else if (value == &PL_sv_placeholder) { value_type = HVrhek_delete; } else if (!SvOK(value)) { @@ -2831,9 +2859,9 @@ S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char); he->refcounted_he_val.refcounted_he_u_len = value_len; } else if (value_type == HVrhek_IV) { - he->refcounted_he_val.refcounted_he_u_iv = SvIVX((SV *)value); + he->refcounted_he_val.refcounted_he_u_iv = SvIVX((const SV *)value); } else if (value_type == HVrhek_UV) { - he->refcounted_he_val.refcounted_he_u_uv = SvUVX((SV *)value); + he->refcounted_he_val.refcounted_he_u_uv = SvUVX((const SV *)value); } PERL_HASH(hash, key_p, key_len); @@ -2983,7 +3011,7 @@ Perl_hv_assert(pTHX_ HV *hv) } else if (HeKWASUTF8(entry)) withflags++; } - if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { + if (!SvTIED_mg((const 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); @@ -3004,7 +3032,7 @@ Perl_hv_assert(pTHX_ HV *hv) bad = 1; } if (bad) { - sv_dump((SV *)hv); + sv_dump(MUTABLE_SV(hv)); } HvRITER_set(hv, riter); /* Restore hash iterator state */ HvEITER_set(hv, eiter);